Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / Menu / Item.pm

package Tk::Menu::Item;

require Tk::Menu;

use Carp;
use strict;

use vars qw($VERSION);
$VERSION = '3.027'; # $Id: //depot/Tk8/Tk/Menu/Item.pm#27 $

sub PreInit
{
# Dummy (virtual) method
my ($class,$menu,$minfo) = @_;
}

sub new
{
my ($class,$menu,%minfo) = @_;
my $kind = $class->kind;
my $name = $minfo{'-label'};
if (defined $kind)
 {
  my $invoke = delete $minfo{'-invoke'};
  if (defined $name)
   {
    # Use ~ in name/label to set -underline
    if (defined($minfo{-label}) && !defined($minfo{-underline}))
     {
      my $cleanlabel = $minfo{-label};
      my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef;
      if (defined($underline) && ($underline >= 0))
       {
        $minfo{-underline} = $underline;
        $name = $cleanlabel if ($minfo{-label} eq $name);
        $minfo{-label} = $cleanlabel;
       }
     }
   }
  else
   {
    $name = $minfo{'-bitmap'} || $minfo{'-image'};
    croak('No -label') unless defined($name);
    $minfo{'-label'} = $name;
   }
  $class->PreInit($menu,\%minfo);
  $menu->add($kind,%minfo);
  $menu->invoke('last') if ($invoke);
 }
else
 {
  $menu->add('separator');
 }
return bless [$menu,$name],$class;
}

sub configure
{
my $obj = shift;
my ($menu,$name) = @$obj;
my %args = @_;
$obj->[1] = $args{'-label'} if exists $args{'-label'};
$menu->entryconfigure($name,@_);
}

sub cget
{
my $obj = shift;
my ($menu,$name) = @$obj;
$menu->entrycget($name,@_);
}

sub parentMenu
{
my $obj = shift;
return $obj->[0];
}

# Default "kind" is a command
sub kind { return 'command' }

# Now the derived packages

package Tk::Menu::Separator;
use base qw(Tk::Menu::Item);
Construct Tk::Menu 'Separator';
sub kind { return undef }

package Tk::Menu::Button;
use base qw(Tk::Menu::Item);
Construct Tk::Menu 'Button';
Construct Tk::Menu 'Command';

#package Tk::Menu::Command;
#use base qw(Tk::Menu::Button);
#Construct Tk::Menu 'Command';

package Tk::Menu::Cascade;
use base qw(Tk::Menu::Item);
Construct Tk::Menu 'Cascade';
sub kind { return 'cascade' }
use Carp;

sub PreInit
{
my ($class,$menu,$minfo) = @_;
my $tearoff   = delete $minfo->{-tearoff};
my $items     = delete $minfo->{-menuitems};
my $widgetvar = delete $minfo->{-menuvar};
my $command   = delete $minfo->{-postcommand};
my $name = delete $minfo->{'Name'};
$name = $minfo->{'-label'} unless defined $name;
my @args = ();
push(@args, '-tearoff' => $tearoff) if (defined $tearoff);
push(@args, '-menuitems' => $items) if (defined $items);
push(@args, '-postcommand' => $command) if (defined $command);
my $submenu = $minfo->{'-menu'};
unless (defined $submenu)
 {
  $minfo->{'-menu'} = $submenu = $menu->Menu(Name => $name, @args);
 }
$$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar));
}

sub menu
{
my ($self,%args) = @_;
my $w = $self->parentMenu;
my $menu = $self->cget('-menu');
if (!defined $menu)
 {
  require Tk::Menu;
  $w->ColorOptions(\%args);
  my $name = $self->cget('-label');
  warn "Had to (re-)reate menu for $name";
  $menu = $w->Menu(Name => $name, %args);
  $self->configure('-menu'=>$menu);
 }
else
 {
  $menu->configure(%args) if %args;
 }
return $menu;
}

# Some convenience methods

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

sub pack
{
my $w = shift;
if ($^W)
 {
  require Carp;
  Carp::carp("Cannot 'pack' $w - done automatically")
 }
}

package Tk::Menu::Checkbutton;
use base qw(Tk::Menu::Item);
Construct Tk::Menu 'Checkbutton';
sub kind { return 'checkbutton' }

package Tk::Menu::Radiobutton;
use base qw(Tk::Menu::Item);
Construct Tk::Menu 'Radiobutton';
sub kind { return 'radiobutton' }

package Tk::Menu::Item;

1;
__END__

=cut