#!/usr/bin/perl
use warnings;
use strict;
use Tk;


package Tk::MyMenuButton;
use strict;
require Tk;
require Tk::Menubutton;
use Tk::Derived;
use base qw/Tk::Derived Tk::Menubutton/;
Construct Tk::Widget 'MyMenuButton';

import Tk qw(&Ev $XS_VERSION);

sub InitObject
{
 my ($mb,$args) = @_;
 my $menuitems = delete $args->{-menuitems};
 my $tearoff   = delete $args->{-tearoff};
 $mb->SUPER::InitObject($args);
 if ((defined($menuitems) || defined($tearoff)) && %$args)
  {
   $mb->configure(%$args);
   %$args = ();
  }
 $mb->menu(-tearoff => $tearoff) if (defined $tearoff);
 $mb->AddItems(@$menuitems) if (defined $menuitems)
}

sub ClassInit
{
 my ($class,$mw) = @_;
 $mw->bind($class,'<FocusIn>','NoOp');
 $mw->bind($class,'<Enter>','Enter');
 $mw->bind($class,'<Leave>','Leave');
 $mw->bind($class,'<1>','ButtonDown');
 $mw->bind($class,'<Motion>',['Motion','up',Ev('X'),Ev('Y')]);
 $mw->bind($class,'<B1-Motion>',['Motion','down',Ev('X'),Ev('Y')]);
 $mw->bind($class,'<ButtonRelease-1>','ButtonUp');
 $mw->bind($class,'<space>','PostFirst');
 $mw->bind($class,'<Return>','PostFirst');
 return $class;
}

sub ButtonDown
{my $w = shift;
 my $Ev = $w->XEvent;
 $Tk::inMenubutton->Post($Ev->X,$Ev->Y) if (defined $Tk::inMenubutton);
}

sub PostFirst
{
 my $w = shift;
 my $menu = $w->cget('-menu');
 $w->Post();
 $menu->FirstEntry() if (defined $menu);
}

sub Enter
{
 my $w = shift;
 $Tk::inMenubutton->Leave if (defined $Tk::inMenubutton);
 $Tk::inMenubutton = $w;
 if ($w->cget('-state') ne 'disabled')
  {
   $w->configure('-state','active')
  }
}

sub Leave
{
 my $w = shift;
 $Tk::inMenubutton = undef;
 return unless Tk::Exists($w);
 if ($w->cget('-state') eq 'active')
  {
   $w->configure('-state','normal')
  }
}

sub Post
{
 my $w = shift;
 my $x = shift;
 my $y = shift;
 return if ($w->cget('-state') eq 'disabled');
 return if (defined $Tk::postedMb && $w == $Tk::postedMb);
 my $menu = $w->cget('-menu');
 return unless (defined($menu) && $menu->index('last') ne 'none');

 my $tearoff = $Tk::platform eq 'unix' || $menu->cget('-type') eq 'tearoff';

 my $wpath = $w->PathName;
 my $mpath = $menu->PathName;
 unless (index($mpath,"$wpath.") == 0)
  {
   die "Cannot post $mpath : not a descendant of $wpath";
  }

 my $cur = $Tk::postedMb;
 if (defined $cur)
  {
   Tk::Menu->Unpost(undef); # fixme
  }
 $Tk::cursor = $w->cget('-cursor');
 $Tk::relief = $w->cget('-relief');

# $w->configure('-cursor','arrow');
  $w->configure('-cursor','pencil');
 
 $w->configure('-relief','raised');
 $Tk::postedMb = $w;
 $Tk::focus = $w->focusCurrent;
 $menu->activate('none');
 $menu->GenerateMenuSelect;
 # If this looks like an option menubutton then post the menu so
 # that the current entry is on top of the mouse. Otherwise post
 # the menu just below the menubutton, as for a pull-down.

 eval
  {local $SIG{'__DIE__'};
   my $dir = $w->cget('-direction');
   if ($dir eq 'above')
    {
     $menu->post($w->rootx, $w->rooty - $menu->ReqHeight);
    }
   elsif ($dir eq 'below')
    {
     $menu->post($w->rootx, $w->rooty + $w->Height);
    }
   elsif ($dir eq 'left')
    {
     my $x = $w->rootx - $menu->ReqWidth;
     my $y = int((2*$w->rooty + $w->Height) / 2);
     if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
      {
       $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
      }
     else
      {
       $menu->post($x,$y);
      }
    }
   elsif ($dir eq 'right')
    {
     my $x = $w->rootx + $w->Width;
     my $y = int((2*$w->rooty + $w->Height) / 2);
     if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
      {
       $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
      }
     else
      {
       $menu->post($x,$y);
      }
    }
   else
    {
     if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable')))
      {
       if (!defined($y))
        {
         $x = $w->rootx+$w->width/2;
         $y = $w->rooty+$w->height/2
        }
       $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
      }
     else
      {
       $menu->post($w->rootx,$w->rooty+$w->height);
      }
    }
  };
 if ($@)
  {
   Tk::Menu->Unpost;
   die $@
  }

 $Tk::tearoff = $tearoff;
 if ($tearoff)
  {
   $menu->focus;
   if ($w->viewable)
    {
     $w->SaveGrabInfo;
     $w->grabGlobal;
    }
  }
}

