view release on metacpan or  search on metacpan

Tk/Menu.pm  view on Meta::CPAN

 $args{'-label'} = $name if (defined $name);
 my $items = delete $args{'-menuitems'};
 foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill))
  {
   delete $args{$opt};
  }
 if (defined($name) && !defined($args{-underline}))
  {
   my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef;
   if (defined($underline) && ($underline >= 0))
    {
     $args{-underline} = $underline;
     $args{-label} = $name;
    }
  }
 my $hash = $menu->TkHash('MenuButtons');
 my $mb = $hash->{$name};
 if (defined $mb)
  {
   delete $args{'-tearoff'}; # too late!
   $mb->configure(%args) if %args;
  }
 else
  {
   $mb = $menu->cascade(%args);
   $hash->{$name} = $mb;
  }
 $mb->menu->AddItems(@$items) if defined($items) && @$items;
 return $mb;
}

sub BalloonInfo
{
 my ($menu,$balloon,$X,$Y,@opt) = @_;
 my $i = $menu->index('active');
 if ($i eq 'none')
  {
   my $y = $Y - $menu->rooty;
   $i = $menu->index("\@$y");
  }
 foreach my $opt (@opt)
  {
   my $info = $balloon->GetOption($opt,$menu);
   if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
    {
     $balloon->Subclient($i);
     return '' if $i eq 'none';
     return ${$info}[$i] || '';
    }
   return $info;
  }
}

sub MasterMenu
{
 my ($menu) = @_;
 my $pathname = $menu->PathName;
 my $master_menu;
 if ($pathname =~ m{#})
  {
   my $master_pathname = (split m{\.}, $pathname)[-1];
   $master_pathname =~ s{#}{.}g;
   $master_menu = $menu->Widget($master_pathname);
   if (0 && !Tk::Exists($master_menu))
    {
     warn "Cannot find master menu <$master_pathname>";
    }
  }
 $master_menu;
}


# ::tk::AmpMenuArgs --
# Processes arguments for a menu entry, turning -label option into
# -label and -underline options, returned by ::tk::UnderlineAmpersand.
#
sub AmpArgs
{
 my ($w, $add, $type, %args) = @_;
 my @options;
 while(my($opt,$val) = each %args)
  {
   if ($opt eq "-label")
    {
     my ($newtext,$under) = $w->UnderlineAmpersand($val);
     push @options, -label => $newtext, -underline => $under;
    }
   else
    {
     push @options, $opt, $val;
    }
  }
 $w->$type(@options);
}

1;

__END__