# HG changeset patch
# User sergey
# Date 1334787002 -14400
# Node ID 6b1dda99883933afe907b487ee2456e42939d278
# Parent  a705e848dcc7878de3d5684726e1dc07229913db
Added IMPL::declare, IMPL::require, to simplify module definitions
IMPL::Transform now admires object inheritance while searching for the transformation
Added HTTP some exceptions
IMPL::Web::Application::RestResource almost implemented

diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/Exception.pm
--- a/Lib/IMPL/Exception.pm	Mon Apr 16 17:42:54 2012 +0400
+++ b/Lib/IMPL/Exception.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -90,7 +90,9 @@
 
 package IMPL::InvalidArgumentException;
 our @ISA = qw(IMPL::Exception);
-__PACKAGE__->PassThroughArgs;
+our %CTOR = (
+    'IMPL::Exception' => sub { "An invalid argument", @_ }
+);
 
 package IMPL::DuplicateException;
 our @ISA = qw(IMPL::Exception);
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/Object/Abstract.pm
--- a/Lib/IMPL/Object/Abstract.pm	Mon Apr 16 17:42:54 2012 +0400
+++ b/Lib/IMPL/Object/Abstract.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -31,6 +31,8 @@
                     $this->$_($mapper->(@_)) foreach @$superSequence;
                 } if @$superSequence;
             }
