# Copyright (c) 1995-1999 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.
$VERSION = '3.046'; # $Id: //depot/Tk8/Tk/Derived.pm#46 $
my $ENHANCED_CONFIGSPECS = 0; # disable for now
use Tk qw(NORMAL_BG BLACK);
if (exists $cw->{SubWidget
})
push(@result,$cw->{SubWidget
}{$name}) if (exists $cw->{SubWidget
}{$name});
@result = values %{$cw->{SubWidget
}};
return (wantarray) ?
@result : $result[0];
my (@specs) = (ref $widget && ref $widget eq 'ARRAY') ?
(@
$widget) : ($widget);
# This finds the widget or widgets to to which to apply a particular
my $config = $cw->ConfigSpecs;
$widget = $config->{$opt};
$widget = ($opt =~ /^-(.*)$/) ?
$config->{$1} : $config->{-$opt};
if (defined($widget) && !ref($widget))
$widget = $config->{$widget};
push(@arg,$opt) unless ($opt eq 'DEFAULT');
$widget = $config->{DEFAULT
} unless (defined $widget);
$cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq 'ARRAY'));
foreach $widget (_makelist
($widget))
$widget = 'SELF' if (ref($widget) && $widget == $cw);
$widget = Tk
::Configure
->new(@
$widget);
foreach my $key (%$widget)
foreach my $sw (_makelist
($widget->{$key}))
push(@subwidget,Tk
::Configure
->new($sw,$key));
elsif ($widget eq 'ADVERTISED')
push(@subwidget,$cw->Subwidget)
elsif ($widget eq 'DESCENDANTS')
push(@subwidget,$cw->Descendants)
elsif ($widget eq 'CHILDREN')
push(@subwidget,$cw->children)
elsif ($widget eq 'METHOD')
my ($method) = ($opt =~ /^-?(.*)$/);
push(@subwidget,Tk
::Configure
->new($method,$method,$cw))
elsif ($widget eq 'SETMETHOD')
my ($method) = ($opt =~ /^-?(.*)$/);
push(@subwidget,Tk
::Configure
->new($method,'_cget',$cw,@arg))
elsif ($widget eq 'SELF')
push(@subwidget,Tk
::Configure
->new('Tk::configure', 'Tk::cget', $cw,@arg))
elsif ($widget eq 'PASSIVE')
push(@subwidget,Tk
::Configure
->new('_configure','_cget',$cw,@arg))
elsif ($widget eq 'CALLBACK')
push(@subwidget,Tk
::Configure
->new('_callback','_cget',$cw,@arg))
push(@subwidget,$cw->Subwidget($widget));
$cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget);
return (wantarray) ?
@subwidget : $subwidget[0];
$cw->BackTrace('Wrong number of args to cget') unless (@_ == 2);
return $cw->{Configure
}{$opt}
$cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
$cw->{Configure
}{$opt} = $val;
$cw->BackTrace('Wrong number of args to configure') unless (@_ == 3);
$val = Tk
::Callback
->new($val) if defined($val) && ref($val);
$cw->{Configure
}{$opt} = $val;
foreach my $sw ($cw->Subconfigure($opt))
eval { @result = $sw->cget($opt) };
eval { $result[0] = $sw->cget($opt) };
return wantarray ?
@result : $result[0];
# Called whenever a derived widget is re-configured
my ($cw,$args,$changed) = @_;
$cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed);
return exists $cw->{'Configure'};
# The default composite widget configuration method uses hash stored
# in the widget's hash to map configuration options
my $spec = $cw->ConfigSpecs;
# Return info on the nominated option
my $info = $spec->{$opt};
$info = ($opt =~ /^-(.*)$/) ?
$spec->{$1} : $spec->{-$opt};
# If the default slot is undef then ask subwidgets in turn
# for their default value until one accepts it.
if ($ENHANCED_CONFIGSPECS && !defined($info->[3]))
foreach my $sw ($cw->Subconfigure($opt))
eval { @def = $sw->configure($opt) };
$info->[1] = $def[1] unless defined $info->[1];
$info->[2] = $def[2] unless defined $info->[2];
push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt));
# Real (core) Tk widgets return db name rather than option name
# for aliases so recurse to get that ...
my @real = $cw->configure($info);
push(@results,$opt,$real[1]);
push(@results,$cw->Subconfigure($opt)->configure($opt));
if (exists $spec->{'DEFAULT'})
foreach $opt ($cw->Subconfigure('DEFAULT')->configure)
$results{$opt->[0]} = $opt;
foreach $opt (keys %$spec)
$results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT');
foreach $opt (sort keys %results)
push(@results,$results{$opt});
my $config = $cw->TkHash('Configure');
while (($opt,$val) = each %args)
my $var = \
$config->{$opt};
my $error = "No widget handles $opt";
foreach my $subwidget ($cw->Subconfigure($opt))
next unless (defined $subwidget);
eval {local $SIG{'__DIE__'}; $subwidget->configure($opt => $val) };
my $val2 = (defined $val) ?
$val : 'undef';
$error = "Can't set $opt to `$val2' for $cw: " . $@
;
$cw->BackTrace($error) unless ($accepted);
$changed{$opt} = $val if (!defined $old || !defined $val || "$old" ne "$val");
$cw->Configured(\
%args,\
%changed);
return (wantarray) ?
@results : \
@results;
$cw->BackTrace('Bad args') unless (defined $args && ref $args eq 'HASH');
my $specs = $cw->ConfigSpecs;
# Should we enforce a Delagates(DEFAULT => ) as well ?
$specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'});
# This is a pain with Text or Entry as core widget, they don't
# inherit SELF's cursor. So comment it out for Tk402.001
# $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'});
# Now some hacks that cause colours to propogate down a composite widget
# tree - really needs more thought, other options adding such as active
# colours too and maybe fonts
my $child = ($cw->children)[0]; # 1st child window (if any)
unless (exists($specs->{'-background'}))
push(@bg,'CHILDREN') if $child;
$specs->{'-background'} = [\
@bg,'background','Background',NORMAL_BG
];
unless (exists($specs->{'-foreground'}))
unshift(@fg,'CHILDREN') if $child;
$specs->{'-foreground'} = [\
@fg,'foreground','Foreground',BLACK
];
$cw->ConfigAlias(-fg
=> '-foreground', -bg
=> '-background');
# Pre-scan args for aliases - this avoids defaulting
# options specified via alias
foreach my $opt (keys %$args)
my $info = $specs->{$opt};
if (defined($info) && !ref($info))
$args->{$info} = delete $args->{$opt};
# Now walk %$specs supplying defaults for all the options
# which have a defined default value, potentially looking up .Xdefaults database
# options for the name/class of the 'frame'
foreach my $opt (keys %$specs)
unless (exists $args->{$opt})
my $info = $specs->{$opt};
if ($ENHANCED_CONFIGSPECS && !defined $info->[3])
# configure inquire to fill in default slot from subwidget
if (defined $info->[1] && defined $info->[2])
# Should we do this on the Subconfigure widget instead?
# to match *Entry.Background
my $db = $cw->optionGet($info->[1],$info->[2]);
$info->[3] = $db if (defined $db);
$args->{$opt} = $info->[3];
my $specs = $cw->TkHash('ConfigSpecs');
my ($specs,$opt,$main) = @_;
if (exists($specs->{$opt}))
unless (exists $specs->{$main})
my $targ = $specs->{$opt};
# make main point to same place
$specs->{$main} = $targ unless $targ eq $main;
my $specs = $cw->ConfigSpecs;
unless (_alias
($specs,$opt,$main) || _alias
($specs,$main,$opt))
$cw->BackTrace("Neither $opt nor $main exist");
$cw->BackTrace('Odd number of args to ConfigAlias') if (@_);
my ($cw,$method,@args) = @_;
my $widget = $cw->DelegateFor($method);
$method = "Tk::Widget::$method"
@result = $widget->$method(@args);
$result[0] = $widget->$method(@args);
return (wantarray) ?
@result : $result[0];
$cw->ConfigDefault($args);
my ($cw,$name,$widget) = @_;
confess
'No name' unless (defined $name);
croak
'No widget' unless (defined $widget);
my $hash = $cw->TkHash('SubWidget');
$hash->{$name} = $widget; # advertise it
my ($cw,$kind,$name,%args) = @_;
$args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'});
# my $pack = delete $args{'-pack'};
my $delegate = delete $args{'-delegate'};
my $w = $cw->$kind(%args); # Create it
# $w->pack(@$pack) if (defined $pack);
$cw->Advertise($name,$w) if (defined $name);
$cw->Delegates(map(($_ => $w),@
$delegate)) if (defined $delegate);
return $w; # and return it