File Coverage

blib/lib/Tk/ColoredButton.pm

Criterion	Covered	Total	%
statement	15	15	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	20	20	100.0

package Tk::ColoredButton;

use warnings;
use strict;
use Carp;

#====================================================================
# $Author    : Djibril Ousmanou                                    $
# $Copyright : 2011                                                $
# $Update    : 18/07/2011 02:07:06                                 $
# $AIM       : Create gradient background color on a button        $
#====================================================================

use vars qw($VERSION);
$VERSION = '1.05';

use base qw/Tk::Derived Tk::Canvas::GradientColor/;
use Tk::Balloon;
use English '-no_match_vars';

Construct Tk::Widget 'ColoredButton';

# Id   =>  widget balloon
my %all_balloon;
my $count = 1;

my ( $system_button_face, $system_button_text, $system_disabled_text, $active_background, $default_font )
  = ();
my $FLASH_INTERVALL        = 300;
my $TEXTVARIABLE_INTERVALL = 300;
my $DASH                   = q{.};
my $SPACE                  = q{ };
my $INITWAIT               = 350;
my $SPACE_PLUS             = 4;

# Default Colors for all OS
if ( $OSNAME eq 'MSWin32' ) {
  $system_button_face   = 'SystemButtonFace';
  $active_background    = $system_button_face;
  $system_button_text   = 'SystemButtonText';
  $system_disabled_text = 'SystemDisabledText';
  $default_font         = '{MS Sans Serif} 8';
}
else {
  $system_button_face   = '#D9D9D9';
  $active_background    = '#ECECEC';
  $system_button_text   = 'black';
  $system_disabled_text = '#A3A3A3';
  $default_font         = '{Helvetica} 12 {bold}';
}

my %config = (
  balloon_tooltip => undef,
  tags            => {
    all      => '_cb_tag',
    text     => '_cb_text_tag',
    image    => '_cb_image_tag',
    bitmap   => '_cb_bitmap_tag',
    font     => '_cb_font_tag',
    focusin  => '_cb_focusin_tag',
    focusout => '_cb_focusout_tag',
    font     => '_cb_font_tag'
  },
  button => { press => 0, },
  ids    => { flash => undef, id_repeatdelay => undef },
  specialbutton => {
    -background         => $system_button_face,
    -borderwidth        => 2,
    -height             => 20,
    -highlightthickness => 0,
    -relief             => 'raised',
    -state              => 'normal',
    -width              => 80,
  },
  '-activebackground'    => $active_background,
  '-activeforeground'    => $system_button_text,
  '-activegradient'      => { -start_color => '#FFFFFF', -end_color => '#B2B2B2' },
  '-anchor'              => 'center',
  '-bitmap'              => undef,
  '-gradient'            => { -start_color => '#B2B2B2', -end_color => '#FFFFFF' },
  '-command'             => undef,
  '-compound'            => 'none',
  '-disabledforeground'  => $system_disabled_text,
  '-font'                => $default_font,
  '-foreground'          => $system_button_text,
  '-highlightbackground' => undef,
  '-image'               => undef,
  '-justify'             => 'center',
  '-overrelief'          => undef,
  '-padx'                => 1,
  '-pady'                => 1,
  '-relief'              => 'raised',
  '-textvariable'        => undef,
  '-tooltip'             => undef,
  '-wraplength'          => 0,
);

