package Tk::Derived;
require Tk::Widget;
require Tk::Configure;
use strict;
use Carp;
use vars qw($VERSION);
$VERSION = '3.046'; # $Id: //depot/Tk8/Tk/Derived.pm#46 $
$Tk::Derived::Debug=0;
my$ENHANCED_CONFIGSPECS=0;
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{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};}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{$widget='SELF';}foreach$widget(_makelist($widget)){$widget='SELF' if(ref($widget)&&$widget==$cw);
if(ref$widget){my$ref=ref$widget;
if($ref eq 'ARRAY'){$widget=Tk::Configure->new(@$widget);
push(@subwidget,$widget)}elsif($ref eq 'HASH'){foreach my $key(%$widget){foreach my $sw(_makelist($widget->{$key})){push(@subwidget,Tk::Configure->new($sw,$key));}}}else{push(@subwidget,$widget)}}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))}else{push(@subwidget,$cw->Subwidget($widget));}}$cw->BackTrace("No delegate subwidget '$widget' for $opt")unless(@subwidget);
return(wantarray)?@subwidget:$subwidget[0];}sub _cget{my($cw,$opt)=@_;
$cw->BackTrace('Wrong number of args to cget')unless(@_==2);
return$cw->{Configure}{$opt}}sub _configure{my($cw,$opt,$val)=@_;
$cw->BackTrace('Wrong number of args to configure')unless(@_==3);
$cw->{Configure}{$opt}=$val;}sub _callback{my($cw,$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;}sub cget{my($cw,$opt)=@_;
my@result;
local$SIG{'__DIE__'};
foreach my $sw($cw->Subconfigure($opt)){if(wantarray){eval{@result=$sw->cget($opt)};}else{eval{$result[0]=$sw->cget($opt)};}last unless$@;}return wantarray?@result:$result[0];}sub Configured{my($cw,$args,$changed)=@_;
if(@_>1){$cw->afterIdle(['ConfigChanged',$cw,$changed])if(%$changed);}return exists$cw->{'Configure'};}sub configure{my@results=();
my$cw=shift;
if(@_<=1){my$spec=$cw->ConfigSpecs;
if(@_){my$opt=$_[0];
my$info=$spec->{$opt};
unless(defined$info){$info=($opt=~/^-(.*)$/)?$spec->{$1}:$spec->{-$opt};}if(defined$info){if(ref$info){if($ENHANCED_CONFIGSPECS&&!defined($info->[3])){local$SIG{'__DIE__'};
my@def;
foreach my $sw($cw->Subconfigure($opt)){eval{@def=$sw->configure($opt)};
last unless$@;}$info->[3]=$def[3];
$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));}else{my@real=$cw->configure($info);
push(@results,$opt,$real[1]);}}else{push(@results,$cw->Subconfigure($opt)->configure($opt));}}else{my$opt;
my%results;
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});}}}else{my(%args)=@_;
my%changed=();
my($opt,$val);
my$config=$cw->TkHash('Configure');
while(($opt,$val)=each%args){my$var=\$config->{$opt};
my$old=$$var;
$$var=$val;
my$accepted=0;
my$error="No widget handles $opt";
foreach my $subwidget($cw->Subconfigure($opt)){next unless(defined$subwidget);
eval{local$SIG{'__DIE__'};$subwidget->configure($opt=>$val)};
if($@){my$val2=(defined$val)?$val:'undef';
$error="Can't set $opt to `$val2' for $cw: ".$@;
undef$@;}else{$accepted=1;}}$cw->BackTrace($error)unless($accepted);
$val=$$var;
$changed{$opt}=$val if(!defined$old||!defined$val||"$old" ne"$val");}$cw->Configured(\%args,\%changed);}return(wantarray)?@results:\@results;}sub ConfigDefault{my($cw,$args)=@_;
$cw->BackTrace('Bad args')unless(defined$args&&ref$args eq 'HASH');
my$specs=$cw->ConfigSpecs;
$specs->{'DEFAULT'}=['SELF']unless(exists$specs->{'DEFAULT'});
my$child=($cw->children)[0];
unless(exists($specs->{'-background'})){my(@bg)=('SELF');
push(@bg,'CHILDREN')if$child;
$specs->{'-background'}=[\@bg,'background','Background',NORMAL_BG];}unless(exists($specs->{'-foreground'})){my(@fg)=('PASSIVE');
unshift(@fg,'CHILDREN')if$child;
$specs->{'-foreground'}=[\@fg,'foreground','Foreground',BLACK];}$cw->ConfigAlias(-fg=>'-foreground',-bg=>'-background');
foreach my $opt(keys%$args){my$info=$specs->{$opt};
if(defined($info)&&!ref($info)){$args->{$info}=delete$args->{$opt};}}foreach my $opt(keys%$specs){if($opt ne 'DEFAULT'){unless(exists$args->{$opt}){my$info=$specs->{$opt};
if(ref$info){if($ENHANCED_CONFIGSPECS&&!defined$info->[3]){$cw->configure($opt);}if(defined$info->[3]){if(defined$info->[1]&&defined$info->[2]){my$db=$cw->optionGet($info->[1],$info->[2]);
$info->[3]=$db if(defined$db);}$args->{$opt}=$info->[3];}}}}}}sub ConfigSpecs{my$cw=shift;
my$specs=$cw->TkHash('ConfigSpecs');
while(@_){my$key=shift;
my$val=shift;
$specs->{$key}=$val;}return$specs;}sub _alias{my($specs,$opt,$main)=@_;
if(exists($specs->{$opt})){unless(exists$specs->{$main}){my$targ=$specs->{$opt};
if(ref($targ)){$specs->{$main}=$opt}else{$specs->{$main}=$targ unless$targ eq$main;}}return 1;}return 0;}sub ConfigAlias{my$cw=shift;
my$specs=$cw->ConfigSpecs;
while(@_>=2){my$opt=shift;
my$main=shift;
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(@_);}sub Delegate{my($cw,$method,@args)=@_;
my$widget=$cw->DelegateFor($method);
if($widget==$cw){$method="Tk::Widget::$method"}my@result;
if(wantarray){@result=$widget->$method(@args);}else{$result[0]=$widget->$method(@args);}return(wantarray)?@result:$result[0];}sub InitObject{my($cw,$args)=@_;
$cw->Populate($args);
$cw->ConfigDefault($args);}sub ConfigChanged{my($cw,$args)=@_;}sub Advertise{my($cw,$name,$widget)=@_;
confess 'No name' unless(defined$name);
croak 'No widget' unless(defined$widget);
my$hash=$cw->TkHash('SubWidget');
$hash->{$name}=$widget;
return$widget;}sub Component{my($cw,$kind,$name,%args)=@_;
$args{'Name'}="\l$name" if(defined$name&&!exists$args{'Name'});
my$delegate=delete$args{'-delegate'};
my$w=$cw->$kind(%args);
$cw->Advertise($name,$w)if(defined$name);
$cw->Delegates(map(($_=>$w),@$delegate))if(defined$delegate);
return$w;}1;
__END__


