view Lib/IMPL/DOM/Node.pm @ 250:129e48bb5afb

DOM refactoring ObjectToDOM methods are virtual QueryToDOM uses inflators Fixed transform for the complex values in the ObjectToDOM QueryToDOM doesn't allow to use complex values (HASHes) as values for nodes (overpost problem)
author sergey
date Wed, 07 Nov 2012 04:17:53 +0400
parents a8db61d0ed33
children 6253872024a4
line wrap: on
line source

package IMPL::DOM::Node;
use strict;
use warnings;

use parent qw(IMPL::Object);

use IMPL::Object::List;
use IMPL::Class::Property;
use IMPL::Class::Property::Direct;
use Scalar::Util qw(weaken);

use IMPL::Exception;

BEGIN {
    public _direct property nodeName => prop_get;
    public _direct property document => prop_get;
    public _direct property isComplex => { get => \&_getIsComplex } ;
    public _direct property nodeValue => prop_all;
    public _direct property childNodes => { get => \&_getChildNodes }; # prop_list
    public _direct property parentNode => prop_get | owner_set;
    public _direct property schema => prop_get | owner_set;
    public _direct property schemaSource => prop_get | owner_set;
    private _direct property _propertyMap => prop_all ;
    
}

our %Axes = (
    parent => \&selectParent,
    siblings => \&selectSiblings,
    child => \&childNodes,
    document => \&selectDocument,
    ancestor => \&selectAncestors,
    descendant => \&selectDescendant
);

sub CTOR {
    my ($this,%args) = @_;
    
    $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required");
    $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue};
    if ( exists $args{document} ) {
        $this->{$document} = delete $args{document};
        weaken($this->{$document});
    }
    
    while ( my ($key,$value) = each %args ) {
        $this->nodeProperty($key,$value);
    }
}

sub insertNode {
    my ($this,$node,$pos) = @_;
    
    die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node;
    
    $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
    
    $this->childNodes->InsertAt($pos,$node);
    
    $node->_setParent( $this );
    
    return $node;
}

sub appendChild {
    my ($this,$node) = @_;
    
    die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node;
    
    $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
    
    my $children = $this->childNodes;
    $children->Append($node);
    
    $node->_setParent( $this );
    
    return $node;
}

sub appendNode {
    goto &appendChild;
}

sub appendRange {
    my ($this,@range) = @_;
    
    die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range;
    
    foreach my $node (@range) {
        $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
        $node->_setParent( $this );
    }
    
    $this->childNodes->Append(@range);
    
    return $this;
}

sub _getChildNodes {
    my ($this) = @_;
    
    $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes};
    return wantarray ? @{ $this->{$childNodes} } : $this->{$childNodes};
}

sub childNodesRef {
    my ($this) = @_;
    return scalar $this->_getChildNodes;
}

sub removeNode {
    my ($this,$node) = @_;
    
    if ($this == $node->{$parentNode}) {
        $this->childNodes->RemoveItem($node);
        $node->_setParent(undef);
        return $node;
    } else {
        die new IMPL::InvalidOperationException("The specified node isn't belong to this node");
    }
}

sub replaceNodeAt {
    my ($this,$index,$node) = @_;
    
    my $nodeOld = $this->childNodes->[$index];
        
    die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node;
        
    # unlink node from previous parent
    $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
        
    # replace (or set) old node
    $this->childNodes->[$index] = $node;
        
    # set new parent
    $node->_setParent( $this );
        
    # unlink old node if we have one
    $nodeOld->_setParent(undef) if $nodeOld;
        
    # return old node
    return $nodeOld;
}

sub removeAt {
    my ($this,$pos) = @_;
    
    if ( my $node = $this->childNodes->RemoveAt($pos) ) {
        $node->_setParent(undef);
        return $node;
    } else {
        return undef;
    }
}

sub removeLast {
    my ($this) = @_;
    
    if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) {
        $node->_setParent(undef);
        return $node;
    } else {
        return undef;
    }
}