sub Populate {
  my ( $cw, $ref_parameters ) = @_;

  $cw->SUPER::Populate($ref_parameters);
  $cw->Advertise( 'GradientColor' => $cw );
  $cw->Advertise( 'canvas'        => $cw->SUPER::Canvas );
  $cw->Advertise( 'Canvas'        => $cw->SUPER::Canvas );

  $cw->{_cb_id} = $count;
  $cw->{_conf_cb}{$count} = \%config;

  # Default widget configuration
  foreach ( keys %{ $config{specialbutton} } ) {
    if ( defined $config{specialbutton}{$_} ) { $cw->configure( $_ => $config{specialbutton}{$_} ); }
  }

  # ConfigSpecs
  $cw->ConfigSpecs(
    -activebackground => [ 'PASSIVE', 'activeBackground', 'ActiveBackground', $active_background ],
    -activegradient   => [
      'PASSIVE', 'activeGradient',
      'ActiveGradient', { -start_color => '#FFFFFF', -end_color => '#B2B2B2' }
    ],
    -activeforeground   => [ 'PASSIVE', 'activeForeground',   'ActiveForeground',   $system_button_text ],
    -autofit            => [ 'PASSIVE', 'autofit',            'Autofit',            '0' ],
    -anchor             => [ 'PASSIVE', 'anchor',             'Anchor',             'center' ],
    -bitmap             => [ 'PASSIVE', 'bitmap',             'Bitmap',             undef ],
    -command            => [ 'PASSIVE', 'command',            'Command',            undef ],
    -compound           => [ 'PASSIVE', 'compound',           'Compound',           'none' ],
    -disabledforeground => [ 'PASSIVE', 'disabledForeground', 'DisabledForeground', $system_disabled_text ],
    -font               => [ 'PASSIVE', 'font',               'Font',               $default_font ],
    -foreground         => [ 'PASSIVE', 'foreground',         'Foreground',         $system_button_text ],
    -gradient =>
      [ 'PASSIVE', 'gradient', 'Gradient', { -start_color => '#B2B2B2', -end_color => '#FFFFFF' } ],
    -image          => [ 'PASSIVE', 'image',          'Image',          undef ],
    -imagedisabled  => [ 'PASSIVE', 'imageDisabled',  'ImageDisabled',  undef ],
    -justify        => [ 'PASSIVE', 'justify',        'Justify',        'center' ],
    -overrelief     => [ 'PASSIVE', 'overRelief',     'OverRelief',     undef ],
    -padx           => [ 'PASSIVE', 'padx',           'Padx',           1 ],
    -pady           => [ 'PASSIVE', 'pady',           'Pady',           1 ],
    -state          => [ 'PASSIVE', 'state',          'State',          'normal' ],
    -repeatdelay    => [ 'PASSIVE', 'repeatDelay',    'RepeatDelay',    undef ],
    -repeatinterval => [ 'PASSIVE', 'repeatInterval', 'RepeatInterval', undef ],
    -text           => [ 'PASSIVE', 'text',           'Text',           $SPACE ],
    -textvariable   => [ 'PASSIVE', 'textVariable',   'TextVariable',   undef ],
    -tooltip        => [ 'PASSIVE', 'tooltip',        'Tooltip',        undef ],
    -wraplength     => [ 'PASSIVE', 'wrapLength',     'WrapLength',     0 ],
  );

  $cw->Delegates( DEFAULT => $cw );

  foreach my $key (qw/ Down End Home Left Next Prior Right Up /) {
    $cw->Tk::bind( 'Tk::ColoredButton', "",         undef );
    $cw->Tk::bind( 'Tk::ColoredButton', "", undef );
  }
  $cw->Tk::bind( '',   \&_press_button );
  $cw->Tk::bind( '', \&_press_leave );
  $cw->Tk::bind( '',           \&_enter );
  $cw->Tk::bind( '',           \&_leave );
  $cw->Tk::bind( '',       \&_create_bouton );
  $cw->Tk::bind( '',         \&_focus_in );
  $cw->Tk::bind( '',        \&_focus_out );

  foreach my $key (qw/ Return space /) {
    $cw->Tk::bind( "",         sub { $cw->invoke; } );
    $cw->Tk::bind( "", sub { $cw->invoke; } );
  }

  $count++;
  return;
}

sub redraw_button {
  my $cw = shift;

  # Simulate press_leave and leave button
  my $button_press = $config{ $cw->{_cb_id} }{button}{press};
  if ( $button_press and $button_press == 1 ) { $cw->_leave; }
  $cw->_create_bouton;

  return;
}

sub invoke {
  my $cw = shift;

  my $state = $cw->cget( -state );
  return if ( $state eq 'disabled' );

  $cw->_command( $cw->cget( -command ) );

  return;
}

sub flash {
  my ( $cw, $interval ) = @_;

  my $state = $cw->cget( -state );
  return if ( $state eq 'disabled' );

  my $id_flash = $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{-flash};

  if ( defined $id_flash ) {
    $cw->itemconfigure( $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{text}, -fill => $cw->cget( -foreground ) );

    $id_flash->cancel;
    $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{-flash} = undef;
  }
  if ( defined $interval and $interval == 0 ) { return; }

  if ( not defined $interval ) { $interval = $FLASH_INTERVALL; }

  my $i = 0;
  $id_flash = $cw->repeat(
    $interval,
    sub {
      if ( !Tk::Exists $cw ) { return; }
      if ( $i % 2 == 0 ) {
        $cw->itemconfigure( $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{text},
          -fill => $cw->cget( -disabledforeground ) );
      }
      else {
        $cw->itemconfigure( $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{text}, -fill => $cw->cget( -foreground ) );
      }
      $i++;
    }
  );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{-flash} = $id_flash;

  return $id_flash;
}

