File Coverage

blib/lib/WebDAO/Engine.pm

Criterion	Covered	Total	%
statement	58	185	31.3
branch	6	86	6.9
condition	2	16	12.5
subroutine	14	26	53.8
pod	2	5	40.0
total	82	318	25.7

package WebDAO::Engine;

#$Id$

=head1 NAME

=head1 DESCRIPTION

WebDAO::Engine - Class for root object of application model

=cut

our $VERSION = '0.01';

use Data::Dumper;
use WebDAO::Container;
use WebDAO::Lib::MethodByPath;
use WebDAO::Lib::RawHTML;
use base qw(WebDAO::Container);
use Carp;
use strict;
use warnings;
__PACKAGE__->mk_attr( _session=>undef, __obj=>undef, __events=>undef);

sub new {
    my $class = shift;
    my $self  = {};
    my $stat;
    bless( $self, $class );
    return ( $stat = $self->_init(@_) ) ? $self : $stat;
}

sub _sysinit {
    my ( $self, $ref ) = @_;
    my %hash = @$ref;

    # Setup $init_hash;
    my $my_name = $hash{id} || '';
    unshift(
        @{$ref},
        {
            ref_engine => $self,       #! Setup _engine refernce for childs!
            name_obj   => "$my_name"
        }
    );                                 #! Setup _my_name
                                       #Save session
    _session $self $hash{session};

    #	name_obj=>"applic"});	#! Setup _my_name
    $self->SUPER::_sysinit($ref);

    #!init _runtime variables;
    $self->_set_parent($self);

    #hash "function" -"package"
    $self->__obj( {} );

    #init hash of evens names  -> @Array of pointers of sub in objects
    $self->__events( {} );

}

sub init {
    my ( $self, %opt ) = @_;

    #register default clasess
    $self->register_class(
        'WebDAO::Lib::RawHTML'      => '_rawhtml_element',
        'WebDAO::Lib::MethodByPath' => '_method_call'
    );

    #Register by init classes
    if ( ref( my $classes = $opt{register} ) ) {
        $self->register_class(%$classes);
    }
    if ( my $lexer = $opt{lexer} ) {
        map { $_->value($self) } @{ $lexer->auto };
        my @objs = map { $_->value($self) } @{ $lexer->tree };
        $self->_add_childs_(@objs);
    }
    elsif ( my $lex = $opt{lex} ) {
        my ( $pre, $fetch, $post ) = @{ $lex->value($self) || [] };
        $self->__add_childs__( 0,  @$pre );
        $self->_add_childs_(  @$fetch );
        $self->__add_childs__( 2, @$post );
    }

}

sub response {
    my $self = shift;
    return $self->_session->response_obj;
}


=head2  __handle_out__ ($sess, @output)

Process output by fetch methods

=cut

sub __handle_out__ {
    my $self = shift;
    my $sess = shift;
    for (@_) {
        if ( UNIVERSAL::isa( $_, 'WebDAO::Element' ) ) {
            $self->__handle_out__( $sess, $_->pre_fetch($sess) )
              if UNIVERSAL::can( $_, 'pre_fetch' );

            $self->__handle_out__( $sess, $_->fetch($sess) );
            $self->__handle_out__( $sess, $_->post_fetch($sess) )
              if UNIVERSAL::can( $_, 'post_fetch' );

        }
        elsif ( ref($_) eq 'CODE' ) {
            return $self->__handle_out__( $sess, $_->($sess) );
        }
        elsif ( UNIVERSAL::isa( $_, 'WebDAO::Response' ) ) {
            $_->_is_headers_printed(1);
            $_->_print_dep_on_context($sess) unless $_->_is_file_send;
            $_->flush;
            $_->_destroy;

        }
        else {
            $sess->print($_);
        }
    }
}

