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

use Carp qw(carp);
use List::Util qw(first);
use IMPL::lang;
use IMPL::Const qw(:prop);
use IMPL::declare {
    require => {
        Factory      => 'IMPL::Web::View::ObjectFactory',
        HttpResponse => 'IMPL::Web::HttpResponse',
        Loader       => 'IMPL::Code::Loader',
        ViewResult   => '-IMPL::Web::ViewResult'
      },
      base => [
        'IMPL::Object'               => undef,
        'IMPL::Object::Autofill'     => '@_',
        'IMPL::Object::Serializable' => undef
      ],

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

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

    $this->_selectorsCache([ map $this->ParseRule($_), @{$this->selectors || []} ]);
}

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

    my $result = $next ? $next->($action) : undef;
    
    my ($model,$view);
    if( ref $result and eval { $result->isa(ViewResult) } ) {
        $model = $result->model;
        $view = $result;      
    } else {
        $model = $result;
        $view = ViewResult->new(model => $model);
    }
    
    my $vars = {
        view        => $view,
        model       => $model,
        #TODO cleanup
        action      => sub { carp "action variable is deprecated"; $action },
        request     => sub { $action },
        app         => $action->application,
        context     => $action->context,
        env         => _cached($action->context->{environment}),
        ImportClass => sub {
            my $class = shift;
            
            carp "ImportClass is obsolete use import instead";
            
            $class = Loader->safe->Require($class);
            
            return Factory->new($class);
        },
        import      => sub {
            my $class = shift;

            $class = Loader->safe->Require($class);
            
            return Factory->new($class);
        }
    };

    my $doc =
      $this->loader->document( eval { $view->template } || $this->SelectView( $action, ref $model ),
        $vars );
        
    $doc->location($action->context->{resourceLocation});
        
    my %responseParams = (
        type => $this->contentType,
        charset => $this->contentCharset,
        body => $doc->Render()
    );
    
    $responseParams{status} = $view->status if $view->status;
    $responseParams{cookies} = $view->cookies if ref $view->cookies eq 'HASH';
    $responseParams{headers} = $view->headers if ref $view->headers eq 'HASH';

    return HttpResponse->new(
        %responseParams        
    );
}

sub _cached {
    my $arg = shift;
    
    return $arg unless ref $arg eq 'CODE';
    
    return sub {
        ref $arg eq 'CODE' ? $arg = &$arg() : $arg;
    }
}

sub SelectView {
    my ($this,$action) = @_;
    
    my @path;
    
    for(my $r = $action->context->{resource}; $r ; $r = $r->parent ) {
        unshift @path, {
            name => $r->id,
            class => typeof($r->model)
        };
    }
    
    @path = map { name => $_}, split /\/+/, $action->query->path_info()
        unless (@path);
    
    return $this->MatchPath(\@path,$this->_selectorsCache) || $this->defaultDocument;
}

sub ParseRule {
    my ($this, $rule) = @_;
    
    my ($selector,$data) = split /\s+=>\s+/, $rule;
    
    my @parts;
    my $first = 1;
    my $weight = 0;
    foreach my $part ( split /\//, $selector ) {
        # если первым символом является /
        # значит путь в селекторе абсолютный и не нужно
        # добавлять "любой" элемент в начало
        
        if($part) {
            $weight ++;
            push @parts,{ any => 1 } if $first;
        } else {
            push @parts,{ any => 1 } unless $first;
            next;
        }        

        my ($name,$class) = split /@/, $part;
        
        if ( my ( $varName, $rx ) = ( $name =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) ) {
            #this is a regexp

            push @parts, {
                rx => $rx,
                var => $varName,
                class => $class,
            };
        } else {
            push @parts, {
                name => length($name) ? $name : undef,
                class => $class,
            };
        }        
    } continue {
        $first = 0;
    }
     
    return { selector => \@parts, data => $data, weight => $weight };
}

sub MatchPath {
    my ($this,$path,$rules) = @_;
    
    $path ||= [];
    $rules ||= [];
    
    my @next;
    
    foreach my $segment (@$path) {
        foreach my $rule (@$rules) {
            my @selector = @{$rule->{selector}};
            
            my $part = shift @selector;
            
            # if this rule doesn't have a selector
            next unless $part;

            if ($part->{any}) {
                #keep the rule for the next try
                push @next, $rule;

                $part = shift @selector while $part->{any};
            }
            
            my $newRule = {
                selector => \@selector,
                data => $rule->{data},
                weight => $rule->{weight},
                vars => { %{$rule->{vars} || {}} }
            };
            
            my $success = 1;
            if (my $class = $part->{class}) {
                $success = isclass($segment->{class},$class);
            }
            
            if($success && (my $name = $part->{name})) {
                $success = $segment->{name} eq $name;
            } elsif ($success && (my $rx = $part->{rx})) {
                if( my @captures = ($segment->{name} =~ m/($rx)/) ) {
                    $newRule->{vars}->{$part->{var}} = \@captures
                        if $part->{var};
                } else {
                    $success = 0;
                }
            }
            
            push @next, $newRule if $success;
            
        }
        $rules = [@next];
        undef @next;
    }
    
    my $result = (
        sort {
            $b->{weight} <=> $a->{weight}
        }
        grep {
            scalar(@{$_->{selector}}) == 0
        }
        @$rules
    )[0];
    
    if($result) {
        my $data = $result->{data};
        $data =~ s/{(\w+)(?:\:(\d+))?}/
            my ($name,$index) = ($1,$2 || 0);
            
            if ($result->{vars}{$name}) {
                $result->{vars}{$name}[$index];
            } else {
                "";
            }
        /gex;
        
        return $data;
    } else {
        return;
    }
}

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>, основывающийся на именах ресурсов и их типах
данных.

Данный обработчик понимает определенные свойства контекста:

=over

=item * C<resourceLocation>

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

=item * C<environment>

В данном совойстве контекста передается дополнительная информация об окружении
ресурса, например, которую задали родительские ресурсы. Использование данного
свойства позволяет не загромождать ресурс реализацией функциональности по
поддержке окружения. Это свойство может быть ссылкой на функцию, что позволяет
формировать контекст только по необходимости, при этом указанная функция будет
выполнена только один раз, при первом обращении.

=back 

=head1 SELECTORS

=begin text

syntax::= selector => template

selector::= ([>]segment-template[@class-name])

segment-template::= {'{'name:regular-expr'}'|segment-name}

name::= \w+

segment-name::= \S+

class-name::= name[(::name)]

url-template@class => template

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

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

=end text


=cut