sub delete_tooltip {
  my $cw = shift;

  my $id = $cw->{_cb_id};
  if ( $id and exists $all_balloon{$id} and Tk::Exists $all_balloon{$id} ) {
    $cw->configure( -tooltip => '' );
    $all_balloon{$id}->configure( -state => 'none' );
    $all_balloon{$id}->detach($cw);
    $all_balloon{$id}->destroy;
    $all_balloon{$id} = undef;
  }

  return;
}

sub _sets_options {
  my ($cw) = @_;

  #===============================Configuration========================
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-background}         = $cw->cget( -background );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-borderwidth}        = $cw->cget( -borderwidth );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-height}             = $cw->cget( -height );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-relief}             = $cw->cget( -relief );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-state}              = $cw->cget( -state );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-width}              = $cw->cget( -width );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-cursor}             = $cw->cget( -cursor );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-highlightcolor}     = $cw->cget( -highlightcolor );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-highlightthickness} = $cw->cget( -highlightthickness );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-takefocus}          = $cw->cget( -takefocus );

  my $gradient       = $cw->cget( -gradient );
  my $activegradient = $cw->cget( -activegradient );

  if ( defined $gradient ) {
    my $ref = ref $gradient;
    if ( $ref ne 'HASH' ) {
      croak('You have to set a hash reference to -gradient option');
    }
  }
  if ( defined $activegradient ) {
    my $ref = ref $activegradient;
    if ( $ref ne 'HASH' ) {
      croak('You have to set a hash reference to -activegradient option');
    }
  }

  return;
}

sub _create_bouton {
  my ($cw) = @_;

  # clear button
  $cw->_clear_button;

  # configure all options
  $cw->_sets_options;

  # For background gradient color
  my $ref_gradient = $cw->cget( -gradient );
  $cw->set_gradientcolor( %{$ref_gradient} );

  # Create text
  $cw->_text();

  # Create image
  $cw->_image_bitmap();

  # Create tooltip
  $cw->_tooltip();

  # autofit
  my $autofit = $cw->cget( -autofit );
  if ( $autofit and $autofit == 1 ) {
    $cw->_autofit_resize;
  }

  return;
}

sub _clear_button {
  my $cw = shift;

  foreach ( $cw->find('all') ) {
    $cw->delete($_);
  }
  $cw->delete('all');

  return;
}

sub _enter {
  my $cw = shift;

  # mouse over the button
  $config{ $cw->{_cb_id} }{button}{enter} = 1;
  my $press_button = $config{ $cw->{_cb_id} }{button}{press};
  my $state        = $cw->cget( -state );
  my $tag_text     = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{text};
  my $background   = $cw->cget( -background );
  $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-background} = $background;

  return if ( $state eq 'disabled' );

  if ( defined $press_button and $press_button == 1 ) {
    $cw->_press_button;
  }

  # -background
  $cw->configure( -background => $cw->cget( -activebackground ) );

  # -gradient
  $cw->set_gradientcolor( %{ $cw->cget( -activegradient ) } );

  # -overrelief
  if ( my $overrelief = $cw->cget( -overrelief ) ) {
    $cw->configure( -relief => $overrelief );
  }

  # -activeforeground
  if ( my $activeforeground = $cw->cget( -activeforeground ) ) {
    $cw->itemconfigure( $tag_text, -fill => $activeforeground );
  }

  return;
}

sub _focus_in {
  my ($cw) = @_;

  my $borderwidth = $cw->cget( -borderwidth );
  my $focusin_tag = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{focusin};
  my $height      = $cw->cget( -height );
  my $tag_all     = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{all};
  my $width       = $cw->cget( -width );

  my $id_image = $cw->createRectangle(
    $borderwidth + 1, $borderwidth + 1, $width - $borderwidth + 1, $height - $borderwidth + 1,
    -tags => [ $tag_all, $focusin_tag ],
    -dash => $DASH,
  );

  return;
}

sub _focus_out {
  my ($cw) = @_;

  my $focusin_tag = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{focusin};
  if ( $cw->find( 'withtag', $focusin_tag ) ) {
    $cw->delete($focusin_tag);
  }

  return;
}

