File Coverage

blib/lib/WebDAO/Element.pm

Criterion	Covered	Total	%
statement	31	99	31.3
branch	1	28	3.5
condition	0	5	0.0
subroutine	9	24	37.5
pod	2	6	33.3
total	43	162	26.5

package WebDAO::Element;

=head1 NAME

WebDAO::Element - Base class for simple object

=head1 SYNOPSIS

=head1 DESCRIPTION

WebDAO::Element - Base class for simple object

=cut

our $VERSION = '0.01';

use Data::Dumper;
use WebDAO::Base;
use base qw/ WebDAO::Base/;
use warnings;
use strict 'vars';

__PACKAGE__->mk_attr(
    __my_name => undef,
    __parent => undef,
    __path2me => undef,
    __engine => undef,
    __extra_path => undef
);

=head1 NAME

WebDAO::Element - WebDAO::Element.

=head1 SYNOPSIS


=cut

sub _init {
    my $self = shift;
    $self->_sysinit( \@_ );    #For system internal inherites
    $self->init(@_);           # if (@_);
    return 1;
}


######## EVENTS ######

sub __register_event__ {
    my $self    = shift;
    my $ref_eng = $self->_root_;
    $ref_eng->__register_event__( $self, @_ );
}

sub __send_event__ {
    my $self   = shift;
    my $parent = $self->__parent || $self->_root_;
    $self->_log1( "Not def parent $self name:"
          . ( $self->__my_name )
          . Dumper( \@_ )
          . Dumper( [ map { [ caller($_) ] } ( 1 .. 10 ) ] ) )
      unless $parent;
    $parent->__send_event__(@_);
}

#
sub _sysinit {
    my $self = shift;

    #get init hash reference
    my $ref_init_hash = shift( @{ $_[0] } );

    #_engine - reference to engine
    $self->__engine( $ref_init_hash->{ref_engine} );

    #_my_name - name of this object
    $self->__my_name( $ref_init_hash->{name_obj} );
}

sub init {

    #Public Init metod for modules;
}


=head2 _get_childs_()

Return ref to childs array

=cut
sub _get_childs_ {
    return [];
}

=head2  __any_path ($session, @path)

Call for unresolved path.

Return:

    ($resuilt, \@rest_of_the_path)

=cut

sub __any_path {
    my $self = shift;
    my $sess = shift;
    my ( $method, @path ) = @_;
    #first check if Method
    #Check upper case First letter for method
    if ( ucfirst($method) ne $method ) {

        #warn  "Deny method : $method";
        return undef;    #not found
    }

    #check if $self have method
    if ( UNIVERSAL::can( $self, $method ) ) {

        #now try call method
        #Ok have method
        #check if path have more elements
        my %args = %{ $sess->Params };
        if (@path) {

            #add  special variable
            $args{__extra_path__} = \@path;
        }

        #call method (only one param may be return)
        my ($res, @path1) = $self->$method(%args);
        if ( scalar(@path1) ) {
            #method may return extra path
            return $res, \@path1;
        }
        return $res, \@path;
    }
    undef;

}

#return
#  undef  = not found
#  [ array of object]
#   <$self|| WebDAO::Element> ( ? for isert to parent container ?)
#  "STRING"
#   <WebDAO::Response>
sub _traverse_ {
    my $self = shift;
    my $sess = shift;

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

    #try get objects by special methods
    my ( $res, $last_path ) = $self->__any_path( $sess, $next_name, @path );
    return ( $self, undef ) unless defined $res;    #break search
    return ( $self, $res );
}

sub __get_self_refs {
    return $_[0];
}

sub _set_parent {
    my ( $self, $parent ) = @_;
    $self->__parent($parent);
    $self->_set_path2me();
}

sub _set_path2me {
    my $self   = shift;
    my $parent = $self->__parent;
    if ( $self != $parent ) {
        ( my $parents_path = $parent->__path2me ) ||= "";
        my $extr = $parent->__extra_path;
        $extr = [] unless defined $extr;
        $extr = [$extr] unless ( ref($extr) eq 'ARRAY' );
        my $my_path = join "/", $parents_path, @$extr, $self->__my_name;
        $self->__path2me($my_path);
    }
    else {
        $self->__path2me('');
    }
}

#deprecated -> $obj->__my_name
sub _obj_name {
    return $_[0]->__my_name;
}


#deprecated  -> self->_root_
sub getEngine {
    my $self = shift;
    return $self->__engine;
}

sub _root_ { return $_[0]->__engine }

sub fetch { undef } #return undef

sub _destroy {
    my $self = shift;
    $self->__parent(undef);
    $self->__engine(undef);
}

sub url_method {
    my $self   = shift;
    my $method = shift;
    my @upath  = ();
    push @upath, $self->__path2me if $self->__path2me;
    push @upath, $method if defined $method;
    my $sess = $self->_root_->_session;
    if ( $sess->set_absolute_url() ) {
        my $root = $sess->Cgi_env->{base_url};
        unshift @upath, $sess->Cgi_env->{base_url};
    }
    #hack !!! clear / on begin
    #s{^/}{} for @upath;
    my $path = join '/' => @upath;
    my $str = '';
    if (@_) {
        my %args = @_;
        my @pars;
        while ( my ( $key, $val ) = each %args ) {
            push @pars, "$key=$val";
        }
        $str .= "?" . join "&" => @pars;
    }
    return $path . $str;
}

=head2 response

Return response object

    return $self->response->error404('Bad name')

=cut

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

=head2 request

Return request object

    $self->request->param('id')

=cut

sub request {
    return $_[0]->response->get_request();
}


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