diff Lib/IMPL/Web/Application/Resource.pm @ 332:04a093f0a5a6

IMPL::Web::Application refactoring: resources are created per client request
author cin
date Sun, 09 Jun 2013 21:48:57 +0400
parents fe725fad2d90
children cd6409f66a5f
line wrap: on
line diff
--- a/Lib/IMPL/Web/Application/Resource.pm	Wed Jun 05 18:21:11 2013 +0400
+++ b/Lib/IMPL/Web/Application/Resource.pm	Sun Jun 09 21:48:57 2013 +0400
@@ -4,132 +4,146 @@
 use URI;
 use IMPL::Const qw(:prop);
 use IMPL::declare {
-    require => {
-        ViewResult          => 'IMPL::Web::ViewResult',
-        Exception           => 'IMPL::Exception',
-        ArgumentException   => '-IMPL::InvalidArgumentException',
-        OperationException  => '-IMPL::InvalidOperationException',
-        NotAllowedException => 'IMPL::Web::NotAllowedException',
-        NotFoundException   => 'IMPL::Web::NotFoundException'
-      },
-      base => [
-        'IMPL::Object'                              => undef,
-        'IMPL::Web::Application::ResourceInterface' => undef
-      ],
-      props => [
-        application => PROP_RO,
-        parent      => PROP_RO,
-        model       => PROP_RO,
-        id          => PROP_RO,
-        contract    => PROP_RO,
-        location    => PROP_RO,
-      ]
+	require => {
+		ViewResult          => 'IMPL::Web::ViewResult',
+		Exception           => 'IMPL::Exception',
+		ArgumentException   => '-IMPL::InvalidArgumentException',
+		OperationException  => '-IMPL::InvalidOperationException',
+		NotAllowedException => 'IMPL::Web::NotAllowedException',
+		NotFoundException   => 'IMPL::Web::NotFoundException'
+	  },
+	  base => [
+		'IMPL::Object'                              => undef,
+		'IMPL::Web::Application::ResourceInterface' => undef
+	  ],
+	  props => [
+		request      => PROP_RO,
+		application => PROP_RO,
+		parent      => PROP_RO,
+		model       => PROP_RO,
+		id          => PROP_RO,
+		contract    => PROP_RO,
+		location    => PROP_RO,
+	  ]
 };
 
 sub CTOR {
-    my ( $this, %args ) = @_;
+	my ( $this, %args ) = @_;
+
+	die ArgumentException->new( id => 'A resource identifier is required' )
+	  unless $args{id};
+	die ArgumentException->new( contract => 'A contract is required' )
+	  unless $args{contract};
 
-    die ArgumentException->new( id => 'A resource identifier is required' )
-      unless $args{id};
-    die ArgumentException->new( contract => 'A contract is required' )
-      unless $args{contract};
-
-    $this->parent( $args{parent} );
-    $this->model( $args{model} );
-    $this->id( $args{id} );
-    $this->contract( $args{contract} );
-    $this->application( $args{application} || ($args{parent} && $args{parent}->application) );
+	$this->request($args{action})
+		or die ArgumentException->new(request => 'A request object must be specified');
+	$this->parent( $args{parent} );
+	$this->model( $args{model} );
+	$this->id( $args{id} );
+	$this->contract( $args{contract} );
+	$this->application( $args{action}{application} );
 
 # если расположение явно не указано, то оно вычисляется автоматически,
 # либо остается не заданным
-    $this->location( $args{location}
-          || eval { $this->parent->location->Child( $this->id ) } );
+	$this->location( $args{location}
+		  || eval { $this->parent->location->Child( $this->id ) } );
 }
 
 sub InvokeHttpVerb {
-    my ( $this, $verb, $action ) = @_;
+	my ( $this, $verb ) = @_;
 
-    my $operation = $this->contract->verbs->{ lc($verb) };
+	my $operation = $this->contract->verbs->{ lc($verb) };
 
-    die NotAllowedException->new(
-        allow => join( ',', map( uc, keys %{ $this->contract->verbs } ) ) )
-      unless $operation;
-      
-    $this->AccessCheck($verb);
+	die NotAllowedException->new(
+		allow => join( ',', map( uc, keys %{ $this->contract->verbs } ) ) )
+	  unless $operation;
+
+	$this->AccessCheck($verb);
+	my $request = $this->request;
 
 # в случае, когда один ресурс вызывает HTTP метод другого ресурса, нужно
 # сохранить оригинальный resourceLocation
-    $action->context->{resourceLocation} ||= $this->location;
-    
-    # это свойство специфично только для REST приложений.
-    # сохранение текущего ресурса не повлечет за собой существенных расходов,
-    # т.к. они просто освободятся несколько позже.
-    if(not $action->context->{resource}) { 
-        $action->context->{resource} = $this;
-        $action->context->{environment} = sub { $this->PrepareEnvironment() };
-    }
+	$request->context->{resourceLocation} ||= $this->location;
 
-    return _InvokeDelegate($operation, $this, $action );
+# это свойство специфично только для REST приложений.
+# сохранение текущего ресурса не повлечет за собой существенных расходов,
+# т.к. они просто освободятся несколько позже.
+	if ( not $request->context->{resource} ) {
+		$request->context->{resource} = $this;
+		$request->context->{environment} = sub { $this->PrepareEnvironment() };
+	}
+
+	return _InvokeDelegate( $operation, $this, $request );
 }
 
 sub AccessCheck {
-	
+
 }
 
 sub PrepareEnvironment {
-    my ($this) = @_;
-    
-    my @stack;
-    my $env = {};
-    
-    for(my $res = $this; $res; $res = $res->parent) {
-        push @stack,$res if $res->can('SetupEnvironment');
-    }
-    
-    map $_->SetupEnvironment($env), reverse @stack; 
-    
-    return $env;
+	my ($this) = @_;
+
+	my @stack;
+	my $env = {};
+
+	for ( my $res = $this ; $res ; $res = $res->parent ) {
+		push @stack, $res if $res->can('SetupEnvironment');
+	}
+
+	map $_->SetupEnvironment($env), reverse @stack;
+
+	return $env;
+}
+
+sub FindChildResourceInfo {
+	my ($this,$resourceId) = @_;
+	return $this->contract->FindChildResourceInfo($resourceId);
 }
 
 # это реализация по умолчанию, базируется информации о ресурсах, содержащийся
 # в контракте.
 sub FetchChildResource {
-    my ( $this, $childId ) = @_;
-    
-    $this->AccessCheck('FETCH');
+	my ( $this, $childId ) = @_;
+
+	$this->AccessCheck('FETCH');
 
-    my ( $info, $childIdParts ) =
-      $this->contract->FindChildResourceInfo($childId);
+	my ( $info, $childIdParts ) =
+	  $this->FindChildResourceInfo($childId);
 
-    die NotFoundException->new( $this->location->url, $childId ) unless $info;
-
-    my $binding  = $info->{binding};
-    my $contract = $info->{contract};
-    my $model    = _InvokeDelegate( $binding, $this, @$childIdParts );
+	die NotFoundException->new( $this->location->url, $childId ) unless $info;
+	
+	my %args;
 
-    if ( ref $contract eq 'CODE' || $contract->can('Invoke')) {
-        $contract = _InvokeDelegate($contract,$this,$model);
-        $info->{contract} = $contract;
-    }
+	my $binding  = $info->{binding};
+	my $contract = $info->{contract};
+	if (ref($binding) eq 'HASH' ) {
+		$args{$_} = _InvokeDelegate( $binding->{$_}, $this, @$childIdParts )
+			foreach keys %$binding;
+	} else {
+		$args{model} = _InvokeDelegate( $binding, $this, @$childIdParts );
+	}
 
-    die OperationException->new( "Can't fetch a contract for the resource",
-        $childId )
-      unless $contract;
+	if ( ref $contract eq 'CODE' || $contract->can('Invoke') ) {
+		$contract = _InvokeDelegate( $contract, $this, $args{model} );
+		$info->{contract} = $contract;
+	}
 
-    my %args = (
-        parent => $this,
-        id     => $childId,
-        model  => $model
-    );
+	die OperationException->new( "Can't fetch a contract for the resource",
+		$childId )
+	  unless $contract;
 
-    return $contract->CreateResource(%args);
+	$args{parent} = $this;
+	$args{id}     = $childId;
+	$args{request} = $this->request;
+
+	return $contract->CreateResource(%args);
 }
 
 sub _InvokeDelegate {
-    my $delegate = shift;
+	my $delegate = shift;
 
-    return $delegate->(@_) if ref $delegate eq 'CODE';
-    return $delegate->Invoke(@_) if eval { $delegate->can('Invoke') };
+	return $delegate->(@_) if ref $delegate eq 'CODE';
+	return $delegate->Invoke(@_) if eval { $delegate->can('Invoke') };
 }
 
 1;