File Coverage

blib/lib/Tk/GraphItems/Node.pm

Criterion	Covered	Total	%
statement	15	66	22.7
branch	0	8	0.0
condition	0	10	0.0
subroutine	5	17	29.4
pod	0	3	0.0
total	20	104	19.2

package Tk::GraphItems::Node;


# Copyright (C) 2007 by Christoph Lamprecht

# This library is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself, either Perl version 5.8.7 or,
# at your option, any later version of Perl 5 you may have available.



use 5.008;
our $VERSION = '0.11';

#use Data::Dumper;
use Carp;
use warnings;
use strict;
use Scalar::Util (qw/looks_like_number/);
require Tk::GraphItems::GraphItem;
require Tk::GraphItems::TiedCoord;
our @ISA = qw/ Tk::GraphItems::GraphItem /;


{
my %iinfo = (-text=>1);                # item information hash

sub _set_canvas_bindings_for_tag{
    my ($self,$tag) = @_;
    my $can = $self->{canvas};

    $can->bind($tag,'<1>' => sub {
                   my($can) = @_;
                   my $e    = $can->XEvent;
                   _items_start_drag ($can, $e->x, $e->y, \%iinfo);
               }
           );
    $can->bind($tag,'' =>sub {
                   _items_drag ($can,
                                $Tk::event->x,
                                $Tk::event->y,
                                \%iinfo);
               }
           );
}
} #end scope of iinfo

sub _items_drag {
    my($can, $x, $y, $iinfo) = @_;

    my $id= ($can->find(withtag => 'current'))[0];
    my $self = _get_inst_by_id($can,$id);
    my ($d_x,$d_y) = ($x-$iinfo->{lastX},$y-$iinfo->{lastY});
    $self->_move($d_x ,$d_y);
    $self->{was_dragged}=1;

    $iinfo->{lastX} = $x;
    $iinfo->{lastY} = $y;

} # end items_drag

sub _items_start_drag {

    my($can, $x, $y, $iinfo) = @_;
    $iinfo->{lastX} = $x;
    $iinfo->{lastY} = $y;
    my $id= ($can->find(withtag => 'current'))[0];
    my $self = _get_inst_by_id($can,$id);
    $self->{was_dragged}=0;

} # end items_start_drag



sub move{
    my $self = shift;
    looks_like_number($_)||
        croak "method 'move' failed: args <$_[0]>,<$_[1]> have to be numbers!"
            for (@_[0,1]);
    $self->_move(@_);
}

sub _move{
    my ($self,$d_x,$d_y) = @_;
    my ($x,$y) = $self->get_coords;
    $self->_set_coords($x+$d_x,$y+$d_y);
}
sub set_coords{
    my $self = shift;
    if (ref $_[0]&& ref$_[1]) {
        $self->_tie_coords(@_);
        return;
    }
    for ( @_[0,1] ) {
        looks_like_number($_)||
            croak "method 'set_coords' failed:\n"
                 ."args <$_[0]>,<$_[1]> have to be numbers!";
    }
    $self->_set_coords(@_);
}

sub _tie_coords{
    my $self = shift;
    $self ->_untie_coords;
    tie ${$_[0]}, 'Tk::GraphItems::TiedCoord',$self,0 if ref $_[0];
    tie ${$_[1]}, 'Tk::GraphItems::TiedCoord',$self,1 if ref $_[1];
    @$self{qw/tiedx tiedy/}= @_[0,1];
}
sub _untie_coords{
    my $self = shift;
    for (@$self{qw/tiedx tiedy/}) {
        untie ${$_} ;                #if tied $$_
    }
}

sub was_dragged{
    my $self = shift;
    return $self->{was_dragged} ||0;
}

sub _get_inst_by_id{
    my ($can,$id) = @_;
    my $obj_map = $can->{GraphItemsMap};
    return $obj_map->{$id}||undef;
}




1;

__END__