Mercurial > pub > Impl
changeset 198:2ffe6f661605
Implemented IMPL::Web::Handler::RestController
fixes in IMPL::Serialization
completed IMPL::Web::Application::RestResource
added IMPL::Web::Handler::JSONView
added IMPL::Web::RestContract
author | cin |
---|---|
date | Fri, 20 Apr 2012 16:06:36 +0400 |
parents | 6b1dda998839 |
children | e743a8481327 |
files | Lib/IMPL/Config/Reference.pm Lib/IMPL/Object/Autofill.pm Lib/IMPL/Serialization.pm Lib/IMPL/Transform.pm Lib/IMPL/Web/Application.pm Lib/IMPL/Web/Application/RestResource.pm Lib/IMPL/Web/Handler/JSONView.pm Lib/IMPL/Web/Handler/RestController.pm Lib/IMPL/Web/RestContract.pm Lib/IMPL/declare.pm _test/temp.pl |
diffstat | 11 files changed, 436 insertions(+), 91 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/Config/Reference.pm Thu Apr 19 02:10:02 2012 +0400 +++ b/Lib/IMPL/Config/Reference.pm Fri Apr 20 16:06:36 2012 +0400 @@ -3,8 +3,6 @@ use IMPL::Exception; -__PACKAGE__->PassThroughArgs; - sub restore { my ($self,$data,$surrogate) = @_; @@ -13,9 +11,8 @@ my ($tagTarget,$target) = splice @$data, 0, 2; die new IMPL::Exception('A traget tag must be the first tag in the reference specification') unless $tagTarget eq 'target'; - while(my ($method,$args) = splice @$data, 0, 2 ) { - $target = $self->_Invoke({ method => $method, args => $args}); + $target = $self->_InvokeMember($target,{ method => $method, args => $args}); } return $target; } @@ -24,9 +21,7 @@ my ($self,$object,$member) = @_; my $method = $member->{method}; - - local $@; - return eval { + return ref $object eq 'HASH' ? $object->{$method} : @@ -36,7 +31,7 @@ : () ) - }; + ; } sub _as_list {
--- a/Lib/IMPL/Object/Autofill.pm Thu Apr 19 02:10:02 2012 +0400 +++ b/Lib/IMPL/Object/Autofill.pm Fri Apr 20 16:06:36 2012 +0400 @@ -82,9 +82,22 @@ __END__ =pod + +=head1 NAME + +C<IMPL::Object::Autofill> - автозаполнение объектов + =head1 SYNOPSIS + +=begin code + package MyClass; -use parent qw(IMPL::Object IMPL::Object::Autofill); +use IMPL::declare { + base => { + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + } +}; BEGIN { private property PrivateData => prop_all; @@ -93,18 +106,17 @@ sub CTOR { my $this = shift; - $this->superCTOR(@_); - # or eqvivalent - # $this->supercall::CTOR(@_); - + print $this->PrivateData,"\n"; print $this->PublicData,"\n"; } my $obj = new MyClass(PrivateData => 'private', PublicData => 'public', Other => 'some data'); -will print -private -public +#will print +#private +#public + +=end code =cut
--- a/Lib/IMPL/Serialization.pm Thu Apr 19 02:10:02 2012 +0400 +++ b/Lib/IMPL/Serialization.pm Fri Apr 20 16:06:36 2012 +0400 @@ -242,7 +242,7 @@ return 1; } - my $refObj = $this->{$ObjectFactory} ?$this->{$ObjectFactory}->($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef) : DefaultFactory($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef); + my $refObj = $this->{$ObjectFactory} ?$this->{$ObjectFactory}->($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef) : DefaultFactory($rhObject->{'Type'},$rhObject->{'Data'} || [],$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef); die new Exception("Trying to close a non existing oject") if not $rhObject; @@ -284,6 +284,15 @@ scalar keys %{"$_[0]::"} ? 1 : 0; } +{ + my %classes; + sub _load_class { + my $class = shift; + $classes{$class} = 1; + eval "require $class"; + } +} + sub DefaultSurrogateHelper { my ($Type) = @_; @@ -295,7 +304,7 @@ } elsif ($Type eq 'HASH') { return {}; } elsif ($Type) { - eval "require $Type" unless _is_class($Type); + _load_class($Type); if (UNIVERSAL::can($Type,'surrogate')) { return $Type->surrogate(); } else { @@ -350,7 +359,7 @@ return $refSurogate; } } else { - eval "require $Type; 1;" or warn $@ unless _is_class($Type); + _load_class($Type); if ( $Type->UNIVERSAL::can('restore') ) { return $Type->restore($Data,$refSurogate); } else {
--- a/Lib/IMPL/Transform.pm Thu Apr 19 02:10:02 2012 +0400 +++ b/Lib/IMPL/Transform.pm Fri Apr 20 16:06:36 2012 +0400 @@ -15,12 +15,13 @@ } sub CTOR { - my ($this,%args) = @_; + my $this = shift; + my $args = @_ == 1 ? shift : { @_ }; - $this->{$plain} = delete $args{-plain}; - $this->{$default} = delete $args{-default}; + $this->{$plain} = delete $args->{-plain}; + $this->{$default} = delete $args->{-default}; - $this->{$templates} = \%args; + $this->{$templates} = $args; } sub Transform { @@ -59,6 +60,7 @@ $t = $this->{$templates}->{$sclass}; + #cache and return return $this->{$_cache}->{$class} = $t if $t; push @isa, @{"${sclass}::ISA"};
--- a/Lib/IMPL/Web/Application.pm Thu Apr 19 02:10:02 2012 +0400 +++ b/Lib/IMPL/Web/Application.pm Fri Apr 20 16:06:36 2012 +0400 @@ -2,29 +2,46 @@ use strict; use warnings; -use parent qw(IMPL::Config IMPL::Object::Singleton); +use IMPL::lang qw(:declare :constants); +use CGI; +use Carp qw(carp); -require IMPL::Web::Application::Action; -require IMPL::Web::Application::Response; - -use IMPL::Class::Property; -use CGI; +use IMPL::declare { + require => { + TAction => 'IMPL::Web::Application::Action', + TResponse => 'IMPL::Web::Application::Response', + TFactory => '-IMPL::Object::Factory' + }, + base => { + 'IMPL::Config' => '@_', + 'IMPL::Object::Singleton' => '@_' + } +}; -__PACKAGE__->PassThroughArgs; +BEGIN { + public property handlerError => PROP_ALL; + public property actionFactory => PROP_ALL; + public property handlers => PROP_ALL | PROP_LIST; + public property responseCharset => PROP_ALL; + public property security => PROP_ALL; + public property options => PROP_ALL; + public property fetchRequestMethod => PROP_ALL; +} -public property handlerError => prop_all; -public property actionFactory => prop_all; -public property handlersQuery => prop_all | prop_list; -public property responseCharset => prop_all; -public property security => prop_all; -public property options => prop_all; -public property fetchRequestMethod => prop_all; + +#TODO: remove +sub handlersQuery { + carp "handlersQuery is obsolete use handlers instead"; + goto &handlers; +} sub CTOR { my ($this) = @_; - $this->actionFactory(typeof IMPL::Web::Application::Action) unless $this->actionFactory; + die IMPL::InvalidArgumentException->new("handlers","At least one handler should be supplied") unless $this->handlers->Count; + + $this->actionFactory(TAction) unless $this->actionFactory; $this->responseCharset('utf-8') unless $this->responseCharset; $this->fetchRequestMethod(\&defaultFetchRequest) unless $this->fetchRequestMethod; $this->handlerError(\&defaultHandlerError) unless $this->handlerError; @@ -33,6 +50,10 @@ sub Run { my ($this) = @_; + my $handler; + + $handler = _ChainHandler($_,$handler) foreach $this->handlers; + while (my $query = $this->FetchRequest()) { my $action = $this->actionFactory->new( @@ -43,9 +64,7 @@ eval { $action->response->charset($this->responseCharset); - $action->ChainHandler($_) foreach $this->handlersQuery; - - $action->Invoke(); + $handler->($action); $action->response->Complete; }; @@ -57,6 +76,45 @@ } } +sub _ChainHandler { + my ($handler,$next) = @_; + + if (ref $handler eq 'CODE') { + return sub { + my ($action) = @_; + return $handler->($action,$next); + }; + } elsif (eval { $handler->can('Invoke') } ) { + return sub { + my ($action) = @_; + return $handler->Invoke($action,$next); + }; + } elsif (eval{ $handler->isa(TFactory) }) { + return sub { + my ($action) = @_; + my $inst = $handler->new(); + return $inst->Invoke($action,$next); + } + } elsif ($handler and not ref $handler and $handler =~ m/^(-)?(\w+(?:::\w+)*)$/) { + my $class = $2; + if (not $1) { + my $mod = $class; + $mod =~ s/::/\//g; + require "$mod.pm"; + + die IMPL::InvalidArgumentException->("An invalid handler supplied",$handler) unless $class->can('Invoke'); + } + + return sub { + my ($action) = @_; + my $inst = $class->new(); + return $inst->Invoke($action,$next); + }; + } else { + die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler); + } +} + sub FetchRequest { my ($this) = @_;
--- a/Lib/IMPL/Web/Application/RestResource.pm Thu Apr 19 02:10:02 2012 +0400 +++ b/Lib/IMPL/Web/Application/RestResource.pm Fri Apr 20 16:06:36 2012 +0400 @@ -1,13 +1,19 @@ package IMPL::Web::Application::RestResource; use strict; -use IMPL::lang qw(:declare :constants); +use IMPL::lang qw(:declare :constants is); +use IMPL::Exception(); + use IMPL::declare { require => { - ForbiddenException => 'IMPL::Web::ForbiddenException' + ForbiddenException => 'IMPL::Web::ForbiddenException', + InvalidOpException => '-IMPL::InvalidOperationException', + ArgumentException => '-IMPL::InvalidArgumentException', + TTransform => '-IMPL::Transform' }, base => { - 'IMPL::Object' => undef + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' } }; @@ -22,6 +28,12 @@ public property delete => PROP_GET | PROP_OWNERSET; } +sub CTOR { + my ($this) = @_; + + die ArgumentException->new("target") unless $this->target; +} + sub GetHttpImpl { my($this,$method) = @_; @@ -36,11 +48,11 @@ } sub InvokeHttpMethod { - my ($this,$method,$child,$action) = @_; + my ($this,$method,$childId,$action) = @_; - my $impl = $this->GetHttpImpl($method) || 'FallbackImpl'; + my $impl = $this->GetHttpImpl($method) || 'HttpFallbackImpl'; - return $this->$impl($child,$action); + return $this->$impl($childId,$action); } sub GetImpl { @@ -49,8 +61,8 @@ my $rx; my $method; if (length $id == 0) { - $method = $this->list; - } elsif ($method = $this->methods->{$id}) { + $method = $this->list or die ForbiddenException->new(); + } elsif ($this->methods and $method = $this->methods->{$id}) { if (ref $method eq 'HASH' and not $method->{allowGet}) { die ForbiddenException->new(); } @@ -62,8 +74,6 @@ parameters => [qw(id)] } unless ref $method; - } else { - die ForbiddenException->new(); } return $this->InvokeMember($method,$id,$action); @@ -131,8 +141,57 @@ sub InvokeMember { my ($this,$method,$id,$action) = @_; + + #normalize method info + if (not ref $method) { + $method = { + method => $method + }; + } + + if (ref $method eq 'HASH') { + my @args; + my $member = $method->{method} or die InvalidOpException->new("A member name isn't specified"); + if (my $params = $method->{parameters}) { + if (ref $params eq 'HASH') { + @args = map { + $_, + $this->MakeParameter($params->{$_},$id,$action) + } keys %$params; + } elsif (ref $params eq 'ARRAY') { + @args = map $this->MakeParameter($_,$id,$action), @$params; + } else { + @args = ($this->MakeParameter($params,$id,$action)); + } + } + $this->target->$member(@args); + } else { + die InvalidOpException->new("Unsupported type of the method information", ref $method); + } } +sub MakeParameter { + my ($this,$param,$id,$action) = @_; + + if ($param) { + if (is $param, TTransform ) { + return $param->Transform($this,$action->query); + } elsif ($param and not ref $param) { + my %std = ( + id => $id, + action => $action, + query => $action->query + ); + + return $std{$param} || $action->query->param($param); + } + } else { + return undef; + } +} + + + 1; @@ -195,16 +254,14 @@ DataContext->Default, { methods => { - get => { - + history => { + allowGet => 1, + method => 'GetHistory', + parameters => [qw(from to)] }, - post => { - - } } - get => 'search', - - + list => 'search', + fetch => 'GetItemById' } ); @@ -241,6 +298,10 @@ Добавляет новый дочерний ресурс в коллекцию. +=head3 C<POST {method}> + +Вызывает метод C<method>. + =head2 HTTP METHOD MAPPING =head3 C<POST {method}> @@ -256,26 +317,161 @@ =head2 C<[get]methods> +Содержит описания методов, которые будут публиковаться как дочерние ресурсы. + =head2 C<[get]childRegex> +Содержит регулярное выражение для идентификаторов дочерних объектов. Если оно +не задано, то данный ресурс не является коллекцией. + =head2 C<[get]fetch> +Содержит описание метода для получения дочернего объекта. Если данный метод +отсутствует, то дочерние ресурсы не получится адресовать относительно данного. +По умолчанию получает идентификатор дочернего ресурса первым параметром. + =head2 C<[get]list> +Описание метода для получения списка дочерних объектов. По умолчанию не +получает параметров. + =head2 C<[get]insert> +Описание метода для добавление дочернего ресурса. По умолчанию получает +объект C<CGI> описывабщий текущий запрос первым параметром. + =head2 C<[get]update> +Описание метода для обновления дочернего ресурса. По умолчанию получает +идентификатор дочернего ресурса и объект C<CGI> текущего запроса. + =head2 C<[get]delete> +Описание метода для удаления дочернего ресурса. По умолчанию получает +идентификатор дочернего ресурса. + =head2 C<GetImpl($child,$action)> +=over + +=item C<$child> + +Идентификатор дочернего ресутсра + +=item C<$action> + +Текущий запрос C<IMPL::Web::Application::Action>. + +=back + +Переадресует запрос нужному методу внутреннего объекта C<target> при +помощи C<InvokeMember>. + =head2 C<PutImpl($child,$action)> +=over + +=item C<$child> + +Идентификатор дочернего ресутсра + +=item C<$action> + +Текущий запрос C<IMPL::Web::Application::Action>. + +=back + +Переадресует запрос нужному методу внутреннего объекта C<target> при +помощи C<InvokeMember>. + =head2 C<PostImpl($child,$action)> +=over + +=item C<$child> + +Идентификатор дочернего ресутсра + +=item C<$action> + +Текущий запрос C<IMPL::Web::Application::Action>. + +=back + +Переадресует запрос нужному методу внутреннего объекта C<target> при +помощи C<InvokeMember>. + =head2 C<DeleteImpl($child,$action)> +=over + +=item C<$child> + +Идентификатор дочернего ресутсра + +=item C<$action> + +Текущий запрос C<IMPL::Web::Application::Action>. + +=back + +Переадресует запрос нужному методу внутреннего объекта C<target> при +помощи C<InvokeMember>. + =head2 C<InvokeMember($memberInfo,$child,$action)> +=over + +=item C<$memberInfo> + +Описание члена внутреннего объекта C<target>, который нужно вызвать. + +=item C<$child> + +Идентификатор дочернего ресутсра + +=item C<$action> + +Текущий запрос C<IMPL::Web::Application::Action>. + +=back + +Вызывает метод внутреннего объекта C<target>, предварительно подготовив +параметры на основе описания C<$memberInfo> и при помощи С<MakeParameter()>. + +=head2 C<MakeParameter($paramDef,$child,$action)> + +=over + +=item C<$paramDef> + +Описание параметра, может быть C<IMPL::Transform> или простая строка. + +Если описание параметра - простая строка, то ее имя либо + +=over + +=item C<id> + +Идентификатор дочернего ресурса + +=item C<query> + +Объект C<CGI> текущего запроса + +=item C<action> + +Текущий запрос C<IMPL::Web::Application::Action> + +=item C<любое другое значение> + +Интерпретируется как параметр текущего запроса. + +=back + +Если описание параметра - объект C<IMPL::Transform>, то будет выполнено это преобразование над C<CGI> +объектом текущего запроса C<< $paramDef->Transform($action->query) >>. + +=back + =cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/Handler/JSONView.pm Fri Apr 20 16:06:36 2012 +0400 @@ -0,0 +1,35 @@ +package IMPL::Web::Handler::JSONView; +use strict; +use JSON; + +use IMPL::lang qw(:declare :constants); +use IMPL::declare { + base => { + 'IMPL::Object' => undef, + 'IMPL::Object::Serializable' => undef, + 'IMPL::Object::Autofill' => '@_' + } +}; + +sub Invoke { + my ($this,$action,$next) = @_; + + my $result = $next->($action); + $result = [$result] unless ref $result; + + $action->response->contentType('text/javascript'); + + my $hout = $action->response->streamBody; + + print $hout JSON->new->utf8->pretty->encode($result); +} + +1; + +__END__ + +=pod + +=head1 + +=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/RestController.pm Thu Apr 19 02:10:02 2012 +0400 +++ b/Lib/IMPL/Web/Handler/RestController.pm Fri Apr 20 16:06:36 2012 +0400 @@ -5,15 +5,18 @@ use IMPL::declare { require => { + HttpException => 'IMPL::Web::Exception', NotFoundException => 'IMPL::Web::NotFoundException' }, base => { 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef } }; BEGIN { - public property rootResource => PROP_GET | PROP_OWNERSET; + public property root => PROP_GET | PROP_OWNERSET; public property contract => PROP_GET | PROP_OWNERSET; } @@ -29,19 +32,22 @@ my @segments = split /\//, $pathInfo; + # remove first segment since it's always empty + shift @segments; + my ($obj,$view) = (pop(@segments) =~ m/(.*?)(?:\.(\w+))?$/); $action->context->{view} = $view; - my $res = $this->rootResource; + my $res = $this->contract->Transform($this->root); while(@segments) { - $res = $res->InvokeHttpMethod('GET',shift @segments); + $res = $this->contract->Transform( $res->InvokeHttpMethod('GET',shift @segments,$action) ); die NotFoundException->new() unless $res; } - return $res->InvokeHttpMethod($method,$obj); + $res = $res->InvokeHttpMethod($method,$obj,$action); } 1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/RestContract.pm Fri Apr 20 16:06:36 2012 +0400 @@ -0,0 +1,57 @@ +package IMPL::Web::RestContract; +use strict; + +use IMPL::lang qw(:declare :constants); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + InvalidOpException => '-IMPL::InvalidOperationException', + ForbiddenException => 'IMPL::Web::ForbiddenException', + TRestResource => 'IMPL::Web::Application::RestResource', + }, + base => { + 'IMPL::Transform' => sub { my %args = @_; $args{resources} }, + 'IMPL::Object::Serializable' => undef + } +}; + +sub CTOR { + my ($this) = @_; + + $this->templates->{-plain} = sub { die ForbiddenException->new(); }; + $this->templates->{-default} = sub { die ForbiddenException->new(); }; + $this->templates->{TRestResource} = sub { $_[0] }; +} + +sub ProcessTemplate { + my ($this,$t,$obj,@args) = @_; + + if (ref $t eq 'HASH') { + my $factory = $t->{factory} || TRestResource; + return $factory->new(%$t, target => $obj); + } elsif (ref $t eq 'CODE') { + return $this->$t($obj,@args); + } else { + die InvalidOpException->new(); + } +} + + + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::RestContract> Описывает правила публикации ресурсов. + +=head1 SYNOPSIS + +=begin code + +=end code + +=cut \ No newline at end of file
--- a/Lib/IMPL/declare.pm Thu Apr 19 02:10:02 2012 +0400 +++ b/Lib/IMPL/declare.pm Fri Apr 20 16:06:36 2012 +0400 @@ -17,10 +17,10 @@ my $aliases = $args->{require} || {}; while( my ($alias, $class) = each %$aliases ) { - _require($class); + my $c = _require($class); *{"${caller}::$alias"} = set_prototype(sub { - $class + $c }, ''); }
--- a/_test/temp.pl Thu Apr 19 02:10:02 2012 +0400 +++ b/_test/temp.pl Fri Apr 20 16:06:36 2012 +0400 @@ -1,29 +1,4 @@ #!/usr/bin/perl use strict; -package Bar; - -sub CTOR { - shift; - warn @_; -} - -package Foo; - -use IMPL::declare { - require => { - TObject => 'IMPL::Object' - }, - base => { - TObject => '@_', - -Bar => '@_' - } -}; - -sub hello { - return TObject; -} - -package main; - -print Foo->new(qw(one for me))->hello; \ No newline at end of file +print join ',', "-some::mod::here" =~ m/^(-)?(\w+(?:::\w+)*)$/; \ No newline at end of file