Ambrosia

 view release on metacpan or  search on metacpan

lib/Ambrosia/core/Object.pm  view on Meta::CPAN

package Ambrosia::core::Object;
use strict;
use warnings;
use Carp;
use integer;

use XML::LibXML();
use Data::Serializer;

use overload '%{}' => \&__get_hash, fallback => 1;

use Ambrosia::error::Exceptions;
use Ambrosia::core::Nil;
use Ambrosia::Assert;

our $VERSION = 0.010;

unless ( $::__AMBROSIA_ACCESS_ALLOW )
{
    *__get_hash = sub {
        $_[0]->[1] ||= {};
        return $_[0]->[1] if $::__AMBROSIA_ACCESS_ALLOW;
        my $pkg = caller(0);

        my $self = shift;

        if ( $pkg eq ref $self || $self->isa($pkg) )
        {
            return $self->[1];
        }
        else
        {
            throw Ambrosia::error::Exception::AccessDenied("Access denied for $pkg in $self (@_); caller0: " . join ';', grep {$_} caller(0) );
        }
    };
}
else
{
    *__get_hash = sub { return $_[0]->[1] ||= {}; };
}

### constructor ###
sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;

    if ($class->__AMBROSIA_IS_ABSTRACT__)
    {
        throw Ambrosia::error::Exception 'You cannot instance abstract class ' . $class;
    }

    my $self = bless [[]], $class;
    $self->_init(@_);
    return $self;
}

sub fields
{
    return ();
}

### run from new ###
sub _init
{
    my $self = shift;

    return $self unless scalar @_;
    my %params = @_ == 1 ? %{$_[0]} : @_;

    foreach ( keys %params )
    {
        if ( eval {$self->can($_)} )
        {
            $self->$_ = $params{$_};
        }
        else
        {
            croak 'Not found property ' . $_ . ' in ' . ref($self);
        }
    }

    return $self;
}

sub value
{
    my $self = shift;

    my %FLDS; @FLDS{$self->fields} = ();

    my @res = map { $self->$_ } @_ ? (grep {exists $FLDS{$_} || throw Ambrosia::error::Exception::AccessDenied 'value: access denied - ' . $_} @_) : $self->fields;
    return wantarray ? @res : \@res;
}

sub string_dump
{
    return Data::Serializer->new(serializer => 'Storable', compress => 1)->serialize($_[0]);
}

sub string_restore
{
    my $dump = shift;
    return new Ambrosia::core::Nil unless $dump;

    my $obj = Data::Serializer->new(serializer => 'Storable')->deserialize($dump);

    reflection( sub {
            if ( my $refObj = ref $_[0] )
            {
                Ambrosia::core::ClassFactory::load_class($refObj)
            }
        }, $obj );

    my $caller = ref $obj;
    no strict 'refs';

    foreach my $f ( keys %{"$caller\::__AMBROSIA_INTERNAL_FLDS__"} )
    {
        reflection( sub {
                if ( my $refObj = ref $_[0] )
                {
                    Ambrosia::core::ClassFactory::load_class($refObj)
                }
            }, $obj->$f );
    }

    return $obj;
}