+        } elsif ($mapper and not ref $mapper and $mapper eq '@_') {
+        	push @sequence,@$superSequence;
         } else {
             warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper;
             push @sequence, sub {
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/Transform.pm
--- a/Lib/IMPL/Transform.pm	Mon Apr 16 17:42:54 2012 +0400
+++ b/Lib/IMPL/Transform.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -1,36 +1,40 @@
 package IMPL::Transform;
+use strict;
+
 use parent qw(IMPL::Object);
 
-use IMPL::Class::Property;
+use IMPL::lang qw(:declare :constants);
+
 use IMPL::Class::Property::Direct;
 
 BEGIN {
-    protected _direct property Templates => prop_all;
-    protected _direct property Default => prop_all;
-    protected _direct property Plain => prop_all;
+    public _direct property templates => PROP_ALL;
+    public _direct property default => PROP_ALL;
+    public _direct property plain => PROP_ALL;
+    private _direct property _cache => PROP_ALL;
 }
 
 sub CTOR {
     my ($this,%args) = @_;
     
-    $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 {
     my ($this,$object,@args) = @_;
     
     if (not ref $object) {
-        die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$Plain};
-        my $template = $this->{$Plain};
+        die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$plain};
+        my $template = $this->{$plain};
         return $this->$template($object,@args);
     } else {
     
-        my $template = $this->MatchTemplate($object) || $this->Default or die new IMPL::Transform::NoTransformException(ref $object);
+        my $template = $this->MatchTemplate($object) || $this->default or die new IMPL::Transform::NoTransformException(ref $object);
     
-        return $this->$template($object,@args);
+        return $this->ProcessTemplate($template,$object,\@args);
     }
 }
 
@@ -38,11 +42,37 @@
     my ($this,$object) = @_;
     my $class = $this->GetClassForObject( $object );
     
-    foreach my $tClass ( keys %{$this->Templates || {}} ) {
-        return $this->Templates->{$tClass} if ($tClass eq $class);
+    if (my $t = $this->{$_cache}->{$class} ) {
+    	return $t;
+    } else {
+    	$t = $this->{$templates}->{$class};
+    	
+    	return $this->{$_cache}->{$class} = $t if $t;
+    	
+    	{
+            no strict 'refs';
+    	
+            my @isa = @{"${class}::ISA"};
+            
+            while (@isa) {
+            	my $sclass = shift @isa;
+            	
+            	$t = $this->{$templates}->{$sclass};
+            	
+            	return $this->{$_cache}->{$class} = $t if $t;
+            	
+            	push @isa, @{"${sclass}::ISA"};
+            } 
+    	};
     }
 }
 
+sub ProcessTemplate {
+	my ($this,$t,$obj,$args) = @_;
+	
+	return $this->$t($obj,@$args);
+}
+
 sub GetClassForObject {
     my ($this,$object) = @_;
     
@@ -50,11 +80,11 @@
 }
 
 package IMPL::Transform::NoTransformException;
-use parent qw(IMPL::Exception);
-
-our %CTOR = (
-    'IMPL::Exception' => sub { 'No transformation', @_ }
-);
+use IMPL::declare {
+	base => {
+		'IMPL::Exception' =>  sub { 'No transformation', @_ }
+	}
+};
 
 1;
 
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/Web/Application/RestResource.pm
--- a/Lib/IMPL/Web/Application/RestResource.pm	Mon Apr 16 17:42:54 2012 +0400
+++ b/Lib/IMPL/Web/Application/RestResource.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -1,6 +1,139 @@
 package IMPL::Web::Application::RestResource;
 use strict;
 
+use IMPL::lang qw(:declare :constants);
+use IMPL::declare {
+	require => {
+		ForbiddenException => 'IMPL::Web::ForbiddenException'
+	},
+	base => {
+		'IMPL::Object' => undef
+	}
+};
+
+BEGIN {
+	public property target => PROP_GET | PROP_OWNERSET;
+	public property methods => PROP_GET | PROP_OWNERSET;
+	public property childRegex => PROP_GET | PROP_OWNERSET;
+	public property list => PROP_GET | PROP_OWNERSET;
+	public property fetch => PROP_GET | PROP_OWNERSET;
+	public property insert => PROP_GET | PROP_OWNERSET;
+	public property update => PROP_GET | PROP_OWNERSET;
+	public property delete => PROP_GET | PROP_OWNERSET;
+}
+
+sub GetHttpImpl {
+	my($this,$method) = @_;
+	
+	my %map = (
+		GET => 'GetImpl',
+        PUT => 'PutImpl',
+        POST => 'PostImpl',
+        DELETE => 'DeleteImpl'
+	);
+	
+	return $map{$method};
+}
+
+sub InvokeHttpMethod {
+	my ($this,$method,$child,$action) = @_;
+	
+	my $impl = $this->GetHttpImpl($method) || 'FallbackImpl';
+	
+	return $this->$impl($child,$action);
+}
+
+sub GetImpl {
+    my ($this,$id,$action) = @_;
+    
+    my $rx;
+    my $method;
+    if (length $id == 0) {
+    	$method = $this->list;
+    } elsif ($method = $this->methods->{$id}) {
+    	if (ref $method eq 'HASH' and not $method->{allowGet}) {
+    		die ForbiddenException->new();
+    	}
+    } elsif($rx = $this->childRegex and $id =~ m/$rx/ ) {
+    	$method = $this->fetch or die ForbiddenException->new();
+        
+        $method = {
+        	method => $method,
+        	parameters => [qw(id)]
+        } unless ref $method;
+        
+    } else {    
+        die ForbiddenException->new();
+    }
+    
+    return $this->InvokeMember($method,$id,$action);
+}
+
+sub PutImpl {
+	my ($this,$id,$action) = @_;
+	
+	my $rx = $this->childRegex;
+	if ( $rx and $id =~ m/$rx/ and $this->update ) {
+		my $method = $this->update or die ForbiddenException->new();
+		
+		$method = {
+			method => $method,
+			parameters => [qw(id query)]
+		} unless ref $method;
+		
+		return $this->InvokeMember($method,$id,$action);
+	} else {	
+	   die ForbiddenException->new();	   
+	}
+}
+
+sub PostImpl {
+	my ($this,$id,$action) = @_;
+	
+	my $method;
+	
+	if (length $id == 0) {
+		$method = $this->insert or die ForbiddenException->new();
+		
+		$method = {
+			method => $method,
+			parameters => [qw(query)]
+		} unless ref $method;
+	} elsif ($method = $this->methods->{$id}) {
+		die ForbiddenException->new() unless ref $method and $method->{allowPost}; 
+	} else {
+		die ForbiddenException->new();
+	}
+	
+	return $this->InvokeMemeber($method,$id,$action);
+}
+
+sub DeleteImpl {
+	my ($this,$id,$action) = @_;
+	
+	my $rx = $this->childRegex;
+	if ($rx and $id =~ m/$rx/ and my $method = $this->delete) {
+		
+		$method = {
+			method => $method,
+			parameters => [qw(id)]
+		} unless ref $method;
+		
+		return $this->InvokeMember($method,$id,$action);
+	} else {
+		die ForbiddenException->new();
+	}
+}
+
+sub HttpFallbackImpl {
+	die ForbiddenException->new();
+}
+
+sub InvokeMember {
+	my ($this,$method,$id,$action) = @_;
+}
+
+
 1;
 
 __END__
@@ -11,6 +144,138 @@
 
 C<IMPL::Web::Application::RestResource> - ресурс Rest вебсервиса.
 
+=head1 SYNOPSIS
+
+=begin text
+
+[REQUEST]
+GET /artists
+
+[RESPONSE]
+<artists>
+    <artist id="1">
+        <name>The Beatles <name/>
+    </atrist>
+    <artist id="2">
+        <name>Bonobo</name>
+    </artist>
+</artists>
+
+[REQUEST]
+GET /artists/1/cds?title='Live at BBC'
+
+[RESPONSE]
+<cds>
+    <cd id="14">
+        <title>Live at BBC 1</title>
+    </cd>
+    <cd id="15">
+        <title>Live at BBC 2</title>
+    </cd>
+</cds>
+
+[REQUEST]
+GET /cds/15
+
+[RESPONSE]
+<cd id="15">
+    <title>Live at BBC 2</title>
+</cd>
+
+=end text
+
+=begin code
+
+use IMPL::require {
+	TRes => 'IMPL::Web:Application::RestResource',
+	DataContext => 'My::App::DataContext'
+};
+
+my $cds = TRes->new(
+    DataContext->Default,
+    {
+    	methods => {
+    		get => {
+    			
+    		},
+    		post => {
+    			
+    		}
+    	}
+    	get => 'search',
+    	
+    	
+    }   
+);
+
+=end code
+
 =head1 DESCRIPTION
 
+Каждый ресурс представляет собой коллекцию и реализует методы C<HTTP> C<GET,POST,PUT,DELETE>.
+
+=head2 HTTP METHODS
+
+=head3 C<GET>
+
+Возвращает коллекцию дочерних ресурсов.
+
+=head3 C<GET {id}>
+
+Возвращает дочерний объект с идентификатором C<id>
+
+=head3 C<GET {method}>
+
+Вызывает метод C<method> и возвращает его результаты. При публикации методов доступных
+через C<GET> данные методы не должны вносить изменений в предметную область.
+
+=head3 C<PUT {id}>
+
+Обновляет дочерний ресурс с указанным идентификатором.
+
+=head3 C<DELETE {id}>
+
+Удаляет дочерний ресурс с указанным идентификатором.
+
+=head3 C<POST>
+
+Добавляет новый дочерний ресурс в коллекцию.
+
+=head2 HTTP METHOD MAPPING 
+
+=head3 C<POST {method}>
+
+Вызывает метод C<method>, в отличии от C<GET> методы опубликованные через C<POST> могут вносить
+изменения в объекты. 
+
+=head1 MEMBERS
+
+=head2 C<[get]target>
+
+Объект (также может быть и класс), обеспечивающий функционал ресурса.
+
+=head2 C<[get]methods>
+
+=head2 C<[get]childRegex>
+
+=head2 C<[get]fetch>
+
+=head2 C<[get]list>
+
+=head2 C<[get]insert>
+
+=head2 C<[get]update>
+
+=head2 C<[get]delete>
+
+=head2 C<GetImpl($child,$action)>
+
+=head2 C<PutImpl($child,$action)>
+
+=head2 C<PostImpl($child,$action)>
+
+=head2 C<DeleteImpl($child,$action)>
+
+=head2 C<InvokeMember($memberInfo,$child,$action)>
+
 =cut
\ No newline at end of file
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/Web/Exception.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Web/Exception.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -0,0 +1,49 @@
+package IMPL::Web::Exception;
+use strict;
+use warnings;
+
+use parent qw(IMPL::Exception);
+
+__PACKAGE__->PassThroughArgs;
+
+sub code {
+	400;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::Web::Exception> - Базовый класс для всех web-исключенийю
+
+=head1 SYNOPSIS
+
+Вызов исключения
+
+=begin code
+
+use IMPL::require {
+	WebException => 'IMPL::Web::WebException'
+};
+
+sub MyWebHandler {
+	# ...
+	
+	die WebException->new("something is wrong"); 
+	
+	# ...	
+}
+
+=end code
+
+=head1 MEMBERS
+
+=head2 C<code()>
+
+Возвращает C<HTTP> код ошибки.
+
+=cut
\ No newline at end of file
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/Web/ForbiddenException.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Web/ForbiddenException.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -0,0 +1,24 @@
+package IMPL::Web::ForbiddenException;
+use strict;
+
+use IMPL::declare {
+	base => {
+		'IMPL::Web::Exception' => '@_'
+	}
+};
+
+sub code {
+	403
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::Web::ForbiddenException> - операция не разрешается.
+
+=cut
\ No newline at end of file
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/Web/Handler/RestController.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Web/Handler/RestController.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -0,0 +1,62 @@
+package IMPL::Web::Handler::RestController;
+use strict;
+
+use IMPL::lang qw(:declare :constants);
+
+use IMPL::declare {
+	require => {
+        NotFoundException => 'IMPL::Web::NotFoundException'
+	},
+	base => {
+		'IMPL::Object' => undef,
+	}	
+};
+
+BEGIN {
+	public property rootResource => PROP_GET | PROP_OWNERSET;
+	public property contract => PROP_GET | PROP_OWNERSET;
+}
+
+sub Invoke {
+	my ($this,$action) = @_;
+	
+	my $query = $action->query;
+	
+	my $method = $query->request_method;
+	
+	#TODO: path_info is broken for IIS
+	my $pathInfo = $query->path_info;
+	
+	my @segments = split /\//, $pathInfo;
+	
+	my ($obj,$view) = (pop(@segments) =~ m/(.*?)(?:\.(\w+))?$/);
+	
+	$action->context->{view} = $view;
+	
+	my $res = $this->rootResource;
+	
+	while(@segments) {
+		$res = $res->InvokeHttpMethod('GET',shift @segments);
+		
+		die NotFoundException->new() unless $res;
+	}
+	
+	return $res->InvokeHttpMethod($method,$obj);
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Использует C<$ENV{PATH_INFO}> для получения ресурса и вызова метода.
+
+
+=cut
\ No newline at end of file
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/Web/NotFoundException.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Web/NotFoundException.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -0,0 +1,24 @@
+package IMPL::Web::NotFoundException;
+use strict;
+
+use IMPL::declare {
+	base => {
+        'IMPL::Web::Exception' => '@_'	
+    }
+};
+
+sub code {
+	404;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::Web::NotFoundException> Исключение для несущесьвующего ресурса.
+
+=cut
\ No newline at end of file
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/declare.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/declare.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -0,0 +1,146 @@
+package IMPL::declare;
+use strict;
+
+use Scalar::Util qw(set_prototype);
+
+sub import {
+	my ($self,$args) = @_;
+	
+	return unless $args;
+    
+    die "A hash reference is required" unless ref $args eq 'HASH';
+    
+    no strict 'refs';
+	
+	my $caller = caller;
+	
+	my $aliases = $args->{require} || {};
+	
+	while( my ($alias, $class) = each %$aliases ) {
+		_require($class);
+        
+        *{"${caller}::$alias"} = set_prototype(sub {
+            $class
+        }, '');
+    }
+    
+    my $base = $args->{base} || {};
+    
+    my %ctor;
+    my @isa;
+    
+    if (ref $base eq 'ARRAY') {
+    	@isa = map _require($_), @$base if @$base;
+    } elsif (ref $base eq 'HASH' ) {
+    	while ( my ($class,$mapper) = each %$base ) {
+    		$class = $aliases->{$class} || _require($class);
+    		
+    		push @isa,$class;
+    		$ctor{$class} = $mapper;
+    	}
+    }
+    
+    *{"${caller}::CTOR"} = \%ctor;
+    *{"${caller}::ISA"} = \@isa;
+}
+
+sub _require {
+	my ($class) = @_;
+	
+	if (not $class =~ s/^-//) {
+		(my $file = $class) =~ s/::|'/\//g;
+		require "$file.pm";
+	}
+	$class;
+}
+
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::declare> - описывает класс
+
+=head1 SYNOPSIS
+
+=begin code
+
+package My::Bar;
+
+use IMPL::declare {
+	require => {
+		TFoo => 'My::Foo',
+		TBox => 'My::Box'
+	},
+	base => {
+		TFoo => '@_',
+		'IMPL::Object' => undef,
+	}
+}
+
+sub CreateBox {
+	my ($this) = @_;
+	return TBox->new($this);
+}
+
+=end code
+
+Специальная ситрока C<@_> означает передачу параметров конструктора текущего класса конструктору
+базового класса без изменений.
+
+=head1 DESCRIPTION
+
+Описывает текущий пакет(модуль) как класс. В качестве параметра получает ссылку на хеш,
+в которой храняться метаданные для объявления класса.
+
+=head1 METADATA
+
+=head2 C<require>
+
+Содержит ссылку на хеш с синонимами модулей, которые будут доступны в текушем модуле,
+аналогично использованию C<IMPL::require>. Однако, если модуль не требует загрузки при
+помощи C<require> нужно использовать префикс C<'-'> в его имени
+
+=begin code
+
+{
+	require => {
+		TObject => 'IMPL::Object', # will be loaded with require
+		TFoo => '-My:App::Data::Foo' # will not use 'require' to load module
+	}
+}
+
+=end code
+
+=head2 C<base>
+
+Обисывает базове классы для текущего класса. Если данный параметр - ссылка массив, то
+этот массив будет превращен в массив C<@ISA>. Если данный параметр - ссылка на хеш, то
+его ключи опичавют список базовых классов, а значения - преобразование параметров для
+вызова базовых конструкторов.
+
+В качестве имен базовых классов могут быть как полные имена модулей, так и назначенные
+ранее псевдонимы. Использование префикса C<'-'> перед B<полным именем модуля> означает,
+что модуль не требуется загружать, в случае с псевдонимами, префикс C<'-'> уже был указан
+при их объявлении.
+
+=begin code
+
+{
+    require => {
+        TFoo => '-My:App::Data::Foo' # will not use 'require' to load module
+    },
+    base => {
+    	TFoo => '@_', # pass parameters unchanged
+    	'My::Base::Class' => sub { name => $_[0], data => $_[1] },  # remap parameters
+    	'-My::Extentions' => undef, # do not pass any parameters
+    }
+}
+
+=end code
+
+=cut
\ No newline at end of file
diff -r a705e848dcc7 -r 6b1dda998839 Lib/IMPL/require.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/require.pm	Thu Apr 19 02:10:02 2012 +0400
@@ -0,0 +1,56 @@
+package IMPL::require;
+use Scalar::Util qw(set_prototype);
+
+sub import {
+	my ($self, $aliases) = @_;
+	
+	return unless $aliases;
+	
+	die "A hash reference is required" unless ref $aliases eq 'HASH';
+	
+	my $caller = $caller;
+	
+	no strict 'refs';
+	
+	while( my ($alias, $class) = each %$aliases ) {
+		(my $file = $class) =~ s/::|'/\//g;
+		require "$file.pm";
+		
+		*{"${caller}::$alias"} = set_prototype(sub {
+            $class
+        }, '');
+	}
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::require> загружает и назначет псевдонимы модулям.
+
+=head1 SYNOPSIS
+
+=begin code
+
+use IMPL::require {
+	TFoo => 'My::Nested::Package::Foo',
+	FS => 'File::Spec'
+};
+
+my $obj = My::Nested::Package::Foo->new('foo');
+$obj = TFoo->new('foo'); # ditto
+
+FS->catdir('one','two','three');
+
+=end code
+
+=head1 DESCRIPTION
+
+Загружает модули с помощью C<require> и создает константы которые возвращаю полное имя модуля.
+
+
+=cut
\ No newline at end of file
diff -r a705e848dcc7 -r 6b1dda998839 _test/temp.pl
--- a/_test/temp.pl	Mon Apr 16 17:42:54 2012 +0400
+++ b/_test/temp.pl	Thu Apr 19 02:10:02 2012 +0400
@@ -1,44 +1,29 @@
 #!/usr/bin/perl
 use strict;
-use Time::HiRes qw(gettimeofday tv_interval);
+
+package Bar;
 
-sub func {
-    1;
-}
-
-my $t0 = [gettimeofday()];
-
-for(my $i = 0; $i < 1000000; $i++) {
-    func(1);
+sub CTOR {
+	shift;
+	warn @_;
 }
 
-print tv_interval($t0),"\n";
-
-my $fn = sub { 1; };
+package Foo;
 
-$t0 = [gettimeofday()];
+use IMPL::declare {
+	require => {
+		TObject => 'IMPL::Object'
+	},
+	base => {
+		TObject => '@_',
+		-Bar => '@_'
+	}
+};
 
-for(my $i = 0; $i < 1000000; $i++) {
-    &$fn(1);
+sub hello {
+	return TObject;
 }
 
-print tv_interval($t0),"\n";
-
-sub dummy() { 0; }
-
-$t0 = [gettimeofday()];
-
-for(my $i = 0; $i < 1000000; $i++) {
-    dummy;
-}
+package main;
 
-print tv_interval($t0),"\n";
-
-$t0 = [gettimeofday()];
-
-for(my $i = 0; $i < 1000000; $i++) {
-    1;
-}
-
-print tv_interval($t0),"\n";
-
+print Foo->new(qw(one for me))->hello;
\ No newline at end of file