sub removeSelected {
    my ($this,$query) = @_;
    
    my @newSet;
    my @result;
    
    if (ref $query eq 'CODE') {
        &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes};
    } elsif (defined $query) {
        $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes};
    } else {
        my $children = $this->childNodes;
        $_->_setParent(undef) foreach @$children;
        delete $this->{$childNodes};
        return wantarray ? @$children : $children;
    }
    
    $_->_setParent(undef) foreach @result;
    
    $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef;
    
    return wantarray ? @result : \@result;
}

sub resolveAxis {
    my ($this,$axis) = @_;
    return $Axes{$axis}->($this)
}

sub selectNodes {
    my $this = shift;
    my $path;
    
    if (@_ == 1) {
        $path = $this->translatePath($_[0]);
    } else {
        $path = [@_];
    }
    
    my @set = ($this);
    
    while (@$path) {
        my $query = shift @$path;
        @set = map $_->selectNodesAxis($query), @set;
    }
    
    return wantarray ? @set : \@set;   
}

sub selectSingleNode {
    my $this = shift;
    my @result = $this->selectNodes(@_);
    return $result[0];
}

sub selectNodesRef {
    my $this = shift;
    
    my @result = $this->selectNodes(@_);
    return \@result;
}

sub translatePath {
    my ($this,$path) = @_;
    
    # TODO: Move path compilation here from IMPL::DOM::Schema::Validator::Compare
    return [$path];
}

sub selectNodesAxis {
     my ($this,$query,$axis) = @_;
    
    $axis ||= 'child';
    
    die new IMPL::InvalidOperationException('Unknown axis',$axis) unless exists $Axes{$axis};
    
    my $nodes = $this->resolveAxis($axis);
    
    my @result;
    
    if (ref $query eq 'CODE') {
        @result = grep &$query($_), @{$nodes};
    } elsif (ref $query eq 'ARRAY' ) {
        my %keys = map (($_,1),@$query);
        @result = grep $keys{$_->nodeName}, @{$nodes};
    } elsif (ref $query eq 'HASH') {
        while( my ($axis,$filter) = each %$query ) {
            push @result, $this->selectNodesAxis($filter,$axis);
        }
    } elsif (defined $query) {
        @result = grep $_->nodeName eq $query, @{$nodes};
    } else {
        return wantarray ? @{$nodes} : $nodes;
    }
    
    return wantarray ? @result : \@result;
}

sub selectParent {
    my ($this) = @_;
    
    if ($this->parentNode) {
        return wantarray ? $this->parentNode : [$this->parentNode];
    } else {
        return wantarray ? () : [];
    }
}

sub selectSiblings {
    my ($this) = @_;
    
    if ($this->parentNode) {
        return $this->parentNode->selectNodes( sub { $_ != $this } );
    } else {
        return wantarray ? () : [];
    }
}

sub selectDocument {
    my ($this) = @_;
    
    if ($this->document) {
        return wantarray ? $this->document : [$this->document];
    } else {
        return wantarray ? () : [];
    }
}

sub selectDescendant {
    wantarray ?
        map $_->selectAll(), $_[0]->childNodes :
        [map $_->selectAll(), $_[0]->childNodes]
}

sub selectAll {
    map(selectAll($_),@{$_[0]->childNodes}) , $_[0]
}

sub selectAncestors {
    my $parent = $_[0]->parentNode;
    
    wantarray ?
        ($parent ? ($parent->selectAncestors,$parent) : ()) :
        [$parent ? ($parent->selectAncestors,$parent) : ()]
}

sub firstChild {
    @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0];
}

sub _getIsComplex {
    ($_[0]->{$childNodes} and $_[0]->{$childNodes}->Count) ? 1 : 0;
}

sub _updateDocRefs {
    my ($this) = @_;
    
    # this method is called by the parent node on his children, so we need no to check parent
    $this->{$document} = $this->{$parentNode}->document;
    
    # prevent cyclic
    weaken($this->{$document}) if $this->{$document};
    
    map $_->_updateDocRefs, @{$this->{$childNodes}} if $this->{$childNodes};
}

