File Coverage

blib/lib/Tk/ToolBar.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Tk::ToolBar;

use 5.005;
use strict;
use Tk::Frame;
use Tk::Balloon;

use base qw/Tk::Frame/;
use Tk::widgets qw(Frame);

use Carp;
use POSIX qw/ceil/;

Construct Tk::Widget 'ToolBar';

use vars qw/$VERSION/;
$VERSION = '0.12';

my $edgeH = 24;
my $edgeW = 5;

my $sepH  = 24;
my $sepW  = 3;

my %sideToSticky = qw(
		      top    n
		      right  e
		      left   w
		      bottom s
		      );

my $packIn     = '';
my @allWidgets = ();
my $floating   = 0;
my %packIn;
my %containers;
my %isDummy;

1;

sub ClassInit {
    my ($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);

    # load the images.
    my $imageFile = Tk->findINC('ToolBar/tkIcons');

    if (defined $imageFile) {
	local *F;
	open F, $imageFile;

	local $_;

	while () {
	    chomp;
	    my ($n, $d) = (split /:/)[0, 4];

	    $mw->Photo($n, -data => $d);
	}
	close F;
    } else {
	carp <
WARNING: can not find tkIcons. Your installation of Tk::ToolBar is broken.
         No icons will be loaded.
EOW
;
    }
}

sub Populate {
    my ($self, $args) = @_;

    $self->SUPER::Populate($args);
    $self->{MW}     = $self->parent;
    $self->{SIDE}   = exists $args->{-side}          ? delete $args->{-side}          : 'top';
    $self->{STICKY} = exists $args->{-sticky}        ? delete $args->{-sticky}        : 'nsew';
    $self->{USECC}  = exists $args->{-cursorcontrol} ? delete $args->{-cursorcontrol} : 1;
    $self->{STYLE}  = exists $args->{-mystyle}       ? delete $args->{-mystyle}       : 0;
    $packIn         = exists $args->{-in}            ? delete $args->{-in}            : '';

    if ($packIn) {
      unless ($packIn->isa('Tk::ToolBar')) {
	croak "value of -packin '$packIn' is not a Tk::ToolBar object";
      } else {
	$self->{SIDE} = $packIn->{SIDE};
      }
    }

    unless ($self->{STICKY} =~ /$sideToSticky{$self->{SIDE}}/) {
	croak "can't place '$self->{STICKY}' toolbar on '$self->{SIDE}' side";
    }

    $self->{CONTAINER} = $self->{MW}->Frame;
    $self->_packSelf;

    my $edge = $self->{CONTAINER}->Frame(qw/
					 -borderwidth 2
					 -relief ridge
					 /);

    $self->{EDGE} = $edge;

    $self->_packEdge($edge, 1);

    $self->ConfigSpecs(
		       -movable          => [qw/METHOD  movable          Movable             1/],
		       -close            => [qw/PASSIVE close            Close              15/],
		       -activebackground => [qw/METHOD  activebackground ActiveBackground/, Tk::ACTIVE_BG],
		       -indicatorcolor   => [qw/PASSIVE indicatorcolor   IndicatorColor/,   '#00C2F1'],
		       -indicatorrelief  => [qw/PASSIVE indicatorrelief  IndicatorRelief    flat/],
		       -float            => [qw/PASSIVE float            Float              1/],
		      );

    push @allWidgets => $self;

    $containers{$self->{CONTAINER}} = $self;

    $self->{BALLOON} = $self->{MW}->Balloon;

    # check for Tk::CursorControl
    $self->{CC} = undef;
    if ($self->{USECC}) {
	local $^W = 0; # suppress message from Win32::API
	eval "require Tk::CursorControl";
	unless ($@) {
	    # CC is installed. Use it.
	    $self->{CC} = $self->{MW}->CursorControl;
	}
    }
}

sub activebackground {
    my ($self, $c) = @_;

    return unless $c; # ignore falses.

    $self->{ACTIVE_BG} = $c;
}

