in reply to Re^4: Perl::Tk and cursor in Menubutton
in thread Perl::Tk and cursor in Menubutton

I must apologize a bit to you. The preferred way to modify a module, for your own use, is to use a Derived widget. But as I experimented with making a Derived Menubutton widget, many unexpected behaviors popped up. I finally resorted to trying a local Tk directory containing a copy of Menubutton.pm . Then even with 
use strict;
use lib '.';
BEGIN{ unshift  @INC, '.';}
use Tk;
print "@INC\n";
.....

[download]
It would find the system installed module, instead of my copy.

I did manage to get a package MyMenuButton to load error free, but the menubutton would not appear in the $mw->menu for some reason.

Here is as far as I care to take it. It works as a package, as long as you place the Derived MenuButton in the $mw, instead of the $mw->menu(). I do not know why it won't work from the menu. I changed the cursor to a pencil.

So this would be perfectly acceptable as far as license and distribution goes. You can do some more cursor modifications in the Enter and Leave subs if you desire. 

#!/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 'tea
+roff';

 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('-textvaria
+ble')))
      {
       $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('-textvaria
+ble')))
      {
       $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text')))
      }
     else
      {
       $menu->post($x,$y);
      }
    }
   else
    {
     if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvaria
+ble')))
      {
       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;

[download]
I'm not really a human, but I play one on earth.
Old Perl Programmer Haiku ................... flash japh

Replies are listed 'Best First'.
Hurrah!!! You are BIG!
by Khariton (Sexton) on Oct 21, 2010 at 19:37 UTC
    Yes!
    This is great!
    Thank you very much for your work...
    This is will be very usefull for me in for this task and may be help me with another module...

    I writing Drag-N-Drop Genealogy Editor.
    Родовід(Descent)
    At monday (I mean) I post new version with html reporting as descent site(www.mishchenko.tk example).
    But code in this software very wet and stupid at now.
    Now I create functionality and when I create it I must begin optimise code for better and better...
[reply]
      I insert code in my program and all work fine.
      But I must add option -highlightbackground to each MeMenuButton because if I use option -state='active' in default mode will set wrong very light gray color.
      Big thanks for you support for me...
[reply]

In Section Seekers of Perl Wisdom