sub _leave {
  my $cw = shift;

  # mouse not over the button
  $config{ $cw->{_cb_id} }{button}{enter} = 0;

  my $foreground = $cw->cget( -foreground );
  my $state      = $cw->cget( -state );
  my $tag_text   = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{text};
  return if ( $state eq 'disabled' );

  # -background
  $cw->configure( -background => $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-background} );

  # -gradient
  my $gradient = $cw->cget( -gradient );
  $cw->set_gradientcolor( %{$gradient} );

  # -overrelief
  if ( my $overrelief = $cw->cget( -overrelief ) ) {
    $cw->configure( -relief => $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-relief} );
  }

  $cw->itemconfigure( $tag_text, -fill => $foreground );

  my $id_repeatdelay = $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{id_repeatdelay};
  if ( defined $id_repeatdelay ) {
    $id_repeatdelay->cancel;
    $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{id_repeatdelay} = undef;
  }

  # press_leave set by leave button (just relief)
  $cw->_press_leave('leave');

  return;
}

sub _press_button {
  my $cw = shift;

  my $state = $cw->cget( -state );
  return if ( $state eq 'disabled' );

  $cw->configure( -relief => 'sunken' );
  $config{ $cw->{_cb_id} }{button}{press} = 1;

  # -repeatdelay
  if ( my $repeatdelay = $cw->cget( -repeatdelay ) ) {
    my $id_repeatdelay = $cw->repeat(
      $repeatdelay,
      sub {
        if ( !Tk::Exists $cw ) { return; }
        $cw->invoke;
        $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{id_repeatdelay}->cancel;
        $config{ $cw->{_cb_id} }{button}{press_repeatdelay} = 1;

        # -repeatinterval
        if ( my $repeatinterval = $cw->cget( -repeatinterval ) ) {
          $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{id_repeatdelay} = $cw->repeat(
            $repeatinterval,
            sub {
              if ( !Tk::Exists $cw ) { return; }
              $cw->invoke;
            }
          );
        }
      }
    );
    $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{id_repeatdelay} = $id_repeatdelay;
  }

  return;
}

sub _press_leave {
  my ( $cw, $who ) = @_;

  my $state = $cw->cget( -state );
  if ( $state eq 'disabled' ) { return; }

  my $id_repeatdelay    = $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{id_repeatdelay};
  my $press_repeatdelay = $config{ $cw->{_cb_id} }{button}{press_repeatdelay};
  if ( defined $id_repeatdelay ) {
    $id_repeatdelay->cancel;
    $cw->{_conf_cb}{ $cw->{_cb_id} }{ids}{id_repeatdelay} = undef;
  }

  # Execute command
  if ( $config{ $cw->{_cb_id} }{button}{enter} == 1 ) {
    if ( not defined $press_repeatdelay or $press_repeatdelay != 1 ) {
      $cw->_command( $cw->cget( -command ) );
    }
  }

  # if widget is destroyed
  if ( !Tk::Exists $cw ) { return; }

  $config{ $cw->{_cb_id} }{button}{press_repeatdelay} = 0;

  if ( my $overrelief = $cw->cget( -overrelief ) ) {
    $cw->configure( -relief => $overrelief );
  }
  else {
    $cw->configure( -relief => $cw->{_conf_cb}{ $cw->{_cb_id} }{specialbutton}{-relief} );
  }
  if ( not defined $who or $who ne 'leave' ) {
    $config{ $cw->{_cb_id} }{button}{press} = 0;
  }

  return;
}

sub _command {
  my ( $cw, $ref_args ) = @_;

  my $state = $cw->cget( -state );
  if ( $state eq 'disabled' or not defined $ref_args ) { return; }

  my $type_arg = ref $ref_args;

  # no arguments
  if ( $type_arg eq 'CODE' ) {
    $ref_args->();
  }
  elsif ( $type_arg eq 'ARRAY' ) {
    my $command = $ref_args->[0];
    my @args;
    my $i = 0;
    foreach my $argument ( @{$ref_args} ) {
      if ( $i != 0 ) { push @args, $argument; }
      $i++;
    }
    $command->(@args);
  }

  return;
}

sub _delete_text {
  my $cw = shift;

  my $tag = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{text};
  if ( $cw->find( 'withtag', $tag ) ) {
    $cw->delete($tag);
  }

  return;
}

sub _delete_image_bitmap {
  my $cw = shift;

  my $tag_image  = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{image};
  my $tag_bitmap = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{bitmap};

  if ( $cw->find( 'withtag', $tag_image ) ) {
    $cw->delete($tag_image);
  }
  if ( $cw->find( 'withtag', $tag_bitmap ) ) {
    $cw->delete($tag_bitmap);
  }

  return;
}