sub Motion
{
 my $w = shift;
 my $upDown = shift;
 my $rootx = shift;
 my $rooty = shift;
 return if (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w);
 my $new = $w->Containing($rootx,$rooty);
 if (defined($Tk::inMenubutton))
  {
   if (!defined($new) || ($new != $Tk::inMenubutton && $w->toplevel != $new->toplevel))
    {
     $Tk::inMenubutton->Leave();
    }
  }
 if (defined($new) && $new->IsMenubutton && $new->cget('-indicatoron') == 0 &&
     $w->cget('-indicatoron') == 0)
  {
   if ($upDown eq 'down')
    {
     $new->Post($rootx,$rooty);
    }
   else
    {
     $new->Enter();
    }
  }
}


sub ButtonUp {
    my $w = shift;

    my $tearoff = $Tk::platform eq 'unix' || (defined($w->cget('-menu')) &&
					      $w->cget('-menu')->cget('-type') eq 'tearoff');
    if ($tearoff && (defined($Tk::postedMb)     && $Tk::postedMb == $w)
	         && (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w)) {
	$Tk::postedMb->cget(-menu)->FirstEntry();
    } else {
      Tk::Menu->Unpost(undef);
    }
} # end ButtonUp

# Some convenience methods

sub menu
{
 my ($w,%args) = @_;
 my $menu = $w->cget('-menu');
 if (!defined $menu)
  {
   require Tk::Menu;
   $w->ColorOptions(\%args) if ($Tk::platform eq 'unix');
   $menu = $w->Menu(%args);
   $w->configure('-menu'=>$menu);
  }
 else
  {
   $menu->configure(%args);
  }
 return $menu;
}

sub separator   { require Tk::Menu::Item; shift->menu->Separator(@_);   }
sub command     { require Tk::Menu::Item; shift->menu->Command(@_);     }
sub cascade     { require Tk::Menu::Item; shift->menu->Cascade(@_);     }
sub checkbutton { require Tk::Menu::Item; shift->menu->Checkbutton(@_); }
sub radiobutton { require Tk::Menu::Item; shift->menu->Radiobutton(@_); }

sub AddItems
{
 shift->menu->AddItems(@_);
}

sub entryconfigure
{
 shift->menu->entryconfigure(@_);
}

sub entrycget
{
 shift->menu->entrycget(@_);
}

sub FindMenu
{
 my $child = shift;
 my $char = shift;
 my $ul = $child->cget('-underline');
 if (defined $ul && $ul >= 0 && $child->cget('-state') ne 'disabled')
  {
   my $char2 = $child->cget('-text');
   $char2 = substr("\L$char2",$ul,1) if (defined $char2);
   if (!defined($char) || $char eq '' || (defined($char2) && "\l$char" eq $char2))
    {
     $child->PostFirst;
     return $child;
    }
  }
 return undef;
}

1;


package main;

my $mw = MainWindow->new;
$mw->geometry( "300x150" );
$mw->title( "Menubutton Test" );

my $main_menu = $mw->Menu();
$mw->configure( -menu => $main_menu );

# won't work from $main_menu
#my $btn = $main_menu->MyMenuButton(
my $btn = $mw->MyMenuButton(
   -text      => "Colorful Buttons...",
   -underline => 0,
   -tearoff   => 0,
)->pack();

$btn->command(
   -label            => "Button #1",
   -activebackground => "blue",
   -foreground       => "blue",
   -command => sub { $mw->messageBox( -message => "Button #1 Pressed" ) }
);

$btn->command(
   -label            => "Button #2",
   -activebackground => "red",
   -activeforeground => "black",
   -background       => "yellow",
   -foreground       => "green",
   -command => sub { $mw->messageBox( -message => "Button #2 Pressed" ) }
);

$btn->command( -label => "Exit", -command => sub { exit } );

MainLoop;