sub _setParent {
    my ($this,$node) = @_;
    
   
    if (($node || 0) != ($this->{$parentNode} || 0)) {
        my $newOwner;
        if ($node) {
            $this->{$parentNode} = $node;
            $newOwner = $node->document || 0;
            
            # prevent from creating cyclicreferences
            weaken($this->{$parentNode});

        } else {
            delete $this->{$parentNode};
            
            #keep document
            $newOwner = $this->{$document};
        }
        
        if (($this->{$document}||0) != $newOwner) {
            $this->{$document} = $newOwner;
            weaken($this->{$document}) if $newOwner;
            $_->_updateDocRefs foreach @{$this->childNodes};
        }
    }
}

sub text {
    my ($this) = @_;
    
    join ('', $this->nodeValue || '', map ($_->text || '', @{$this->childNodes}));
}

sub nodeProperty {
    my $this = shift;
    my $name = shift;
    
    return unless defined $name;
    
    if (my $method = $this->can($name)) {
        unshift @_,$this;
        # use goto to preserve calling context
        goto &$method;
    }
    # dynamic property
    if (@_) {
        # set
        return $this->{$_propertyMap}{$name} = shift;
    } else {
        return $this->{$_propertyMap}{$name};
    }
}

sub listProperties {
    my ($this) = @_;
    
    my %props = map {$_->Name, 1} $this->get_meta(typeof IMPL::Class::PropertyInfo, sub { $_->Attributes->{domProperty}},1);
    
    return (keys %props,keys %{$this->{$_propertyMap}});
}

sub save {
    my ($this,$writer) = @_;
    
    if ( not ( $this->isComplex or defined $this->{$nodeValue} ) ) {
        $writer->emptyTag(
            $this->{$nodeName},
            map {
                $_,
                $this->nodeProperty($_)
            } grep defined $this->nodeProperty($_), $this->listProperties
        );
    } else {
        $writer->startTag(
            $this->{$nodeName},
            map {
                $_,
                $this->nodeProperty($_)
            } grep defined $this->nodeProperty($_), $this->listProperties
        );
        $writer->characters($this->{$nodeValue}) if $this->{$nodeValue};
        
        $_->save($writer) foreach $this->childNodes;
        
        $writer->endTag($this->{$nodeName});
    }
}

sub qname {
    $_[0]->{$nodeName};
}

sub path {
    my ($this) = @_;
    
    if ($this->parentNode) {
        return $this->parentNode->path.'.'.$this->qname;
    } else {
        return $this->qname;
    }
}

1;

__END__

=pod

=head1 NAME

C<IMPL::DOM::Node> Элемент DOM модели

=head1 DESCRIPTION

Базовый узел DOM модели. От него можно наследовать другие элементы DOM модели.

=head1 MEMBERS

=head2 PROPERTIES

=over

=item C<[get] nodeName>

Имя узла. Задается при создании.

=item C<[get] document>

Документ к которому принадлежит узел. Задается при поздании узла.

=item C<[get] isComplex>

Определяет является ли узел сложным (тоесть есть ли дети).

C<true> - есть, C<false> - нет.

=item C<[get,set] nodeValue>

Значение узла, обычно простой скаляр, но ничто не мешает туда
устанавливать любое значение.

=item C<[get,list] childNodes>

Список детей, является списокм C<IMPL::Object::List>.

=item C<[get] parentNode>

Ссылка на родительский элемент, если таковой имеется.

=item C<[get] schema>

Ссылка на узел из C<IMPL::DOM::Schema>, представляющий схему данных текущего узла. Может быть C<undef>.

=item C<[get] schema>

Ссылка на узел из C<IMPL::DOM::Schema>, представляющий элемент схемы, объявляющий данный узел. Может быть C<undef>.

Отличается от свойства C<schema> тем, что узел в случае ссылки на тип узла, данной свойство будет содержать
описание ссылки C<IMPL::DOM::Schema::Node>, а свойство C<schema> например будет ссылаться на
C<IMPL::DOM::Schema::ComplexType>.

=back 

=head2 METHODS

=cut