sub _image_bitmap {
  my $cw = shift;

  my $anchor             = $cw->cget( -anchor );
  my $bitmap             = $cw->cget( -bitmap );
  my $compound           = $cw->cget( -compound );
  my $disabledforeground = $cw->cget( -disabledforeground );
  my $font               = $cw->cget( -font );
  my $foreground         = $cw->cget( -foreground );
  my $image              = $cw->cget( -image );
  my $imagedisabled      = $cw->cget( -imagedisabled );
  my $justify            = $cw->cget( -justify );
  my $wraplength         = $cw->cget( -wraplength );
  my $state              = $cw->cget( -state );
  my $tag_all            = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{all};
  my $tag_image          = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{image};
  my $tag_bitmap         = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{bitmap};
  my $tag_text           = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{text};
  my $text               = $cw->cget( -text );

  if ( $state eq 'disabled' and defined $imagedisabled ) {
    $image = $imagedisabled;
  }

  if ( not defined $image and not defined $bitmap ) {
    return;
  }

  $cw->_delete_text;
  $cw->_delete_image_bitmap;

  my ( $x_text, $y_text, $x_image, $y_image );
  ( $x_image, $y_image ) = $cw->_anchor_position;

  if ( $compound eq 'left'
    or $compound eq 'bottom'
    or $compound eq 'center'
    or $compound eq 'right'
    or $compound eq 'top' )
  {
    ( $x_text, $y_text, $x_image, $y_image ) = $cw->_anchor_position_compound($image);
  }

  if ( defined $image ) {
    my $id_image = $cw->createImage(
      $x_image, $y_image,
      -anchor => $anchor,
      -image  => $image,
      -state  => $state,
      -tags   => [ $tag_all, $tag_image ],
    );
  }
  else {
    my $id_image = $cw->createBitmap(
      $x_image, $y_image,
      -anchor => $anchor,
      -bitmap => $bitmap,
      -state  => $state,
      -tags   => [ $tag_all, $tag_bitmap ],
    );
  }

  if ( defined $x_text and defined $y_text ) {
    $cw->createText(
      $x_text, $y_text,
      -anchor  => $anchor,
      -fill    => $foreground,
      -font    => $font,
      -justify => $justify,
      -tags    => [ $tag_all, $tag_text ],
      -text    => $text,
      -width   => $wraplength,
    );
  }

  if ( $state eq 'disabled' ) {
    $cw->itemconfigure( $tag_text, -fill => $disabledforeground );
  }

  return 1;
}

sub _text {
  my $cw                 = shift;
  my $anchor             = $cw->cget( -anchor );
  my $disabledforeground = $cw->cget( -disabledforeground );
  my $font               = $cw->cget( -font );
  my $foreground         = $cw->cget( -foreground );
  my $justify            = $cw->cget( -justify );
  my $state              = $cw->cget( -state );
  my $tag_all            = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{all};
  my $tag_text           = $cw->{_conf_cb}{ $cw->{_cb_id} }{tags}{text};
  my $text               = $cw->cget( -text );
  my $ref_textvariable   = $cw->cget( -textvariable );
  my $wraplength         = $cw->cget( -wraplength );

  # -textvariable used
  if ( ref $ref_textvariable eq 'SCALAR' ) {
    $text = ${$ref_textvariable};
    $cw->configure( -textvariable => undef );
    $cw->configure( -text         => $text );

    # check modification of textvariable value
    my $id;
    $id = $cw->repeat( $TEXTVARIABLE_INTERVALL, [ \&_check_textvariable, $cw, $ref_textvariable, \$id ] );
  }
  $cw->_delete_text;

  my ( $x_text, $y_text ) = $cw->_anchor_position($anchor);
  $cw->createText(
    $x_text, $y_text,
    -anchor  => $anchor,
    -fill    => $foreground,
    -font    => $font,
    -justify => $justify,
    -tags    => [ $tag_all, $tag_text ],
    -text    => $text,
    -width   => $wraplength,
  );

  if ( $state eq 'disabled' ) {
    $cw->itemconfigure( $tag_text, -fill => $disabledforeground );
  }

  return;
}

sub _check_textvariable {
  my ( $cw, $ref_textvariable, $ref_id ) = @_;
  my $last_text = $cw->cget( -text );
  my $new_text  = ${$ref_textvariable};

  if ( ( defined $last_text and defined $new_text ) and ( $last_text ne $new_text ) ) {
    $cw->configure( -text => $new_text );
    $cw->redraw_button;
  }
  return;
}

