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