package IMPL::Transform;
use strict;

use parent qw(IMPL::Object);

use IMPL::lang qw(:declare :constants);

use IMPL::Class::Property::Direct;

BEGIN {
    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 = shift;
    my $args = @_ == 1 ? shift : { @_ };
    
    $this->{$plain} = delete $args->{-plain};
    $this->{$default} = delete $args->{-default};
    
    $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};
        return $this->$template($object,@args);
    } else {
    
        my $template = $this->MatchTemplate($object) || $this->default or die new IMPL::Transform::NoTransformException(ref $object);
    
        return $this->ProcessTemplate($template,$object,@args);
    }
}

sub MatchTemplate {
    my ($this,$object) = @_;
    my $class = $this->GetClassForObject( $object );
    
    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};
            	
            	#cache and return
            	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) = @_;
    
    return ref $object;
}

package IMPL::Transform::NoTransformException;
use IMPL::declare {
	base => {
		'IMPL::Exception' =>  sub { 'No transformation', @_ }
	}
};

1;

__END__

=pod

=head1 NAME

C<IMPL::Transform> - преобразование объектной структуры

=head1 SYNOPSIS

=begin code

my $obj = new AnyObject;

my $t = new Transform (
    SomeClass => sub {
        my ($this,$object) = @_;
        return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) })
    },
    DocClass => sub {
        my ($this,$object) = @_;
        return new DocPreview(Author => $object->Author, Text => $object->Data);
    },
    -default => sub {
        my ($this,$object) = @_;
        return $object;
    },
    -plain => sub {
        my ($this,$object) = @_;
        return $object;
    }
);

my $result = $t->Transform($obj);

=end code

=head1 DESCRIPTION

Преобразование одного объекта к другому, например даных к их представлению.

=cut