sub _autofit_resize {
  my $cw = shift;

  my $image       = $cw->cget( -image );
  my $bitmap      = $cw->cget( -bitmap );
  my $compound    = $cw->cget( -compound );
  my $font        = $cw->cget( -font );
  my $text        = $cw->cget( -text );
  my $width       = $cw->width;
  my $height      = $cw->height;
  my $borderwidth = $cw->cget( -borderwidth );

  my $widthcw  = $cw->width;
  my $heightcw = $cw->height;
  my $padx     = $cw->cget( -padx ) + $SPACE_PLUS;
  my $pady     = $cw->cget( -pady ) + $SPACE_PLUS;

  # Text dimension
  my ( $text_width, $text_height, $image_width, $image_height );
  if ( defined $text ) {
    my $text_temp = $cw->createText(
      0, 0,
      -anchor => 'nw',
      -font   => $font,
      -text   => $text,
    );
    ( undef, undef, $text_width, $text_height ) = $cw->bbox($text_temp);
    $cw->delete($text_temp);
  }
  if ( defined $image ) {
    $image_width  = $image->width;
    $image_height = $image->height;
  }
  elsif ( defined $bitmap ) {
    my $bitmap_temp = $cw->createBitmap( 0, 0, '-bitmap' => $bitmap, -anchor => 'nw' );
    ( undef, undef, $image_width, $image_height ) = $cw->bbox($bitmap_temp);
    $cw->delete($bitmap_temp);
  }

  # autofit : Dimension, button
  my ( $total_width, $total_height ) = ( 0, 0 );

  # image/bitmap and compound
  if (
    ( defined $image or defined $bitmap )
    and (
      defined $compound
      and ($compound eq 'left'
        or $compound eq 'right'
        or $compound eq 'center'
        or $compound eq 'bottom'
        or $compound eq 'top' )
    )
    )
  {

    if ( $compound eq 'left' or $compound eq 'right' ) {
      $width = $image_width + $text_width + ( 2 * $padx );
      $height = _maxarray( [ $image_height, $text_height ] ) + ( 2 * $pady );
    }
    elsif ( $compound eq 'bottom' or $compound eq 'top' ) {
      $width = _maxarray( [ $image_width, $text_width ] ) + ( 2 * $padx );
      $height = $image_height + $text_height + ( 2 * $pady );
    }
    elsif ( $compound eq 'center' ) {
      $width  = _maxarray( [ $image_width,  $text_width ] ) +  ( 2 * $padx );
      $height = _maxarray( [ $image_height, $text_height ] ) + ( 2 * $pady );
    }
  }

  # image/bitmap replace text
  elsif ( defined $image or defined $bitmap ) {
    $width  = $image->width +  ( 2 * $padx );
    $height = $image->height + ( 2 * $pady );
  }

  # just text
  elsif ( defined $text ) {
    $width  = $text_width +  ( 2 * $padx );
    $height = $text_height + ( 2 * $pady );
  }

  if ( $widthcw != $width or $heightcw != $height ) {
    $cw->configure( -width => $width, -height => $height );
  }

  return;
}

sub _anchor_position {
  my $cw = shift;

  my $anchor      = $cw->cget( -anchor );
  my $width       = $cw->width;
  my $height      = $cw->height;
  my $borderwidth = $cw->cget( -borderwidth );
  my $padx        = $cw->cget( -padx );
  my $pady        = $cw->cget( -pady );

  my %xy_anchor_position = (
    n => {
      x => $width / 2,
      y => ( 2 * $pady ) + ( 2 * $borderwidth ),
    },
    nw => {
      x => ( 2 * $padx ) + ( 2 * $borderwidth ),
      y => ( 2 * $pady ) + ( 2 * $borderwidth ),
    },
    ne => {
      x => $width - ( 2 * $padx ) - ( 2 * $borderwidth ),
      y => ( 2 * $pady ) + ( 2 * $borderwidth ),
    },
    s => {
      x => $width / 2,
      y => $height - ( 2 * $pady ) - ( 2 * $borderwidth ),
    },
    sw => {
      x => ( 2 * $padx ) + ( 2 * $borderwidth ),
      y => $height - ( 2 * $pady ) - ( 2 * $borderwidth ),
    },
    se => {
      x => $width -  ( 2 * $padx ) - ( 2 * $borderwidth ),
      y => $height - ( 2 * $pady ) - ( 2 * $borderwidth ),
    },
    center => {
      x => $width / 2,
      y => $height / 2,
    },
    w => {
      x => ( 2 * $padx ) + ( 2 * $borderwidth ),
      y => $height / 2,
    },
    e => {
      x => $width - ( 2 * $padx ) - ( 2 * $borderwidth ),
      y => $height / 2,
    },
  );

  return ( $xy_anchor_position{$anchor}{x}, $xy_anchor_position{$anchor}{y} );
}

