view release on metacpan or  search on metacpan

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

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' )
    {
        $ex_node->setAttribute( $p, $$v);
    }
    elsif ( $refV && eval{$v->as_hash} )
    {
        my $node = $document->createElement($p);
        my $h = $v->as_hash;
        proces_node( $document, $node, $_, $h->{$_}, $error_ignore ) foreach keys %$h;
        $ex_node->addChild($node);
    }
    elsif ( $refV eq 'CODE' )
    {
        as_xml_nodes($document, $ex_node, $p, $v->(), $error_ignore);
    }
    elsif ( $refV && eval{$v->can('as_xml')} )
    {
        $ex_node->addChild($v->as_xml(
                                document => $document,
                                name => $p,
                                error_ignore => $error_ignore,
                                need_node => 1,
                            ));
    }
    elsif( $force_node )
    {
        my $node = $document->createElement($force_node);
        proces_node($document, $node, $force_node, $v, $error_ignore);
        $ex_node->addChild($node);
    }
    else
    {
        $ex_node->setAttribute( $p, $v );
    }
    return $ex_node;
}

# Parameters
#    document => 'xml_document', #optional. If not defined then the document will be created.
#    charset => 'charset_of_xml_document', #if not defined document. Optional. Default is 'utf8'
#    name => 'name_of_root_node', #optional. If nod present then the name will be making from '$self'
#    error_ignore => 'true or false in perl notation (1 or 0))', #optional. default is true
#    methods => [], #optional. See 
#

sub as_xml
{
    my $self = shift;
    my %params = @_;

    my ($name_node, $document);

    unless ( $name_node = $params{name} )
    {
        $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;

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

        {
            my $self = shift;
            return $self->b1 . ';' . $self->b2;
        }
    
        1;
    }
    {
        package Foo;
        Ambrosia::Meta;
        class
        {
            public => [qw/f1 f2 bar/],
        };
        
        sub m1
        {
            return 'method of m1 run with: ' . $_[1];
        }
        
        sub getBar
        {
            return $_[0]->bar;
        }
        
        sub dump
        {
            my $self = shift;
            return $self->as_hash(1, 'm1:method1(123)', 'getBar{join}');
        }
        1;
    }

=head2 copy_to ($dest)

Makes copy of the source object to the destination object (only public fields are copied).
    C<$source-E<gt>copy_to($dest)>

=head2 clone ($deep)

Makes clone of object.
If C<$deep> is true it will create a deep clone.
And vice versa if C<$deep> is false it will create a simple clone.
If a field is a reference to some data then the field of simple clone will also refer to these data.

Note for deep clone: if any field is the reference to any object, this object will also be cloned but only if it has the method C<clone>

=head2 as_xml ($document, $charset, $name, $error_ignore, @methods)

Converts the object to the XML Document (L<XML::LibXML::Document>).
Is called with the following params

=over 4

=item document

The xml document. Optional. If not defined, the document will be created.

=item charset

Charset of xml document if it has not been defined. Optional. Default is 'utf8'.

=item name

Name of root node. Optional. If not presented, the class name will be used.

=item error_ignore ($bool)

True or false in perl notation (1 or 0). Optional. Default value is true.
In the case of error and if C<$bool> is true, the error will be ignored.

item methods

Optional. See L<as_hash>.

=back

=head2 equal ($other_object, $deep, $identical)

Compares two objects.
$object->equal($other_object, $deep, $identical);
If $deep is true, deep compare will be executed.
If $identical is true, only references of objects will be compared.

    my $obj = new SomeObject();
    my $ref = $obj;
    my $obj2 = new SomeObject();

    $obj->equal($ref,0,1); #is true
    $obj->equal($obj2,0,1); #is false
    $obj->equal($obj2); #is true
    $obj->equal($obj2,1); #is true

=head1 DEPENDENCIES

L<XML::LibXML>
L<Data::Serializer>
L<Ambrosia::error::Exceptions>
L<Ambrosia::core::Nil>

=head1 THREADS

Not tested.

=head1 BUGS

Please report bugs relevant to C<Ambrosia> to <knm[at]cpan.org>.

=head1 SEE ALSO

L<Ambrosia::Meta>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2010-2012 Nickolay Kuritsyn. All rights reserved.

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

=head1 AUTHOR