sub _packSelf {
    my $self = shift;

    my $side = $self->{SIDE};
    my $fill = 'y';
    if ($side eq 'top' or $side eq 'bottom') { $fill = 'x' }

    if ($packIn && $packIn != $self) {
	my $side = $packIn->{SIDE} =~ /top|bottom/ ? 'left' : 'top';

	$self->{CONTAINER}->pack(-in => $packIn->{CONTAINER},
				 -side => $side,
				 -anchor => ($fill eq 'x' ? 'w' : 'n'),
				 -expand => 0);
	$self->{CONTAINER}->raise;
	$packIn{$self->{CONTAINER}} = $packIn->{CONTAINER};
    } else {
	# force a certain look! for now.
	my $slave = ($self->{MW}->packSlaves)[0];

	$self->configure(qw/-relief raised -borderwidth 1/);
	$self->pack(-side => $side, -fill => $fill,
		    $slave ? (-before => $slave) : ()
		    );

	$self->{CONTAINER}->pack(-in => $self,
				 -anchor => ($fill eq 'x' ? 'w' : 'n'),
				 -expand => 0);

	$packIn{$self->{CONTAINER}} = $self;
    }
}

sub _packEdge {
    my $self = shift;
    my $e    = shift;
    my $w    = shift;

    my $s    = $self->{SIDE};

    my ($pack, $pad, $nopad, $fill);

    if ($s eq 'top' or $s eq 'bottom') {
      if ($w) {
	$e->configure(-height => $edgeH, -width => $edgeW);
      } else {
	$e->configure(-height => $sepH, -width => $sepW);
      }
      $pack  = 'left';
      $pad   = '-padx';
      $nopad = '-pady';
      $fill  = 'y';
    } else {
      if ($w) {
	$e->configure(-height => $edgeW, -width => $edgeH);
      } else {
	$e->configure(-height => $sepW, -width => $sepH);
      }

      $pack  = 'top';
      $pad   = '-pady';
      $nopad = '-padx';
      $fill  = 'x';
    }

    if (exists $self->{SEPARATORS}{$e}) {
	$e->configure(-cursor => $pack eq 'left' ? 'sb_h_double_arrow' : 'sb_v_double_arrow');
	$self->{SEPARATORS}{$e}->pack(-side   => $pack,
				      -fill   => $fill);
    }

    $e->pack(-side  => $pack, $pad => 5,
	     $nopad => 0,  -expand => 0);
}

sub movable {
    my ($self, $value) = @_;

    if (defined $value) {
	$self->{ISMOVABLE} = $value;
	my $e = $self->_edge;

	if ($value) {
	    $e->configure(qw/-cursor fleur/);
	    $self->afterIdle(sub {$self->_enableEdge()});
	} else {
	    $e->configure(-cursor => undef);
	    $self->_disableEdge($e);
	}
    }

    return $self->{ISMOVABLE};
}

