summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Derived.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Derived.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Derived.pm512
1 files changed, 0 insertions, 512 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Derived.pm b/Master/tlpkg/tlperl/lib/Tk/Derived.pm
deleted file mode 100644
index c31c205d2fb..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/Derived.pm
+++ /dev/null
@@ -1,512 +0,0 @@
-# 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 = 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)
- {
- $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
-{
- # Called whenever a derived widget is re-configured
- my ($cw,$args,$changed) = @_;
- if (@_ > 1)
- {
- $cw->afterIdle(['ConfigChanged',$cw,$changed]) if (%$changed);
- }
- return exists $cw->{'Configure'};
-}
-
-sub configure
-{
- # The default composite widget configuration method uses hash stored
- # in the widget's hash to map configuration options
- # onto subwidgets.
- #
- my @results = ();
- my $cw = shift;
- if (@_ <= 1)
- {
- # Enquiry cases
- my $spec = $cw->ConfigSpecs;
- if (@_)
- {
- # Return info on the nominated option
- my $opt = $_[0];
- my $info = $spec->{$opt};
- unless (defined $info)
- {
- $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt};
- }
- if (defined $info)
- {
- if (ref $info)
- {
- # 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]))
- {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
- {
- # 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]);
- }
- }
- 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;
- # 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'}))
- {
- Tk::catch { $cw->Tk::cget('-background') };
- my (@bg) = $@ ? ('PASSIVE') : ('SELF');
- push(@bg,'CHILDREN') if $child;
- $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG];
- }
- unless (exists($specs->{'-foreground'}))
- {
- Tk::catch { $cw->Tk::cget('-foreground') };
- my (@fg) = $@ ? ('PASSIVE') : ('SELF');
- push(@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)
- {
- if ($opt ne 'DEFAULT')
- {
- unless (exists $args->{$opt})
- {
- my $info = $specs->{$opt};
- if (ref $info)
- {
- # Not an alias
- if ($ENHANCED_CONFIGSPECS && !defined $info->[3])
- {
- # configure inquire to fill in default slot from subwidget
- $cw->configure($opt);
- }
- if (defined $info->[3])
- {
- 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];
- }
- }
- }
- }
- }
-}
-
-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))
- {
- # opt is a real option
- $specs->{$main} = $opt
- }
- else
- {
- # opt is itself an alias
- # make main point to same place
- $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; # advertise it
- return $widget;
-}
-
-sub Component
-{
- 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
-}
-
-1;
-__END__
-
-