sub __events__ {
    my $self         = shift;
    my $root         = shift;
    my $inject_fetch = shift;
    my $path         = $root->__path2me;
    my @childs       = ();

    #make inject event for objects
    if ( my $res = $inject_fetch->{$path} ) {
        @childs = (
            {
                fetch => $root->__path2me,
                pme   => $path,
                ,
                event => 'inject',
                obj   => $root,
                res   => $res
            }
        );

    }
    else {

        if ( UNIVERSAL::isa( $root, 'WebDAO::Container' ) ) {

            #skip modal
            for ( @{ $root->__childs() } ) {
                push @childs, $self->__events__( $_, $inject_fetch )
                  unless UNIVERSAL::isa( $_, 'WebDAO::Modal' );
            }
        }
        else {
            @childs = (
                {
                    fetch => $root->__path2me,
                    pme   => $path,
                    ,
                    event => 'fetch',
                    obj   => $root
                }
            );
        }
    }
    my @res = (
        {
            st_ev => $root->__path2me,
            pme   => $path,
            event => 'start',
            obj   => $root
        },
        @childs,
        {
            end_ev => $root->__path2me,
            pme    => $path,
            event  => 'end',
            obj    => $root
        }
    );
}

sub _execute {
    my $self =shift;
    return $self->execute2(@_)
}

sub execute2 {
    my $self = shift;
    my $sess = shift;
    my $url  = shift;
    my @path = @{ $sess->call_path($url) };
    my ( $src, $res ) = $self->_traverse_( $sess, @path );
    my $response = $self->response;
    #now analyze answers
    # undef -> not Found
    unless ( defined($res) ) {
        $response->error404( "Url not found:" . join "/", @path );
        $response->flush;
        $response->_destroy;
        return;    #end
    }

    #convert string and ref(scalar) to resonse with html
    #special handle strings
    if ( !ref($res) or ( ref($res) eq 'SCALAR' ) ) {
        $res = $response->set_html( ref($res) ? $$res : $res );
    }
    #special handle HASH refs ( interpret as json)
    if ( ( ref($res) eq 'HASH' ) and $response->wantformat('json') ) {
        $res = $response->set_json( $res );
    }
    #check if  response modal
    if ( UNIVERSAL::isa( $res, 'WebDAO::Response' ) ) {
        #check empty response( $r->set_empty)
        return if $res->is_empty;
        if ( $res->_is_modal() ) {

        #handle response
        $res->_print_dep_on_context($sess, $res) unless $res->_is_file_send;
        $res->flush;
        $res->_destroy;
        return;
     }
    }

    #extract all objects to evenets
    my $root = $self;

    #if object modal ?
    if ( UNIVERSAL::isa( $src, 'WebDAO::Modal' ) ) {

        #set him as root of putput
        $root = $src;
    }
    my $need_inject_result = 1;

    #special handle strings
    if ( !ref($res) or ( ref($res) eq 'SCALAR' ) ) {

        #now walk
    }
    elsif

      #if result ref to object and it eq $src run flow
      ( $res == $src ) {
        $need_inject_result = 0;
    }
    if ( UNIVERSAL::isa( $res, 'WebDAO::Element' ) ) {

        #nothing  to do
    }
    my %injects = ();

    #if need inject check flow by path
    if ($need_inject_result) {
        $injects{ $src->__path2me } = $res;
    }
    #start out
    $response->print_header;

    my @ev_flow = $self->__events__( $root, \%injects );
    foreach my $ev (@ev_flow) {
        my $obj = $ev->{obj};

        #_log1 $self "DO " . $ev->{event}. " for $obj";
        if ( $ev->{event} eq 'start' ) {
            $self->__handle_out__( $sess, $obj->pre_fetch($sess) )
              if UNIVERSAL::can( $obj, 'pre_fetch' );
        }
        elsif ( $ev->{event} eq 'inject' ) {
            $self->__handle_out__( $sess, $ev->{res} )

        }
        elsif ( $ev->{event} eq 'fetch' ) {

            #skip fetch method for container

            $self->__handle_out__( $sess, $obj->fetch($sess) )
              if UNIVERSAL::can( $obj, 'fetch' );

        }
        elsif ( $ev->{event} eq 'end' ) {

            $self->__handle_out__( $sess, $obj->post_fetch($sess) )
              if UNIVERSAL::can( $obj, 'post_fetch' );
        }

    }
    $response->flush;
    $response->_destroy;
}