sub _enableEdge {
  my ($self) = @_;

  my $e     = $self->_edge;
  my $hilte = $self->{MW}->Frame(-bg     => $self->cget('-indicatorcolor'),
				 -relief => $self->cget('-indicatorrelief'));

  my $dummy = $self->{MW}->Frame(
				 qw/
				 -borderwidth 2
				 -relief ridge
				 /);

  $self->{DUMMY} = $dummy;

  my $drag     = 0;
  #my $floating = 0;
  my $clone;

  my @mwSize;  # extent of mainwindow.

  $e->bind('<1>'         => sub {
	     $self->{CC}->confine($self->{MW}) if defined $self->{CC};
	     my $geom      = $self->{MW}->geometry;
	     my ($rx, $ry) = ($self->{MW}->rootx, $self->{MW}->rooty);

	     if ($geom =~ /(\d+)x(\d+)/) {#\+(\d+)\+(\d+)/) {
#	       @mwSize = ($3, $4, $1 + $3, $2 + $4);
	       @mwSize = ($rx, $ry, $1 + $rx, $2 + $ry);
	     } else {
	       @mwSize = ();
	     }

	     if (!$self->{ISCLONE} && $self->{CLONE}) {
	       $self->{CLONE}->destroy;
	       $self->{CLONE} = $clone = undef;
	       @allWidgets = grep Tk::Exists, @allWidgets;
	     }

	   });

  $e->bind('' => sub {
	     my ($x, $y) = ($self->pointerx - $self->{MW}->rootx - ceil($e->width /2) - $e->x,
			    $self->pointery - $self->{MW}->rooty - ceil($e->height/2) - $e->y);

	     my ($px, $py) = $self->pointerxy;

	     $dummy = $self->{ISCLONE} ? $self->{CLONE}{DUMMY} : $self->{DUMMY};

	     unless ($drag or $floating) {
	       $drag = 1;
	       $dummy->raise;
	       my $noclone = $self->{ISCLONE} ? $self->{CLONE} : $self;
	       $noclone->packForget;
	       $noclone->{CONTAINER}->pack(-in => $dummy);
	       $noclone->{CONTAINER}->raise;
	       ref($_) eq 'Tk::Frame' && $_->raise for $noclone->{CONTAINER}->packSlaves;
	     }
	     $hilte->placeForget;

	     if ($self->cget('-float') &&
		 (@mwSize and
		 $px < $mwSize[0] or
		 $py < $mwSize[1] or
		 $px > $mwSize[2] or
		 $py > $mwSize[3])) {

	       # we are outside .. switch to toplevel mode.
	       $dummy->placeForget;
	       $floating = 1;

	       unless ($self->{CLONE} || $self->{ISCLONE}) {
		 # clone it.
		 my $clone = $self->{MW}->Toplevel(qw/-relief ridge -borderwidth 2/);
		 $clone->withdraw;
		 $clone->overrideredirect(1);
		 $self->_clone($clone);
		 $self->{CLONE} = $clone;
	       }

	       $clone = $self->{ISCLONE} || $self->{CLONE};
	       $clone->deiconify unless $clone->ismapped;
	       $clone->geometry("+$px+$py");

	     } else {
	       $self->{ISCLONE}->withdraw if $self->{CLONE} && $self->{ISCLONE};

	       $dummy->place('-x' => $x, '-y' => $y);
	       $floating = 0;

	       if (my $newSide = $self->_whereAmI($x, $y)) {
		 # still inside main window.
		 # highlight the close edge.
		 $clone && $clone->ismapped && $clone->withdraw;
		 #$self->{ISCLONE}->withdraw if $self->{CLONE} && $self->{ISCLONE};

		 my ($op, $pp);
		 if ($newSide =~ /top/) {
		   $op = [qw/-height 5/];
		   $pp = [qw/-relx 0 -relwidth 1 -y 0/];
		 } elsif ($newSide =~ /bottom/) {
		   $op = [qw/-height 5/];
		   $pp = [qw/-relx 0 -relwidth 1 -y -5 -rely 1/];
		 } elsif ($newSide =~ /left/) {
		   $op = [qw/-width 5/];
		   $pp = [qw/-x 0 -relheight 1 -y 0/];
		 } elsif ($newSide =~ /right/) {
		   $op = [qw/-width 5/];
		   $pp = [qw/-x -5 -relx 1 -relheight 1 -y 0/];
		 }

		 $hilte->configure(@$op);
		 $hilte->place(@$pp);
		 $hilte->raise;
	       }
	     }
	   });

    $e->bind('' => sub {
	my $noclone = $self->{ISCLONE} ? $self->{CLONE} : $self;
	$noclone->{CC}->free($noclone->{MW}) if defined $noclone->{CC};
	return unless $drag;

	$drag = 0;
	$dummy->placeForget;

	# forget everything if it's cloned.
	return if $clone && $clone->ismapped;

	# destroy the clone.
	#$clone->destroy;

	#return unless $self->_whereAmI(1);
	$noclone->_whereAmI(1);
	$hilte->placeForget;

	# repack everything now.
	my $ec = $noclone->_edge;
	my @allSlaves = grep {$_ ne $ec} $noclone->{CONTAINER}->packSlaves;
	$_   ->packForget for $noclone, @allSlaves, $noclone->{CONTAINER};

	$noclone->_packSelf;
	$noclone->_packEdge($ec, 1);
	$noclone->_packWidget($_) for @allSlaves;
    });
}