sub _anchor_position_compound {
  my ( $cw, $image ) = @_;

  my $anchor      = $cw->cget( -anchor );
  my $bitmap      = $cw->cget( -bitmap );
  my $compound    = $cw->cget( -compound );
  my $font        = $cw->cget( -font );
  my $text        = $cw->cget( -text );
  my $width       = $cw->width;
  my $height      = $cw->height;
  my $borderwidth = $cw->cget( -borderwidth );
  my $padx        = $cw->cget( -padx );
  my $pady        = $cw->cget( -pady );

  my ( $x_text, $y_text, $x_image, $y_image );
  ( $x_text, $y_text ) = $cw->_anchor_position;
  $x_image = $x_text;
  $y_image = $y_text;

  # Image dimension
  my ( $image_width, $image_height ) = ();
  if ( defined $image ) {
    $image_width  = $image->width;
    $image_height = $image->height;
  }
  elsif ( defined $bitmap ) {
    my $bitmap_temp = $cw->createBitmap( 0, 0, '-bitmap' => $bitmap, -anchor => 'nw' );
    ( undef, undef, $image_width, $image_height ) = $cw->bbox($bitmap_temp);
    $cw->delete($bitmap_temp);
  }

  # no image or bitmap defined
  else {
    return ( $x_text, $y_text, $x_image, $y_image );
  }

  # Text dimension
  my $text_temp = $cw->createText(
    0, 0,
    -anchor => 'nw',
    -font   => $font,
    -text   => $text,
  );
  my ( undef, undef, $text_width, $text_height ) = $cw->bbox($text_temp);
  $cw->delete($text_temp);

  my $diff_width  = $text_width - $image_width;
  my $diff_height = $text_height - $image_height;

  # Compound
  my %xy_anchor_position;
  foreach my $compound_pos (qw/ left right center top bottom /) {
    foreach my $anchor_pos (qw/ n ne nw s sw se center e w /) {
      $xy_anchor_position{$compound_pos}{$anchor_pos}{x_text}  = $x_text;
      $xy_anchor_position{$compound_pos}{$anchor_pos}{y_text}  = $y_text;
      $xy_anchor_position{$compound_pos}{$anchor_pos}{x_image} = $x_image;
      $xy_anchor_position{$compound_pos}{$anchor_pos}{y_image} = $y_image;
    }
  }

  # x
  foreach (qw / nw w sw /) {
    $xy_anchor_position{left}{$_}{x_text}   += $image_width;
    $xy_anchor_position{right}{$_}{x_image} += $text_width;
    if ( $diff_width > 0 ) {
      $xy_anchor_position{center}{$_}{x_image} += ( $diff_width / 2 );
      $xy_anchor_position{bottom}{$_}{x_image} += ( $text_width - $image_width ) / 2;
      $xy_anchor_position{top}{$_}{x_image}    += ($diff_width) / 2;
    }
    else {
      $xy_anchor_position{center}{$_}{x_text} -= ( $diff_width / 2 );
      $xy_anchor_position{bottom}{$_}{x_text} += -($diff_width) / 2;
      $xy_anchor_position{top}{$_}{x_text} -= ($diff_width) / 2;
    }
  }
  foreach (qw / n center s /) {
    $xy_anchor_position{left}{$_}{x_text} += ( $image_width / 2 );
    $xy_anchor_position{left}{$_}{x_image}
      = ( $xy_anchor_position{left}{$_}{x_text} - ( $text_width / 2 ) - ( $image_width / 2 ) );
    $xy_anchor_position{right}{$_}{x_text} -= ( $image_width / 2 );
    $xy_anchor_position{right}{$_}{x_image} += ( $text_width / 2 );
  }
  foreach (qw / ne e se /) {
    $xy_anchor_position{left}{$_}{x_image} -= $text_width;
    $xy_anchor_position{right}{$_}{x_text} -= $image_width;
    if ( $diff_width > 0 ) {
      $xy_anchor_position{center}{$_}{x_image} -= ( $diff_width / 2 );
      $xy_anchor_position{bottom}{$_}{x_image} -= ( $text_width - $image_width ) / 2;
      $xy_anchor_position{top}{$_}{x_image}    -= ($diff_width) / 2;
    }
    else {
      $xy_anchor_position{center}{$_}{x_text} += ( $diff_width / 2 );
      $xy_anchor_position{bottom}{$_}{x_text} -= -($diff_width) / 2;
      $xy_anchor_position{top}{$_}{x_text} += ($diff_width) / 2;
    }
  }

  # y
  foreach (qw / nw n ne /) {
    if ( $diff_height > 0 ) {
      $xy_anchor_position{left}{$_}{y_image}   += ( $diff_height / 2 );
      $xy_anchor_position{right}{$_}{y_image}  += ( $diff_height / 2 );
      $xy_anchor_position{center}{$_}{y_image} += ( $diff_height / 2 );
    }
    else {
      $xy_anchor_position{left}{$_}{y_text}   -= ( $diff_height / 2 );
      $xy_anchor_position{right}{$_}{y_text}  -= ( $diff_height / 2 );
      $xy_anchor_position{center}{$_}{y_text} -= ( $diff_height / 2 );
    }
    $xy_anchor_position{bottom}{$_}{y_image} += $text_height;
    $xy_anchor_position{top}{$_}{y_text}     += $image_height;
  }
  foreach (qw / sw s se /) {
    if ( $diff_height > 0 ) {
      $xy_anchor_position{left}{$_}{y_image}   -= ( $diff_height / 2 );
      $xy_anchor_position{right}{$_}{y_image}  -= ( $diff_height / 2 );
      $xy_anchor_position{center}{$_}{y_image} -= ( $diff_height / 2 );
    }
    else {
      $xy_anchor_position{left}{$_}{y_text}   += ( $diff_height / 2 );
      $xy_anchor_position{right}{$_}{y_text}  += ( $diff_height / 2 );
      $xy_anchor_position{center}{$_}{y_text} += ( $diff_height / 2 );
    }
    $xy_anchor_position{bottom}{$_}{y_image} = $height - ( 2 * $pady ) - ( 2 * $borderwidth );
    $xy_anchor_position{bottom}{$_}{y_text} -= $image_height;
    $xy_anchor_position{top}{$_}{y_image} = $xy_anchor_position{top}{$_}{y_text} - $text_height;
  }
  foreach (qw / w center e /) {
    $xy_anchor_position{bottom}{$_}{y_text} -= $text_height / 2;
    $xy_anchor_position{bottom}{$_}{y_image} += $image_height / 2;
    $xy_anchor_position{top}{$_}{y_text}     += $text_height / 2;
    $xy_anchor_position{top}{$_}{y_image} -= $image_height / 2;
  }

  foreach my $anchor_pos (qw/ n ne nw s sw se center e w /) {
    $xy_anchor_position{left}{$anchor_pos}{x_text}   += $SPACE_PLUS;
    $xy_anchor_position{right}{$anchor_pos}{x_image} += $SPACE_PLUS;
  }

  my @xy_text
    = ( $xy_anchor_position{$compound}{$anchor}{x_text}, $xy_anchor_position{$compound}{$anchor}{y_text} );
  my @xy_image
    = ( $xy_anchor_position{$compound}{$anchor}{x_image}, $xy_anchor_position{$compound}{$anchor}{y_image} );

  return ( @xy_text, @xy_image );
}

