view release on metacpan or  search on metacpan

lib/Tcl/pTk/Derived.pm  view on Meta::CPAN

#
# Megawidget support for Tcl::pTk

package Tcl::pTk::Derived;

our ($VERSION) = ('1.11');

use Carp;

use Tcl::pTk::Configure;

use strict;

my $ENHANCED_CONFIGSPECS = 0; # disable for now

#################### Methods Originally in Tk::Derived #################
sub Subwidget
{
 my $cw = shift;
 my @result = ();
 if (exists $cw->{SubWidget})
  {
   if (@_)
    {
     foreach my $name (@_)
      {
       push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name});
      }
    }
   else
    {
     @result = values %{$cw->{SubWidget}};
    }
  }
 return (wantarray) ? @result : $result[0];
}

sub _makelist
{
 my $widget = shift;
 my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ? (@$widget) : ($widget);
 return @specs;
}

sub Subconfigure
{
 # This finds the widget or widgets to to which to apply a particular
 # configure option
 my ($cw,$opt) = @_;
 my $config = $cw->ConfigSpecs;
 my $widget;
 my @subwidget = ();
 my @arg = ();
 if (defined $opt)
  {
   $widget = $config->{$opt};
   unless (defined $widget)
    {
     $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt};
    }
   # Handle alias entries
   if (defined($widget) && !ref($widget))
    {
     $opt    = $widget;
     $widget = $config->{$widget};
    }
   push(@arg,$opt) unless ($opt eq 'DEFAULT');
  }
 $widget = $config->{DEFAULT} unless (defined $widget);
 if (defined $widget)
  {
   $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY'));
   $widget = $widget->[0];
  }
 else
  {