sub _whereAmI {
    my $self = shift;

    my $flag = 0;
    my ($x, $y);

    if (@_ == 1) {
	$flag = shift;
	my $e    = $self->_edge;
	($x, $y) = ($self->pointerx - $self->{MW}->rootx - ceil($e->width /2) - $e->x,
		    $self->pointery - $self->{MW}->rooty - ceil($e->height/2) - $e->y);
    } else {
	($x, $y) = @_;
    }

    my $x2 = $x + $self->{CONTAINER}->width;
    my $y2 = $y + $self->{CONTAINER}->height;

    my $w  = $self->{MW}->Width;
    my $h  = $self->{MW}->Height;

    # bound check
    $x     = 1      if $x  <= 0;
    $y     = 1      if $y  <= 0;
    $x     = $w - 1 if $x  >= $w;
    $y     = $h - 1 if $y  >= $h;

    $x2    = 0      if $x2 <= 0;
    $y2    = 0      if $y2 <= 0;
    $x2    = $w - 1 if $x2 >= $w;
    $y2    = $h - 1 if $y2 >= $h;

    my $dx = 0;
    my $dy = 0;

    my $close = $self->cget('-close');

    if    ($x       < $close) { $dx = $x }
    elsif ($w - $x2 < $close) { $dx = $x2 - $w }

    if    ($y       < $close) { $dy = $y }
    elsif ($h - $y2 < $close) { $dy = $y2 - $h }

    $packIn       = '';
    if ($dx || $dy) {
	my $newSide;
	if ($dx && $dy) {
	    # which is closer?
	    if (abs($dx) < abs($dy)) {
		$newSide = $dx > 0 ? 'left' : 'right';
	    } else {
		$newSide = $dy > 0 ? 'top' : 'bottom';
	    }
	} elsif ($dx) {
	    $newSide = $dx > 0 ? 'left' : 'right';
	} else {
	    $newSide = $dy > 0 ? 'top' : 'bottom';
	}

	# make sure we're stickable on that side.
	return undef unless $self->{STICKY} =~ /$sideToSticky{$newSide}/;

	$self->{SIDE} = $newSide if $flag;
	return $newSide;
    } elsif ($flag) {
	# check for overlaps.
	for my $w (@allWidgets) {
	    next if $w == $self;

	    my $x1 = $w->x;
	    my $y1 = $w->y;
	    my $x2 = $x1 + $w->width;
	    my $y2 = $y1 + $w->height;

	    if ($x > $x1 and $y > $y1 and $x < $x2 and $y < $y2) {
		$packIn = $w;
		last;
	    }
	}

      $self->{SIDE} = $packIn->{SIDE} if $packIn;
#	if ($packIn) {
#	  $self->{SIDE} = $packIn->{SIDE};
#	} else {
#	  return undef;
#	}
    } else {
	return undef;
    }

    return 1;
}

sub _disableEdge {
    my ($self, $e) = @_;

    $e->bind(''       => undef);
    $e->bind('' => undef);
}

sub _edge {
    $_[0]->{EDGE};
}

sub ToolButton {
    my $self = shift;
    my %args = @_;

    my $type = delete $args{-type} || 'Button';

    unless ($type eq 'Button' or
	    $type eq 'Checkbutton' or
	    $type eq 'Menubutton' or
	    $type eq 'Radiobutton') {

	croak "toolbutton can be only 'Button', 'Menubutton', 'Checkbutton', or 'Radiobutton'";
    }

    my $m = delete $args{-tip}         || '';
    my $x = delete $args{-accelerator} || '';

    my $but = $self->{CONTAINER}->$type(%args,
				      $self->{STYLE} ? () : (
							     -relief      => 'flat',
							     -borderwidth => 1,
							    ),
				     );

    $self->_createButtonBindings($but);
    $self->_configureWidget     ($but);

    push @{$self->{WIDGETS}} => $but;
    $self->_packWidget($but);

    $self->{BALLOON}->attach($but, -balloonmsg => $m) if $m;
    $self->{MW}->bind($x => [$but, 'invoke'])         if $x;

    # change the bind tags.
    #$but->bindtags([$but, ref($but), $but->toplevel, 'all']);

    return $but;
}

