package IMPL::Web::Handler::TTView;
use strict;

use List::Util qw(first);
use IMPL::Const qw(:prop);
use IMPL::declare {
    require => {
        Factory      => 'IMPL::Object::Factory',
        HttpResponse => 'IMPL::Web::HttpResponse'
      },
      base => [
        'IMPL::Object'               => undef,
        'IMPL::Object::Autofill'     => '@_',
        'IMPL::Object::Serializable' => undef
      ],

      props => [
        contentType     => PROP_RO,
        contentCharset  => PROP_RO,
        loader          => PROP_RO,
        selectors       => PROP_RO | PROP_LIST,
        defaultDocument => PROP_RW,
        indexResource   => PROP_RW,
        _selectorsCache => PROP_RW,
        _classTemplates => PROP_RW
      ]
};

sub CTOR {
    my ($this) = @_;

    $this->indexResource('index') unless $this->indexResource;
}

sub Invoke {
    my ( $this, $action, $next ) = @_;

    my $result = $next ? $next->($action) : undef;

    my $vars = {
        data        => $result,
        action      => $action,
        app         => $action->application,
        LoadFactory => sub {
            my $class = shift;

            my $module = $class;

            $module =~ s/::/\//g;
            $module .= ".pm";

            require $module;
            return Factory->new($class);
        }
    };

    my $doc =
      $this->loader->document( $this->SelectView( $action, ref $result ),
        $vars );

    return HttpResponse->new(
        type => $this->contentType,
        charset => $this->contentCharset,
        body => $doc->Render($vars)
    );
}

sub SelectView {
    my ( $this, $action, $class ) = @_;

    my @path = split /\//, $action->query->path_info(), -1;

    shift @path;    # remove always empty leading segment

    my $last = pop @path;
    $last =~ s/\.\w+$//;
    $last ||= $this->indexResource;
    push @path, $last;

    $this->BuildCache unless $this->_selectorsCache;
    my $cache = $this->_selectorsCache;

    @path = reverse @path;

    foreach
      my $subclass ( $class ? ( _GetHierarchy($class), '-default' ) : '-plain' )
    {
        my @results;
        push @results,
          { result => $this->_classTemplates->{$subclass}, level => 0 }
          if $this->_classTemplates->{$subclass};
        if ( $cache->{$subclass} ) {
            my $alternatives =
              [ { selector => $cache->{$subclass}, immediate => 1 } ];
            $alternatives =
              $this->MatchAlternatives( $_, $alternatives, \@results )
              foreach @path;
        }

        if (@results) {
            @results = sort { $b->{level} <=> $a->{level} } @results;
            return ( shift @results )->{result};
        }
    }

    return $this->defaultDocument;
}

sub _GetHierarchy {
    my ($class) = @_;
    return unless $class;

    no strict 'refs';

    return $class, map { _GetHierarchy($_) } @{"${class}::ISA"};
}

sub BuildCache {
    my ($this) = @_;

    my @selectors;

    my $cache = $this->_selectorsCache( {} );
    $this->_classTemplates( {} );

    foreach my $selector ( $this->selectors ) {
        if ( not ref $selector ) {

            my ( $path, $data ) = split( /\s*=>\s*/, $selector );

            my @path = split( /\s+/, $path );

            my $class;

            # if this selector has a class part
            if ( $path[$#path] =~ m/^\@(.*)/ ) {
                $class = $1;
                pop @path;
            }
            else {
                $class = '-default';
            }

            #if this selector has a path
            if (@path) {
                @path = reverse @path;
                my $last  = pop @path;
                my $t     = ( $cache->{$class} ||= {} );
                my $level = 1;
                foreach my $prim (@path) {
                    $t = ( $t->{$prim}->{next} ||= {} );
                    $level++;
                }
                $t->{$last}->{level} = $level;
                $t->{$last}->{data}  = $data;

            }
            else {

                # we dont have a selector, only class

                $this->_classTemplates->{$class} = $data;
            }

        }
    }
}

sub MatchAlternatives {
    my ( $this, $segment, $alternatives, $results ) = @_;

    my @next;

    foreach my $alt (@$alternatives) {
        while ( my ( $selector, $match ) = each %{ $alt->{selector} } ) {

            my $context = {
                vars => \%{ $alt->{vars} || {} },
                selector => $match->{next}
            };

            if ( $selector =~ s/^>// ) {
                $context->{immediate} = 1;
            }

            if ( my ( $name, $rx ) =
                ( $selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) )
            {

                #this is a regexp

                if ( my @captures = ( $segment =~ m/($rx)/ ) ) {
                    $context->{success} = 1;

                    if ($name) {
                        $context->{vars}->{$name} = \@captures;
                    }
                }
            }
            else {

                #this is a segment name
                if ( $segment eq $selector ) {
                    $context->{success} = 1;
                }
            }

            # test if there were a match
            if ( delete $context->{success} ) {
                if ( my $data = $match->{data} ) {

                    # interpolate data
                    $data =~ s/{(\w+)(?:\:(\d+))?}/
                        my ($name,$index) = ($1,$2 || 0);
                        
                        if ($context->{vars}{$name}) {
                            $context->{vars}{$name}[$index];
                        } else {
                            "";
                        }
                    /gex;

                    push @$results,
                      { level => $match->{level}, result => $data };
                }
                push @next, $context if $context->{selector};
            }
            else {

                #repeat current alternative if it's not required to be immediate
                push @next,
                  {
                    selector => { $selector, $match },
                    vars     => $alt->{vars}
                  }
                  unless $alt->{immediate};
            }
        }
    }

    return \@next;
}

1;

__END__

=pod

=head1 NAME

C<IMPL::Web::Handler::TTView> - использует шаблоны для построения представления.

=head1 SYNOPSIS

=begin code xml

<item id="html-view" type="IMPL::Web::Handler::TTView">
    <contentType>text/html</contentType>
    <loader id="tt-loader" type="IMPL::Web::View::TTLoader">
	    <options type="HASH">
	        <INCLUDE_PATH type="IMPL::Config::Reference">
	            <target>IMPL::Config</target>
	            <AppBase>view</AppBase>
	        </INCLUDE_PATH>
	        <INTERPOLATE>1</INTERPOLATE>
	        <POST_CHOMP>1</POST_CHOMP>
	        <ENCODING>utf-8</ENCODING>
	    </options>
	    <ext>.tt</ext>
	    <initializer>global.tt</initializer>
	    <layoutBase>layouts</layoutBase>
    </loader>
    <defaultDocument>default</defaultDocument>
    <selectors type="ARRAY">
        <item>@HASH => dump</item>
        <item>@My::Data::Product => product/info</item>
        <item>{action:.*} @My::Data::Product => product/{action}</item>
    </selectors>                    
</item>

=end code xml

=head1 DESCRIPTION

Подбирает шаблон для представления результата, полученного при выполнении следующего обработчика. При
выборе используется принцип похожий на селекторы C<CSS>, основывающийся на именах ресурсов и их типах
данных.

=head1 SELECTORS

=begin text

[url-template] [class] => template

shoes => product/list
{action:*.} @My::Data::Product => product/{action}

stuff >list => product/list
details => product/details

=end text


=cut