#fill $self->__events hash event - method
sub __register_event__ {
    my ( $self, $ref_obj, $event_name, $ref_sub ) = @_;
    my $ev_hash = $self->__events;
    $ev_hash->{$event_name}->{ scalar($ref_obj) } = {
        ref_obj => $ref_obj,
        ref_sub => $ref_sub
      }
      if ( ref($ref_sub) );
    return 1;
}

sub __send_event__ {
    my ( $self, $event_name, @Par ) = @_;
    my $ev_hash = $self->__events;
    unless ( exists( $ev_hash->{$event_name} ) ) {
        _log2 $self "WARN: Event $event_name not exists.";
        return 0;
    }
    foreach my $ref_rec ( keys %{ $ev_hash->{$event_name} } ) {
        my $ref_sub = $ev_hash->{$event_name}->{$ref_rec}->{ref_sub};
        my $ref_obj = $ev_hash->{$event_name}->{$ref_rec}->{ref_obj};
        $ref_obj->$ref_sub( $event_name, @Par );
    }
}

=head3 _create_(,,@parameters)

create object by .

=cut

sub _create_ {
    my ( $self, $name_obj, $name_func, @par ) = @_;
    my $pack = $self->_pack4name($name_func) || $name_func;
    my $ref_init_hash = {
        ref_engine => $self->_root_,  #! Setup _engine refernce for childs!
        name_obj   => $name_obj
    };    #! Setup _my_name
    my $obj_ref =
      $pack->isa('WebDAO::Element')
      ? eval "'$pack'\-\>new(\@par)"
      : eval "'$pack'\-\>new(\@par)";
#      ? eval "'$pack'\-\>new(\$ref_init_hash,\@par)"
#      : eval "'$pack'\-\>new(\@par)";
    if ($pack->isa('WebDAO::Element') ) {
        $obj_ref->{_engine} = $self->_root_ ;
        $obj_ref->{__my_name} =  $name_obj ;
        $obj_ref->_init($ref_init_hash,@par)
    }
    $self->_log1("Error in eval:  _create_ $@") if $@;
    return $obj_ref;
}

sub _createObj {
    my $self = shift;

    #    _deprecated $self "_create_";
    return $self->_create_(@_);
}

#Get package for functions name
sub _pack4name {
    my ( $self, $name ) = @_;
    my $ref = $self->__obj;
    return $$ref{$name} if ( exists $$ref{$name} );
}

sub register_class {
    my ( $self, %register ) = @_;
    my $_obj = $self->__obj;
    while ( my ( $class, $alias ) = each %register ) {

        #check non loaded mods
        my ( $main, $module ) = $class =~ m/(.*\:\:)?(\S+)$/;
        $main ||= 'main::';
        $module .= '::';
        no strict 'refs';
        unless ( exists $$main{$module} ) {
            _log1 $self "Try use $class";
            eval "use $class";
            if ($@) {
                _log1 $self "Error register class :$class with $@ ";
                return "Error register class :$class with $@ ";
                next;
            }
        }
        use strict 'refs';

        #check if register_class used for eval ( see Lobject )
        $$_obj{$alias} = $class if defined $alias;
    }
    return;
}

=head3  _commit

Method witch called after HTTP request

=cut

sub _commit {
    #nothing by default
}

sub _destroy {
    my $self = shift;
    $self->SUPER::_destroy;
    $self->_session(undef);
    $self->__obj(undef);
    $self->__events(undef);
}
1;
__DATA__