sub ToolLabel {
    my $self = shift;

    my $l = $self->{CONTAINER}->Label(@_);

    push @{$self->{WIDGETS}} => $l;

    $self->_packWidget($l);

    return $l;
}

sub ToolEntry {
    my $self = shift;
    my %args = @_;

    my $m = delete $args{-tip} || '';
    $args{-width} = 5 unless exists $args{-width};
    my $l = $self->{CONTAINER}->Entry(%args);

    push @{$self->{WIDGETS}} => $l;

    $self->_packWidget($l);
    $self->{BALLOON}->attach($l, -balloonmsg => $m) if $m;

    return $l;
}

sub ToolLabEntry {
    my $self = shift;
    my %args = @_;

    require Tk::LabEntry;
    my $m = delete $args{-tip} || '';
    $args{-width} = 5 unless exists $args{-width};
    my $l = $self->{CONTAINER}->LabEntry(%args);

    push @{$self->{WIDGETS}} => $l;

    $self->_packWidget($l);
    $self->{BALLOON}->attach($l, -balloonmsg => $m) if $m;

    return $l;
}

sub ToolOptionmenu {
    my $self = shift;
    my %args = @_;

    my $m = delete $args{-tip} || '';
    my $l = $self->{CONTAINER}->Optionmenu(%args);

    push @{$self->{WIDGETS}} => $l;

    $self->_packWidget($l);
    $self->{BALLOON}->attach($l, -balloonmsg => $m) if $m;

    return $l;
}

sub ToolBrowseEntry {
    my $self = shift;
    my %args = @_;

	require Tk::BrowseEntry;
    my $m = delete $args{-tip} || '';
    my $l = $self->{CONTAINER}->BrowseEntry(%args);

    push @{$self->{WIDGETS}} => $l;

    $self->_packWidget($l);
    $self->{BALLOON}->attach($l, -balloonmsg => $m) if $m;

    return $l;
}

sub separator {
    my $self = shift;
    my %args = @_;

    my $move = 1;
    $move    = $args{-movable} if exists $args{-movable};
    my $just = $args{-space} || 0;

    my $f    = $self->{CONTAINER}->Frame(-width => $just, -height => 0);

    my $sep  = $self->{CONTAINER}->Frame(qw/
					 -borderwidth 5
					 -relief sunken
					 /);

    $isDummy{$f} = $self->{SIDE};

    push @{$self->{WIDGETS}} => $sep;
    $self->{SEPARATORS}{$sep} = $f;
    $self->_packWidget($sep);

    $self->_createSeparatorBindings($sep) if $move;

    if ($just eq 'right' || $just eq 'bottom') {
      # just figure out the good width.
    }

    return 1;
}

sub _packWidget {
    my ($self, $b) = @_;

    return $self->_packEdge($b) if exists $self->{SEPARATORS}{$b};

    my ($side, $pad, $nopad) = $self->{SIDE} =~ /^top$|^bottom$/ ?
	qw/left -padx -pady/ : qw/top -pady -padx/;

    if (ref($b) eq 'Tk::LabEntry') {
	$b->configure(-labelPack => [-side => $side]);
    }

    my @extra;
    if (exists $packIn{$b}) {
	@extra = (-in => $packIn{$b});

	# repack everything now.
	my $top = $containers{$b};
	$top->{SIDE} = $self->{SIDE};

	my $e = $top->_edge;
	my @allSlaves = grep {$_ ne $e} $b->packSlaves;
	$_   ->packForget for @allSlaves;

	$top->_packEdge($e, 1);
	$top->_packWidget($_) for @allSlaves;
    }

    if (exists $isDummy{$b}) { # swap width/height if we need to.
	my ($w, $h);

	if ($side eq 'left' && $isDummy{$b} =~ /left|right/) {
	    $w = 0;
	    $h = $b->height;
	} elsif ($side eq 'top'  && $isDummy{$b} =~ /top|bottom/) {
	    $w = $b->width;
	    $h = 0;
	}

	$b->configure(-width => $h, -height => $w) if defined $w;
	$isDummy{$b} = $self->{SIDE};
    }

    $b->pack(-side => $side, $pad => 4, $nopad => 0, @extra);
}

