File Coverage

blib/lib/WebDAO/Container.pm

Criterion	Covered	Total	%
statement	34	135	25.1
branch	0	52	0.0
condition	0	12	0.0
subroutine	10	20	50.0
pod	2	2	100.0
total	46	221	20.8

package WebDAO::Container;

#$Id$

=head1 NAME

WebDAO::Container - Group of objects

=head1 SYNOPSIS

=head1 DESCRIPTION

WebDAO::Container - Group of objects

=cut

our $VERSION = '0.02';

use WebDAO::Element;
use base qw(WebDAO::Element);
use strict 'vars';
use warnings;

__PACKAGE__->mk_attr( __post_childs => '', __pre_childs => '', __childs => '' );

sub _sysinit {
    my $self = shift;

    #First invoke parent _init;
    $self->SUPER::_sysinit(@_);

    #init childs
    $self->_clear_childs_();
}

=head1 METHODS (chidls)

=head2 _get_childs_()

Return ref to childs array

=cut

sub _get_childs_ {
    my $self = shift;
    return [
        @{ $self->__pre_childs() },
        @{ $self->__childs() },
        @{ $self->__post_childs() }
    ];
}

=head3 _add_childs_($object1[, $object2])

Insert set of objects into container

=cut

sub _add_childs_ {
    my $self = shift;
    $self->__add_childs__( 1, @_ );
}

=head2 _clear_childs_

Clear all childs (pre, post also)

=cut

sub _clear_childs_ {
    my $self = shift;
    $self->__post_childs( [] );
    $self->__childs(      [] );
    $self->__pre_childs(  [] );
}

=head2 _set_childs_ @childs_set

Clear all childs (except "pre" and "post" objects), and set  to C<@childs_set>

=cut

# 0 - pre, 1 - fetch , 2 - post
sub __set_childs__ {
    my $self = shift;
    my $type = shift;
    my $dst  = $type == 0
      ? $self->__pre_childs    #0
      : $type == 1 ? $self->__childs()        #1
      :              $self->__post_childs;    #2
    for ( @{$dst} ) {
        $_->_destroy;
    }
    $self->__add_childs__( $type, @_ );
}

# 0 - pre, 1 - fetch , 2 - post
sub __add_childs__ {
    my $self = shift;
    my $type = shift;
    my $dst  = $type == 0
      ? $self->__pre_childs                   #0
      : $type == 1 ? $self->__childs()        #1
      :              $self->__post_childs;    #2
    my @childs =
      grep { ref $_ }
      map { ref($_) eq 'ARRAY' ? @$_ : $_ }
      map { $_->__get_self_refs }
      grep { ref($_) && $_->can('__get_self_refs') }
      map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
    return unless @childs;
    if ( $self->__parent ) {
        $_->_set_parent($self) for @childs;
    }
    push( @{$dst}, @childs );
}

sub _set_childs_ {
    my $self = shift;

    #first destoroy
    for ( @{ $self->__childs() } ) {
        $_->_destroy;
    }
    $self->__childs( [] );
    $self->_add_childs_(@_);
}

=head1 OUTPUT_METHODS

=head2 pre_fetch ($session)

Output data precede to fetch method. By default output "pre" objects;

=cut

sub pre_fetch {
    my $self = shift;
    @{ $self->__pre_childs };
}

=head2 post_fetch ($session)

Output data follow to fetch method. By default output "post" objects;

=cut

sub post_fetch {
    my $self = shift;
    @{ $self->__post_childs };
}

=head1 OTHER
=cut

#it for container
sub _set_parent {
    my ( $self, $par ) = @_;
    $self->SUPER::_set_parent($par);
    foreach my $ref ( @{ $self->_get_childs_ } ) {
        $ref->_set_parent($self);
    }
}

sub __any_path {
    my $self     = shift;
    my $sess     = shift;
    my ($method) = @_;
    my ( $res, $path ) = $self->SUPER::__any_path( $sess, @_ );

    #process routes
    unless ( defined($res) ) {
        no strict 'refs';
        my $pkg    = ref($self);
        my %routes = %{"${pkg}::_WEBDAO_ROUTE_"};
        if ( exists $routes{$method} and my $class = $routes{$method} ) {
            unless ( UNIVERSAL::isa( $class, 'WebDAO::Container' ) ) {
                my $isa = \@{"${class}::ISA"};
                push @$isa, 'WebDAO::Container';
            }
            my $obj = $self->_root_->_create_( $method, $class );
            $self->_add_childs_($obj);
            $path = \@_;
            $res  = $self;
        }
        use strict 'refs';
    }
    return undef unless defined($res);
    if ( ref($res) eq 'ARRAY' ) {

        #make container
        my $cont = $self->__engine->_create_( $method, __PACKAGE__ );
        $cont->_set_childs_(@$res);
        $res = [$cont];
        unshift( @$path, $method );
    }
    return ( $res, $path );
}

#Return (  object witch handle req and result )
sub _traverse_ {
    my $self = shift;
    my $sess = shift;

    #if empty path return $self
    unless ( scalar(@_) ) { return ( $self, $self ) }

    my ( $next_name, @path ) = @_;

    #$src - object wich handle answer, $res - answer
    my ( $src, $res ) = ( $self, undef );

    #check if exist object with some name
    if ( my $obj = $self->_get_obj_by_name($next_name) ) {

        #if last in path return him
        ( $src, $res ) = $obj->_traverse_( $sess, @path );

    }
    else {    #try get other ways

        #try get objects by special methods
        my $last_path;
        ( $res, $last_path ) = $self->__any_path( $sess, $next_name, @path );
        return ( $self, undef ) unless defined $res;    #break search
        if ( UNIVERSAL::isa( $res, 'WebDAO::Response' ) ) {
            return ( $self, $res );
        }
        elsif ( ref($res) eq 'ARRAY' ) {

            #for objects array attach them into collection
            $self->_set_childs_(@$res);

            #return ref to container if array to self
            $res = $self;
        }

        #analyze $last_path
        my @rest_path = ();
        if ($last_path) {
            if ( ref($last_path) eq 'ARRAY' ) {
                @rest_path = @$last_path;
            }
        }
        if (@rest_path) {
            ( $src, $res ) = $self->_traverse_( $sess, @rest_path );
        }
    }
    #
    if ( $res && $src && ( $src eq $res )  && !UNIVERSAL::isa( $src, 'WebDAO::Modal' ) ) {

        #force set root object for Modal
        $src = $res = $self if UNIVERSAL::isa( $self, 'WebDAO::Modal' );
    }
    return ( $src, $res );
}

sub _get_obj_by_name {
    my $self = shift;
    my $name = shift;
    return unless defined $name;
    my $res;
    foreach my $obj ( $self, @{ $self->_get_childs_ } ) {
        if ( $obj->_obj_name eq $name ) {
            return $obj;
        }
    }
    return;
}

sub _destroy {
    my $self = shift;
    my @res;
    for my $a ( @{ $self->_get_childs_ } ) {
        $a->_destroy;
    }
    $self->_clear_childs_();
    $self->SUPER::_destroy;
}

1;
__DATA__

=head1 SEE ALSO

http://webdao.sourceforge.net

=head1 AUTHOR

Zahatski Aliaksandr, E<lt>[e-mail]<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2002-2012 by Zahatski Aliaksandr

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut