view release on metacpan or  search on metacpan

Tk/Derived.pm  view on Meta::CPAN

# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Tk::Derived;
require Tk::Widget;
require Tk::Configure;
use strict;
use Carp;

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

$Tk::Derived::Debug = 0;

my $ENHANCED_CONFIGSPECS = 0; # disable for now

use Tk qw(NORMAL_BG BLACK);

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)
  {