sub _packWidget_old {
    my ($self, $b) = @_;

    return $self->_packEdge($b) if exists $self->{SEPARATORS}{$b};

    my ($side, $pad, $nopad) = $self->{SIDE} =~ /^top$|^bottom$/ ?
	qw/left -padx -pady/ : qw/top -pady -padx/;

    if (ref($b) eq 'Tk::LabEntry') {
	$b->configure(-labelPack => [-side => $side]);
    }

    my @extra;
    if (exists $packIn{$b}) {
	@extra = (-in => $packIn{$b});

	# repack everything now.
	my $top = $containers{$b};
	$top->{SIDE} = $self->{SIDE};

	my $e = $top->_edge;
	my @allSlaves = grep {$_ ne $e} $b->packSlaves;
	$_   ->packForget for @allSlaves;

	$top->_packEdge($e, 1);
	$top->_packWidget($_) for @allSlaves;
    }

    $b->pack(-side => $side, $pad => 4, $nopad => 0, @extra);
}

sub _configureWidget {
    my ($self, $w) = @_;

    $w->configure(-activebackground => $self->{ACTIVE_BG});
}

sub _createButtonBindings {
    my ($self, $b) = @_;

    my $bg = $b->cget('-bg');

    $b->bind('' => [$b, 'configure', qw/-relief raised/]);
    $b->bind('' => [$b, 'configure', qw/-relief flat/]);
}

sub _createSeparatorBindings {
  my ($self, $s) = @_;

  my ($ox, $oy);

  $s->bind('<1>'         => sub {
	     $ox = $s->XEvent->x;
	     $oy = $s->XEvent->y;
	   });

  $s->bind('' => sub {
	     my $x = $s->XEvent->x;
	     my $y = $s->XEvent->y;

	     my $f = $self->{SEPARATORS}{$s};

	     if ($self->{SIDE} =~ /top|bottom/) {
	       my $dx = $x - $ox;

	       my $w  = $f->width + $dx;
	       $w     = 0 if $w < 0;

	       $f->GeometryRequest($w, $f->height);
	     } else {
	       my $dy = $y - $oy;

	       my $h  = $f->height + $dy;
	       $h     = 0 if $h < 0;

	       $f->GeometryRequest($f->width, $h);
	     }
	   });
}

sub Button     { goto &ToolButton      }
sub Label      { goto &ToolLabel       }
sub Entry      { goto &ToolEntry       }
sub LabEntry   { goto &ToolLabEntry    }
sub Optionmenu { goto &ToolOptionmenu  }
sub BrowseEntry { goto &ToolBrowseEntry }

sub _clone {
  my ($self, $top, $in) = @_;

  my $new = $top->ToolBar(qw/-side top -cursorcontrol/, $self->{USECC}, ($in ? (-in => $in, -movable => 0) : ()));
  my $e   = $self->_edge;

  my @allSlaves = grep {$_ ne $e} $self->{CONTAINER}->packSlaves;
  for my $w (@allSlaves) {
    my $t = ref $w;
    $t =~ s/Tk:://;

    if ($t eq 'Frame' && exists $containers{$w}) { # embedded toolbar
      my $obj = $containers{$w};
      $obj->_clone($top, $new);
    }

    if ($t eq 'Frame' && exists $self->{SEPARATORS}{$w}) {  # separator
      $new->separator;
    }

    my %c = map { $_->[0], $_->[4] || $_->[3] } grep {defined $_->[4] || $_->[3] } grep @$_ > 2, $w->configure;
    delete $c{$_} for qw/-offset -class -tile -visual -colormap -labelPack/;

    if ($t =~ /.button/) {
      $new->Button(-type => $t,
		   %c);
    } else {
      $new->$t(%c);
    }
  }

  $new ->{MW}      = $self->{MW};
  $new ->{CLONE}   = $self;
  $new ->{ISCLONE} = $top;
  $self->{ISCLONE} = 0;
}

__END__