sub _tooltip {
  my $cw = shift;

  my $state = $cw->cget( -state );

  #if ( $state eq 'disabled' ) { return; }

  my $tooltip_balloon = $cw->cget( -tooltip );
  my $id              = $cw->{_cb_id};
  my $initwait        = $INITWAIT;
  my $tooltip;

  if ( ref $tooltip_balloon eq 'ARRAY' and $tooltip_balloon->[1] ) {
    $tooltip  = $tooltip_balloon->[0];
    $initwait = $tooltip_balloon->[1];
  }
  else {
    $tooltip = $tooltip_balloon;
  }

  if ( defined $tooltip ) {
    if ( exists $all_balloon{$id} and Tk::Exists $all_balloon{$id} ) {
      $all_balloon{$id}->configure( -state => 'none' );
      $all_balloon{$id}->detach($cw);
      $all_balloon{$id} = undef;
    }

    $all_balloon{$id} = $cw->Balloon( -background => 'white', );
    $all_balloon{$id}->attach(
      $cw,
      -balloonposition => 'mouse',
      -msg             => $tooltip,
      -initwait        => $initwait,
    );
  }

  return;
}

sub _maxarray {
  my ($ref_umber) = @_;
  my $max;

  for my $chiffre ( @{$ref_umber} ) {
    $max = _max( $max, $chiffre );
  }

  return $max;
}

sub _max {
  my ( $a, $b ) = @_;
  if ( not defined $a ) { return $b; }
  if ( not defined $b ) { return $a; }
  if ( not defined $a and not defined $b ) { return; }

  if   ( $a >= $b ) { return $a; }
  else              { return $b; }

  return;
}

1;

__END__