home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Derived.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  11.7 KB  |  518 lines
  1. # Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Derived;
  5. require Tk::Widget;
  6. require Tk::Configure;
  7. use strict;
  8. use Carp;
  9.  
  10. =head1 NAME
  11.  
  12. Tk::Derived - Base class for widgets derived from others
  13.  
  14. =head1 SYNOPSIS
  15.  
  16.   package Tk::Whatever;
  17.   require Tk::Something; 
  18.   require Tk::Derived;
  19.   @ISA = qw(Tk::Derived Tk::Something);
  20.  
  21.   sub Populate
  22.   {
  23.    my ($cw,$args) = @_;
  24.    ...
  25.    $cw->SUPER::Populate($args);
  26.    $cw->ConfigSpecs(...);
  27.    ...
  28.   }
  29.  
  30. =head1 DESCRIPTION 
  31.  
  32. Tk::Derived is used with perl5's multiple inheritance to override some
  33. methods normally inherited from Tk::Widget.
  34.  
  35. Tk::Derived should precede any Tk widgets in the class's @ISA.
  36.  
  37. Tk::Derived's main purpose is to apply wrappers to C<configure> and C<cget>
  38. methods of widgets to allow the derived widget to add to or modify behaviour
  39. of the configure options supported by the base widget.
  40.  
  41. The derived class should normally override the C<Populate> method provided
  42. by Tk::Derived and call C<ConfigSpecs> to declare configure options.
  43.  
  44. The public methods provided by Tk::Derived are as follows:
  45.  
  46. =over 4
  47.  
  48. =cut
  49.  
  50. $Tk::Derived::Debug = 0;
  51.  
  52. use Tk qw(NORMAL_BG BLACK);
  53.  
  54. sub Subwidget 
  55. {
  56.  my $cw = shift;
  57.  my @result = ();
  58.  if (exists $cw->{SubWidget})
  59.   {
  60.    if (@_)
  61.     {
  62.      my $name;
  63.      foreach $name (@_)
  64.       {
  65.        push(@result,$cw->{SubWidget}{$name}) if (exists $cw->{SubWidget}{$name});
  66.       }
  67.     }
  68.    else
  69.     {
  70.      @result = values %{$cw->{SubWidget}};
  71.     }
  72.   }
  73.  return (wantarray) ? @result : $result[0];
  74. } 
  75.  
  76. sub _makelist
  77. {
  78.  my $widget = shift;
  79.  my (@specs) = (ref $widget && ref $widget eq "ARRAY") ? (@$widget) : ($widget);
  80.  return @specs;
  81. }
  82.  
  83. sub Subconfigure
  84. {
  85.  # This finds the widget or widgets to to which to apply a particular 
  86.  # configure option
  87.  my ($cw,$opt) = @_;
  88.  my $config = $cw->ConfigSpecs;
  89.  my $widget;
  90.  my @subwidget = ();
  91.  my @arg = ();
  92.  if (defined $opt)
  93.   {
  94.    $widget = $config->{$opt};
  95.    unless (defined $widget)
  96.     {
  97.      $widget = ($opt =~ /^-(.*)$/) ? $config->{$1} : $config->{-$opt};
  98.     }
  99.    # Handle alias entries
  100.    if (defined($widget) && !ref($widget))
  101.     {
  102.      $opt    = $widget;
  103.      $widget = $config->{$widget};
  104.     }
  105.    push(@arg,$opt) unless ($opt eq 'DEFAULT');
  106.   }
  107.  $widget = $config->{DEFAULT} unless (defined $widget);
  108.  if (defined $widget)
  109.   {
  110.    $cw->BackTrace("Invalid ConfigSpecs $widget") unless (ref($widget) && (ref $widget eq "ARRAY"));
  111.    $widget = $widget->[0];
  112.   }
  113.  else
  114.   {
  115.    $widget = 'SELF';
  116.   }
  117.  foreach $widget (_makelist($widget))
  118.   {
  119.    if (ref $widget)
  120.     {
  121.      my $ref = ref $widget;
  122.      if ($ref eq 'ARRAY')
  123.       {
  124.        $widget = Tk::Configure->new(@$widget); 
  125.        push(@subwidget,$widget)
  126.       }
  127.      elsif ($ref eq 'HASH')
  128.       {
  129.        my $key;
  130.        foreach $key (%$widget)
  131.         {
  132.          my $sw;  
  133.          foreach $sw (_makelist($widget->{$key}))
  134.           {
  135.            push(@subwidget,Tk::Configure->new($sw,$key));
  136.           }
  137.         }
  138.       }
  139.      else
  140.       {
  141.        push(@subwidget,$widget)
  142.       }
  143.     }
  144.    elsif ($widget eq 'ADVERTISED')
  145.     {
  146.      push(@subwidget,$cw->Subwidget)
  147.     }
  148.    elsif ($widget eq 'DESCENDANTS')
  149.     {
  150.      push(@subwidget,$cw->Descendants) 
  151.     }
  152.    elsif ($widget eq 'CHILDREN')
  153.     {
  154.      push(@subwidget,$cw->children) 
  155.     }
  156.    elsif ($widget eq 'METHOD')
  157.     {
  158.      my ($method) = ($opt =~ /^-?(.*)$/);
  159.      push(@subwidget,Tk::Configure->new($method,$method,$cw))
  160.     }
  161.    elsif ($widget eq 'SETMETHOD')
  162.     {
  163.      my ($method) = ($opt =~ /^-?(.*)$/);
  164.      push(@subwidget,Tk::Configure->new($method,'_cget',$cw,@arg))
  165.     }
  166.    elsif ($widget eq 'SELF')
  167.     {
  168.      push(@subwidget,Tk::Configure->new('configure_self', 'cget_self', $cw,@arg))
  169.     }
  170.    elsif ($widget eq 'PASSIVE') 
  171.     {
  172.      push(@subwidget,Tk::Configure->new('_configure','_cget',$cw,@arg))
  173.     }
  174.    elsif ($widget eq 'CALLBACK') 
  175.     {
  176.      push(@subwidget,Tk::Configure->new('_callback','_cget',$cw,@arg))
  177.     }
  178.    else
  179.     {
  180.      push(@subwidget,$cw->Subwidget($widget));
  181.     }
  182.   }
  183.  $cw->BackTrace("No delegate subwidget '$widget' for $opt") unless (@subwidget);
  184.  return (wantarray) ? @subwidget : $subwidget[0];
  185. }
  186.  
  187. sub _cget
  188. {
  189.  my ($cw,$opt) = @_;
  190.  $cw->BackTrace("Wrong number of args to cget") unless (@_ == 2);
  191.  return $cw->{Configure}{$opt}
  192. }
  193.  
  194. sub _configure
  195. {
  196.  my ($cw,$opt,$val) = @_;
  197.  $cw->BackTrace("Wrong number of args to configure") unless (@_ == 3);
  198.  $cw->{Configure}{$opt} = $val;
  199. }
  200.  
  201. sub _callback
  202. {
  203.  my ($cw,$opt,$val) = @_;
  204.  $cw->BackTrace("Wrong number of args to configure") unless (@_ == 3);
  205.  $val = Tk::Callback->new($val) if defined $val;
  206.  $cw->{Configure}{$opt} = $val;
  207. }
  208.  
  209. sub cget
  210. {my ($cw,$opt) = @_;
  211.  my (@subwidget) = $cw->Subconfigure($opt);
  212.  my @result = $cw->{Configure}{$opt};
  213.  if (@subwidget == 1)
  214.   {
  215.    @result = $subwidget[0]->cget($opt);
  216.   }
  217.  return (wantarray) ? @result : $result[0];
  218. }
  219.  
  220. sub Configured
  221. {
  222.  # Called whenever a derived widget is re-configured
  223.  my ($cw,$args,$changed) = @_;
  224.  if (@_ > 1)
  225.   {
  226.    $cw->DoWhenIdle(['ConfigChanged',$cw,$changed]) if (%$changed);
  227.   }
  228.  return exists $cw->{'Configure'};
  229. }
  230.  
  231. sub configure
  232. {
  233.  # The default composite widget configuration method uses hash stored
  234.  # in the widget's hash to map configuration options
  235.  # onto subwidgets. 
  236.  #
  237.  my @results = ();
  238.  my $cw = shift;
  239.  if (@_ <= 1)
  240.   {
  241.    # Enquiry cases 
  242.    my $spec = $cw->ConfigSpecs;
  243.    if (@_)
  244.     {
  245.      # Return info on the nominated option
  246.      my $opt  = $_[0];
  247.      my $info = $spec->{$opt};
  248.      unless (defined $info)
  249.       {
  250.        $info = ($opt =~ /^-(.*)$/) ? $spec->{$1} : $spec->{-$opt};
  251.       }
  252.      if (defined $info)
  253.       {
  254.        if (ref $info)
  255.         {
  256.          push(@results,$opt,$info->[1],$info->[2],$info->[3],$cw->cget($opt));
  257.         }
  258.        else
  259.         {
  260.          # Real (core) Tk widgets return db name rather than option name 
  261.          # for aliases so recurse to get that ...
  262.          my @real = $cw->configure($info);
  263.          push(@results,$opt,$real[1]);
  264.         }
  265.       }
  266.      else
  267.       {
  268.        push(@results,$cw->Subconfigure($opt)->configure($opt));
  269.       }
  270.     }
  271.    else
  272.     {
  273.      my $opt;
  274.      my %results;
  275.      if (exists $spec->{'DEFAULT'})
  276.       {
  277.        foreach $opt ($cw->Subconfigure('DEFAULT')->configure)
  278.         {
  279.          $results{$opt->[0]} = $opt;
  280.         }
  281.       }
  282.      foreach $opt (keys %$spec)
  283.       {
  284.        $results{$opt} = [$cw->configure($opt)] if ($opt ne 'DEFAULT');
  285.       }
  286.      foreach $opt (sort keys %results)
  287.       {
  288.        push(@results,$results{$opt});
  289.       }
  290.     }
  291.   }
  292.  else
  293.   {
  294.    my (%args) = @_;
  295.    my %changed = ();
  296.    my ($opt,$val);
  297.    $cw->{Configure} = {} unless exists $cw->{Configure};
  298.    while (($opt,$val) = each %args)
  299.     {
  300.      my $var = \$cw->{Configure}{$opt};
  301.      my $old = $$var;
  302.      my $subwidget;
  303.      $$var = $val;
  304.      my $accepted = 0;
  305.      my $error = "No widget handles $opt";
  306.      foreach $subwidget ($cw->Subconfigure($opt))
  307.       {
  308.        next unless (defined $subwidget);
  309.        eval {local $SIG{'__DIE__'};  $subwidget->configure($opt => $val) };
  310.        if ($@)
  311.         {
  312.          $error = $@; 
  313.          undef $@;
  314.         }
  315.        else
  316.         {
  317.          $accepted = 1;
  318.         }
  319.       }
  320.      $cw->BackTrace($error) unless ($accepted);
  321.      $val = $$var;
  322.      $changed{$opt} = $val if (!defined $old || !defined $val || $old ne $val);
  323.     }
  324.    $cw->Configured(\%args,\%changed);
  325.   }
  326.  return (wantarray) ? @results : $results[0];
  327. }
  328.  
  329. sub ConfigDefault
  330. {
  331.  my ($cw,$args) = @_;
  332.  
  333.  $cw->BackTrace("Bad args") unless (defined $args && ref $args eq 'HASH');
  334.  
  335.  my $specs = $cw->ConfigSpecs;
  336.  # Should we enforce a Delagates(DEFAULT => )  as well ?
  337.  $specs->{'DEFAULT'} = ['SELF'] unless (exists $specs->{'DEFAULT'});
  338.  
  339.  # 
  340.  # This is a pain with Text or Entry as core widget, they don't
  341.  # inherit SELF's cursor. So comment it out for Tk402.001
  342.  # 
  343.  # $specs->{'-cursor'} = ['SELF',undef,undef,undef] unless (exists $specs->{'-cursor'});
  344.  
  345.  # Now some hacks that cause colours to propogate down a composite widget 
  346.  # tree - really needs more thought, other options adding such as active 
  347.  # colours too and maybe fonts
  348.  
  349.  my $children = scalar($cw->children);
  350.  unless (exists($specs->{'-background'}))
  351.   {
  352.    my (@bg) = ('SELF');
  353.    push(@bg,'CHILDREN') if $children;
  354.    $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG]; 
  355.   }
  356.  unless (exists($specs->{'-foreground'}))
  357.   {
  358.    my (@fg) = ('PASSIVE');
  359.    unshift(@fg,'CHILDREN') if $children;
  360.    $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK];
  361.   }
  362.  $cw->ConfigAlias(-fg => '-foreground', -bg => '-background');
  363.  
  364.  # Pre-scan args for aliases - this avoids defaulting
  365.  # options specified via alias
  366.  my $opt; 
  367.  foreach $opt (keys %$args)
  368.   {
  369.    my $info = $specs->{$opt};
  370.    if (defined($info) && !ref($info))
  371.     {
  372.      $args->{$info} = delete $args->{$opt};
  373.     }
  374.   }
  375.  
  376.  # Now walk %$specs supplying defaults for all the options 
  377.  # which have a defined default value, potentially looking up .Xdefaults database
  378.  # options for the name/class of the 'frame' 
  379.  
  380.  foreach $opt (keys %$specs)
  381.   {
  382.    if ($opt ne 'DEFAULT')
  383.     {
  384.      unless (exists $args->{$opt})
  385.       {
  386.        my $info = $specs->{$opt};
  387.        if (ref $info)
  388.         {
  389.          # Not an alias
  390.          if (defined $info->[3])
  391.           {
  392.            # Only propagate if a default is supplied
  393.            $args->{$opt} = $info->[3];
  394.            # maybe should convert -fred into 'fred','Fred' here 
  395.            if (defined $info->[1] && defined $info->[2])
  396.             {
  397.              # Should we do this on the Subconfigure widget instead?
  398.              # to match *Entry.Background 
  399.              my $db = $cw->optionGet($info->[1],$info->[2]);
  400.              $args->{$opt} = $db if (defined $db);
  401.             }
  402.           }
  403.         }
  404.       }
  405.     }
  406.   }
  407. }
  408.  
  409. =item -E<gt>ConfigSpecs(-I<key> =E<gt> [I<kind>, I<name>, I<Class>, I<default], ...)
  410.  
  411. =cut 
  412.  
  413. sub ConfigSpecs
  414. {
  415.  my $cw = shift;
  416.  if (exists $cw->{'ConfigSpecs'})
  417.   {
  418.    my $specs = $cw->{'ConfigSpecs'};
  419.    while (@_)
  420.     {
  421.      my $key = shift;
  422.      my $val = shift;
  423.      $specs->{$key} = $val;
  424.     }
  425.   }
  426.  else
  427.   {
  428.    $cw->{'ConfigSpecs'} = { @_ };
  429.   }
  430.  return $cw->{'ConfigSpecs'};
  431. }
  432.  
  433. sub ConfigAlias
  434. {
  435.  my $cw = shift;
  436.  my $specs = $cw->ConfigSpecs;
  437.  while (@_ >= 2)
  438.   {
  439.    my $opt  = shift;
  440.    my $main = shift;
  441.    if (exists($specs->{$opt}) && ref($specs->{$opt}))
  442.     {
  443.      $specs->{$main} = $opt unless (exists $specs->{$main});
  444.     }
  445.    elsif (exists($specs->{$main}) && ref($specs->{$main}))
  446.     {
  447.      $specs->{$opt}  = $main unless (exists $specs->{$opt});
  448.     }
  449.    else 
  450.     {
  451.      $cw->BackTrace("Neither $opt nor $main exist");
  452.     }
  453.   }
  454.  $cw->BackTrace("Odd number of args to ConfigAlias") if (@_);
  455. }
  456.  
  457.  
  458. sub Delegate
  459. {
  460.  my ($cw,$method,@args) = @_;
  461.  my $widget = $cw->DelegateFor($method);
  462.  $method = "Tk::$method" if ($widget == $cw);
  463.  my @result;
  464.  if (wantarray)
  465.   {
  466.    @result   = $widget->$method(@args);
  467.   }
  468.  else
  469.   {
  470.    $result[0] = $widget->$method(@args);
  471.   }
  472.  return (wantarray) ? @result : $result[0];
  473. }
  474.  
  475. sub InitObject
  476. {
  477.  my ($cw,$args) = @_;
  478.  $cw->Populate($args);    
  479.  $cw->ConfigDefault($args);
  480. }
  481.  
  482. sub ConfigChanged
  483. {
  484.  my ($cw,$args) = @_;
  485. }       
  486.  
  487. sub Advertise
  488. {
  489.  my ($cw,$name,$widget)  = @_;
  490.  confess "No name" unless (defined $name);
  491.  croak "No widget" unless (defined $widget);
  492.  $cw->{SubWidget} = {} unless (exists $cw->{SubWidget});
  493.  $cw->{SubWidget}{$name} = $widget;              # advertise it
  494.  return $widget;
  495. }
  496.  
  497. sub Component
  498. {
  499.  my ($cw,$kind,$name,%args) = @_;
  500.  $args{'Name'} = "\l$name" if (defined $name && !exists $args{'Name'});
  501.  # my $pack = delete $args{'-pack'};
  502.  my $delegate = delete $args{'-delegate'};
  503.  my $w = $cw->$kind(%args);            # Create it
  504.  # $w->pack(@$pack) if (defined $pack);
  505.  $cw->Advertise($name,$w) if (defined $name);
  506.  $cw->Delegates(map(($_ => $w),@$delegate)) if (defined $delegate); 
  507.  return $w;                            # and return it
  508. }
  509.  
  510. 1;
  511. __END__
  512.  
  513. =back
  514.  
  515. =cut
  516.  
  517.  
  518.