File Coverage

blib/lib/Tk/GraphItems/LabeledConnector.pm

Criterion	Covered	Total	%
statement	12	60	20.0
branch	0	14	0.0
condition	0	16	0.0
subroutine	4	9	44.4
pod	1	5	20.0
total	17	104	16.3

package Tk::GraphItems::LabeledConnector;

=head1 NAME

Tk::GraphItems::LabeledConnector - Display edges of relation-graphs on a Tk::Canvas

=head1 SYNOPSIS


  require Tk::GraphItems::TextBox;
  require Tk::GraphItems::LabeledConnector;


  my $conn = Tk::GraphItems::LabeledConnector->new(
                                            source => $a_TextBox,
                                            target => $another_TextBox,
                                            label  => 'labeltext'
                                            );
  $conn->colour( 'red' );
  $conn->arrow( 'both' );
  $conn->width( 2 );
  $conn->detach;
  $conn = undef;




=head1 DESCRIPTION

Tk::GraphItems::LabeledConnector extends Tk::GraphItems::Connector with a 'label' option.


=head1 METHODS

B supports the following additional methods:

=over 4

=item B source      => $a_GraphItems-Node,
             target      => $a_GraphItems-NodeB,
             label       => 'label text'
             colour      => $a_TkColour,
             width       => $width_pixels,
             arrow       => $where,
             autodestroy => $bool<)>


Create a new LabeledConnector instance and  display it on the Canvas of 'source' and 'target'. See Tk::GraphItems::Connector for details.


=item B [$labeltext] B<)>

Sets the labels text to $labeltext, if the argument is given. Returns the current label, if called without an argument.


=back

=head1 SEE ALSO

Documentation of Tk::GraphItems::Connector
Documentation of Tk::GraphItems::TextBox
Examples in Tk/GraphItems/Examples

=head1 AUTHOR

Christoph Lamprecht, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008 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.


=cut
use 5.008;
our $VERSION = '0.12';


use warnings;
use strict;
use Carp;
require Tk::GraphItems::Connector;
our @ISA = ('Tk::GraphItems::Connector');

sub initialize{
    my $self = shift;
    my %args = @_;
    my $labeltext = delete ($args{label}) || '';

    my $can  = $args{source}->get_canvas;

    eval{$self->{label_id} = $can->createText(10,10,
                                              -text   => $labeltext,
                                              -anchor => 'w')};
    if ($@) {
        croak "Connector creation failed: $@";
    }
    $self->SUPER::initialize(%args);
    $self->adjust_label;
    return $self;
}

sub label{
    my $self = shift;
    my $can = $self->get_canvas;
    if (@_) {
        $can->itemconfigure($self->{label_id},-text=>$_[0]);
        return $self;
    } else {
        return $can->itemcget($self->{label_id},'-text');
    }
}

sub set_coords{
    my $self = shift;
    $self->SUPER::set_coords(@_);
    $self->adjust_label;

}
sub adjust_label{
    my $self = shift;
    my $can  = $self->{canvas};
    my $line = $self->{line_id};
    my $label_id = $self->{label_id};
    my @coords = $can->coords($line);
    my $d_x  = $coords[2] - $coords[0];
    my $d_y  = $coords[3] - $coords[1];
    my $center_x = ($coords[0] + $coords[2])/ 2;
    my $center_y = ($coords[1] + $coords[3])/ 2;
    my $term = $d_x **2 /( ($d_x **2 + $d_y**2)|| 0.0001);
    my $xo = sqrt(1 - $term);
    my $yo = sqrt($term);
    my $label_x ;
    my $label_y ;
    my $delta = 10;
    if ($d_x <= 0 && $d_y <= 0){
        $label_x = $center_x + $delta * $xo;
        $label_y = $center_y - $delta * $yo;
        #print "1\n";
    }elsif($d_x <= 0 && $d_y >= 0){
        $label_x = $center_x + $delta * $xo;
        $label_y = $center_y + $delta * $yo;
        #print "2\n";
    }elsif($d_x >= 0 && $d_y >= 0){
        $label_x = $center_x + $delta * $xo;
        $label_y = $center_y - $delta * $yo;
        #print "3\n";
    }elsif($d_x >= 0 && $d_y <= 0){
        $label_x = $center_x + $delta * $xo;
        $label_y = $center_y + $delta * $yo;
        #print "4\n";
    }

    $can->coords($label_id,
                 $label_x,
                 $label_y,
             );

}


sub canvas_items{
    my $self = shift;
    my @c_i = ($self->SUPER::canvas_items);
    push @c_i, $self->{label_id} if $self->{label_id};
    return @c_i;
}

1;




__END__