view release on metacpan or  search on metacpan

Tk/Menu.pm  view on Meta::CPAN

# Converted from menu.tcl --
#
# This file defines the default bindings for Tk menus and menubuttons.
# It also implements keyboard traversal of menus and implements a few
# other utility procedures related to menus.
#
# @(#) menu.tcl 1.34 94/12/19 17:09:09
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package Tk::Menu;
require Tk;
require Tk::Widget;
require Tk::Wm;
require Tk::Derived;
require Tk::Menu::Item;


use vars qw($VERSION);
$VERSION = '4.023'; # was: sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/;

use strict;

use base  qw(Tk::Wm Tk::Derived Tk::Widget);

Construct Tk::Widget 'Menu';

sub Tk_cmd { \&Tk::_menu }

Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure',
            'index','insert','invoke','post','postcascade','type',
            'unpost','yposition');

import Tk qw(Ev);

sub CreateArgs
{
 my ($package,$parent,$args) = @_;
 # Remove from hash %$args any configure-like
 # options which only apply at create time (e.g. -class for Frame)
 # return these as a list of -key => value pairs
 my @result = ();
 my $opt;
 foreach $opt (qw(-type -screen -visual -colormap))
  {
   my $val = delete $args->{$opt};
   push(@result, $opt => $val) if (defined $val);
  }
 return @result;
}

sub InitObject
{
 my ($menu,$args) = @_;
 my $menuitems = delete $args->{-menuitems};
 $menu->SUPER::InitObject($args);
 $menu->ConfigSpecs(-foreground => ['SELF']);
 if (defined $menuitems)
  {
   # If any other args do configure now
   if (%$args)
    {
     $menu->configure(%$args);
     %$args = ();
    }
   $menu->AddItems(@$menuitems)
  }
}

sub AddItems
{
 my $menu = shift;
 ITEM:
 while (@_)
  {
   my $item = shift;
   if (!ref($item))
    {
     $menu->separator;  # A separator
    }
   else
    {
     my ($kind,$name,%minfo) = ( @$item );
     my $invoke = delete $minfo{'-invoke'};