sub reflection #(&@)
{
    my $filter = shift;
    my $value = shift;
    my $refValue = ref $value;

    if ( $refValue eq 'ARRAY' )
    {
        return [ map { reflection($filter, $_) } @$value ];
    }
    elsif ( $refValue eq 'HASH' )
    {
        return { map { $_ => reflection($filter, $_) } keys %$value };
    }
    elsif ( $refValue eq 'CODE' )
    {
        my $r = $filter->($value->());
        return \$r;
    }
    else
    {
        return $filter->($value);

lib/Ambrosia/core/Object.pm  view on Meta::CPAN

    my $hash = {};
    foreach my $f ( $self->fields )
    {
        $hash->{$f} = reflection( sub {
                my $v = shift;
                if ( ref $v eq 'SCALAR' )
                {
                    return $$v;
                }
                elsif ( ref $v && eval{ $v->can('as_hash') } )
                {
                    return $v->as_hash($ignore, $f);
                }
                else
                {
                    return $v;
                }
            }, $self->$f );
    }
    foreach ( @methods )
    {
        eval
        {
            my($m, $a, $p, @P);
            @P = ();
            if ( ($m, $a, $p) = ( $_ =~ /^(.+?)(?::(.+?))?\{(.*)\}$/s ) )
            {
                while ( $p =~ /^\s*(.+?(?:\{(?:.*?)\})?)\s*(?:,|$)(.*)/s )
                {
                    $p = $2;
                    push @P, $1;
                }
            }
            elsif ( ($m, $a) = ( $_ =~ /^(.+?)(?::(.+?))$/s ) )
            {
                
            }
            else
            {
                $m = $_;
            }
            $hash->{$a||$m} = reflection( sub {
                    my $v = shift;
                    if ( ref $v eq 'SCALAR' )
                    {
                        return $$v;
                    }
                    elsif ( ref $v && eval{ $v->can('as_hash') } )
                    {
                        return $v->as_hash($ignore, $p);
                    }
                    else
                    {
                        return $v;
                    }
                }, $self->$m(@P) );
        };
        if ( $@ )
        {
            throw Ambrosia::error::Exception $@ unless $ignore;
        };
    }
    return $hash;
}

sub copy_to
{
    my $self = shift;
    my $dest = shift;
    throw Ambrosia::error::Exception("Cannot copy $self to $dest.") unless ref $self eq ref $dest;
    foreach my $f ( $self->fields )
    {
        $dest->$f = $self->$f;
    }
}

sub clone
{
    no strict 'refs';
    my $self = shift;
    my $deep = shift;

    my $obj = $self->new();

    my $pkg = ref $self;# || die 'clone: for object context only!';
    assert {$pkg} 'clone: for object context only!';

    my @__FIELDS__ = (keys(%{"$pkg\::__AMBROSIA_INTERNAL_FLDS__"}), $self->parent_fields());

    if ( $deep )
    {
        foreach my $fn ( @__FIELDS__ )
        {
            eval
            {
            $obj->$fn = reflection( sub {
                    my $v = shift;
                    my $refV = ref $v;
                    if( $refV eq 'SCALAR' )
                    {
                        my $t = $$v;
                        return \$t;
                    }
                    elsif ( $refV eq 'GLOB' || $refV eq 'CODE' )
                    {
                        return $v;
                    }
                    elsif ( $refV && eval{$v->isa( __PACKAGE__ )} )
                    {
                        return $v->clone(1);
                    }
                    elsif ( $refV && eval{$v->can( 'clone' )} )
                    {
                        return $v->clone;
                    }
                    else
                    {
                        #die "cannot clone $v";
                        return $v;
                    }
                }, $self->$fn );
            };
            if ( $@ )
            {
                croak "$@\n";
                throw Ambrosia::error::Exception "FOR $fn CANNOT CLONE " . $self->$fn . ' :(', $@;
            }
        }
    }
    else
    {
        foreach my $f ( @__FIELDS__ )
        {
            $obj->$f = $self->$f;
        }
    }
    return $obj;
}

sub proces_node
{
    my $document = shift;
    my $node = shift;
    my $name = shift;
    my $value = shift;
    my $error_ignore = shift;

    unless (defined $value)
    {
        $value = '';
    }

    if ( ref $value )
    {
        as_xml_nodes($document, $node, $name, $value, $error_ignore);
    }
    else
    {
        $node->setAttribute( $name, $value );
    }
    return $node;
}

sub as_xml_nodes #( $document, $node, $p, $v, $params{error_ignore} )
{
    my $document = shift;
    my $ex_node = shift;
    my $p = shift;
    my $v = shift;
    my $error_ignore = shift;
    my $force_node = shift;
    my $refV = ref $v;
    local $@;

    if ( $refV eq 'ARRAY' )
    {
        as_xml_nodes($document, $ex_node, $p, $_, $error_ignore, $p) foreach @$v;
    }
    elsif ( $refV eq 'HASH' )
    {
        my $node = $document->createElement($p);
        proces_node( $document, $node, $_, $v->{$_}, $error_ignore ) foreach keys %$v;
        $ex_node->addChild($node);
    }
    elsif ( $refV eq 'SCALAR' )
    {

lib/Ambrosia/core/Object.pm  view on Meta::CPAN

        $name_node = ref $self;
        $name_node =~ s/::/_/gs;
    }

    unless ( $document = $params{document} )
    {
        $document = XML::LibXML->createDocument( '1.0', $params{charset} || 'UTF-8' );
    }

    my $node = $document->createElement($name_node);

    my $addChild = sub {
            my $p = shift;
            my $v = shift;

            if ( ref $v )
            {
                $node->addChild($_) foreach as_xml_nodes( $document, $node, $p, $v, $params{error_ignore} );
            }
            else
            {
                $node->setAttribute($p, $v);
            }
        };

    foreach ( $self->fields )
    {
        $addChild->($_, $self->$_);
    }

    foreach ( @{$params{methods}} )
    {
        eval
        {   # --== BNF ==--
            # mlist := method+
            # method := 'class_method_real_name'[[:alias]{method+}]
            # alias := 'alternative_name'
            #
            my($m, $a, $p, @P);
            @P = ();
            if ( ($m, $a, $p) = ( $_ =~ /^(.+?)(?::(.+?))?\{(.*)\}$/s ) )
            {
                while ( $p =~ /^\s*(.+?(?:\{(?:.*?)\})?)\s*(?:,|$)(.*)/s )
                {
                    $p = $2;
                    push @P, $1;
                }
            }
            elsif ( ($m, $a) = ( $_ =~ /^(.+?)(?::(.+?))$/s ) )
            {
                
            }
            else
            {
                $m = $_;
            }
            $node->addChild($_) foreach as_xml_nodes($document, $node, $a||$m, $self->$m(@P));
        };
        if ( $@ )
        {
            throw Ambrosia::error::Exception $@ unless $params{error_ignore};
        };
    }

    if ( $params{need_node} )
    {
        return $node;
    }
    else
    {
        $document->setDocumentElement($node);
        return $document;
    }
}

sub __fields_equal
{
    my $f1 = shift;
    my $f2 = shift;
    my $ref1 = ref $f1;
    my $ref2 = ref $f2;

    return 0 if $ref1 ne $ref2;
    if ( $ref1 eq 'ARRAY' )
    {
        return 0 if scalar @$f1 != scalar @$f2;
        for( my ($i,$j)=(0, scalar @$f1); $i < $j; ++$i )
        {
            unless ( my $res = __fields_equal($f1->[$i],$f2->[$i]) )
            {
                return $res;
            }
        }
        return 1;
    }
    elsif ( $ref1 eq 'HASH' )
    {
        my @keys = keys %$f1;
        return 0 if scalar @keys != scalar keys %$f2;
        return 0 if scalar @keys != scalar grep {exists $f2->{$_}} @keys;
        foreach ( @keys )
        {
            unless ( my $res = __fields_equal($f1->{$_}, $f2->{$_}) )
            {
                return $res;
            }
        }
        return 1;
    }
    elsif ( $ref1 eq 'SCALAR' )
    {
        return $f1 == $f2 || $$f1 eq $$f2;
    }
    elsif ( $ref1 eq 'CODE' )
    {
        return undef;#__fields_equal($f1->(), $f2->());
    }
    elsif ( $ref1 && $f1->isa('Ambrosia::core::Object') )
    {
        return $f1->equal($f2,1);
    }