home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Frame.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  7.8 KB  |  358 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::Frame;
  5. require Tk::Widget;
  6. require Tk::Derived;
  7. use AutoLoader;
  8. use strict qw(vars);
  9. use Carp;
  10.  
  11. @Tk::Frame::ISA = qw(Tk::Derived Tk::Widget);
  12.  
  13. Construct Tk::Widget 'Frame';
  14.  
  15. sub Menubar;
  16.  
  17. sub Tk_cmd { \&Tk::frame }
  18.  
  19. sub CreateArgs
  20. {
  21.  my ($package,$parent,$args) = @_;
  22.  my @result = $package->SUPER::CreateArgs($parent,$args);
  23.  my $colormap = delete $args->{-colormap};                     
  24.  push(@result, '-colormap' => $colormap) if (defined $colormap);
  25.  return @result;
  26. }
  27.  
  28. sub Default
  29. {
  30.  my ($cw,$name,$widget)  = @_;
  31.  confess "No name" unless (defined $name);
  32.  croak "No widget" unless (defined $widget);
  33.  $cw->Delegates(DEFAULT => $widget);
  34.  $cw->ConfigSpecs(DEFAULT => [$widget]);
  35.  $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager);  # Suspect 
  36.  $cw->Advertise($name,$widget);
  37. }
  38.  
  39. sub ConfigDelegate
  40. {
  41.  my ($cw,$name,@skip) = @_;
  42.  my $sw = $cw->Subwidget($name);
  43.  my $sc;
  44.  my %skip = ();
  45.  foreach $sc (@skip)
  46.   {
  47.    $skip{$sc} = 1;
  48.   }
  49.  foreach $sc ($sw->configure)
  50.   {
  51.    my (@info) = @$sc;
  52.    next if (@info == 2);
  53.    my $option = $info[0];
  54.    unless ($skip{$option})
  55.     {
  56.      $option =~ s/^-(.*)/-$name\u$1/;            
  57.      $info[0] = Tk::Configure->new($sw,$info[0]);
  58.      pop(@info);                         
  59.      $cw->ConfigSpecs($option => \@info);
  60.     }
  61.   }
  62. }
  63.  
  64. sub bind
  65. {my ($cw,@args) = @_;
  66.  $cw->Delegate('bind',@args);
  67. }
  68.  
  69. sub focus
  70. {my ($cw,@args) = @_;
  71.  $cw->Delegate('focus',@args);
  72. }
  73.  
  74. #sub bindtags
  75. #{my ($cw,@args) = @_;
  76. # $cw->Delegate('bindtags',@args);
  77. #}
  78.  
  79. sub selection
  80. {my ($cw,@args) = @_;
  81.  $cw->Delegate('selection',@args);
  82. }
  83.  
  84. sub Populate
  85. {
  86.  my ($cw,$args) = @_;
  87.  $cw->ConfigSpecs('-labelPack'     => [ METHOD, undef, undef, undef]);
  88.  $cw->ConfigSpecs('-labelVariable' => [ METHOD, undef, undef, undef]);
  89.  $cw->ConfigSpecs('-label'         => [ METHOD, undef, undef, undef]);
  90. }
  91.  
  92.  
  93. 1;
  94.  
  95. __END__
  96.  
  97. sub labelPack
  98. {
  99.  my ($cw,$val) = @_;
  100.  my $w = $cw->Subwidget('label');
  101.  my @result = ();
  102.  if (@_ > 1)
  103.   {
  104.    if (defined($w) && !defined($val))
  105.     {
  106.      $w->packForget;
  107.     }
  108.    elsif (defined($val) && !defined ($w))
  109.     {
  110.      require Tk::Label;
  111.      $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable);
  112.      $cw->Advertise('label' => $w); 
  113.      $cw->ConfigDelegate('label',qw(text textvariable));
  114.     }
  115.    if (defined($val) && defined($w))
  116.     {
  117.      my %pack = @$val;
  118.      unless (exists $pack{-side})
  119.       {
  120.        $pack{-side} = 'top' unless (exists $pack{-side});
  121.       }
  122.      unless (exists $pack{-fill})
  123.       {
  124.        $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/);
  125.        $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/);
  126.       }
  127.      unless (exists($pack{'-before'}) || exists($pack{'-after'}))
  128.       {
  129.        my $before = ($cw->packSlaves)[0];
  130.        $pack{'-before'} = $before if (defined $before);
  131.       }
  132.      $w->pack(%pack);
  133.     }
  134.   }
  135.  @result = $w->packInfo if (defined $w);
  136.  return (wantarray) ? @result : \@result;
  137. }
  138.  
  139. sub labelVariable
  140. {
  141.  my ($cw,$val) = @_;
  142.  my $var = \$cw->{Configure}{'-labelVariable'};
  143.  if (@_ > 1 && defined $val)
  144.   {
  145.    $$var = $val;
  146.    $$val = '' unless (defined $$val);
  147.    my $w = $cw->Subwidget('label');
  148.    unless (defined $w)
  149.     {
  150.      $cw->labelPack([]);
  151.      $w = $cw->Subwidget('label');
  152.     }
  153.    $w->configure(-textvariable => $val);
  154.   }
  155.  return $$var;
  156. }
  157.  
  158. sub label
  159. {
  160.  my ($cw,$val) = @_;
  161.  my $var = $cw->cget('-labelVariable');
  162.  if (@_ > 1 && defined $val)
  163.   {
  164.    if (!defined $var)
  165.     {
  166.      $var = \$cw->{Configure}{'-label'};
  167.      $cw->labelVariable($var);
  168.     }
  169.    $$var = $val;
  170.   }
  171.  return (defined $var) ? $$var : undef;;
  172. }
  173.  
  174. sub queuePack
  175. {
  176.  my ($cw) = @_; 
  177.  unless ($cw->{'pack_pending'})
  178.   {
  179.    $cw->{'pack_pending'} = 1;
  180.    $cw->afterIdle([$cw,'packscrollbars']);
  181.   }
  182. }
  183.  
  184. sub sbset
  185. {
  186.  my ($cw,$sb,$ref,@args) = @_;
  187.  $sb->set(@args);
  188.  # print "sbset $cw ",$sb->cget('-orient')," p=$$ref need=",$sb->Needed," (",join(',',@args),")\n";
  189.  $cw->queuePack if (@args == 2 && $sb->Needed != $$ref);
  190. }
  191.  
  192. sub freeze_on_map
  193. {
  194.  my ($w) = @_;
  195.  unless ($w->Tk::bind('Freeze','<Map>'))
  196.   {
  197.    $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0])
  198.   }
  199.  $w->AddBindTag('Freeze');
  200. }
  201.  
  202. sub AddScrollbars
  203. {
  204.  require Tk::Scrollbar;
  205.  my ($cw,$w) = @_;
  206.  my $def = "";
  207.  my ($x,$y) = ('','');
  208.  my $s = 0;
  209.  my $c;
  210.  $cw->freeze_on_map;
  211.  foreach $c ($w->configure)
  212.   {
  213.    my $opt = $c->[0];
  214.    if ($opt eq '-yscrollcommand')
  215.     {
  216.      my $slice  = Tk::Frame->new($cw,Name => 'ysbslice');                                       
  217.      my $ysb    = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]);
  218.      my $size   = $ysb->cget('-width');
  219.      my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised', 
  220.                   '-width' => $size, '-height' => $size);
  221.      $ysb->pack(-side => 'left', -fill => 'y');
  222.      $cw->Advertise("yscrollbar" => $ysb); 
  223.      $cw->Advertise("corner" => $corner);
  224.      $cw->Advertise("ysbslice" => $slice);
  225.      $corner->{'before'} = $ysb;
  226.      $slice->{'before'} = $w;
  227.      $y = 's';
  228.      $s = 1;
  229.     }
  230.    elsif ($opt eq '-xscrollcommand')
  231.     {
  232.      my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]);
  233.      $cw->Advertise("xscrollbar" => $xsb); 
  234.      $xsb->{'before'} = $w;
  235.      $x = 'w';
  236.      $s = 1;
  237.     }
  238.   }
  239.  if ($s)
  240.   {
  241.    $cw->Advertise('scrolled' => $w);
  242.    $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$y.$x]);
  243.   }
  244. }
  245.  
  246.  
  247.  
  248.  
  249. sub packscrollbars
  250. {
  251.  my ($cw) = @_;
  252.  my $opt    = $cw->cget('-scrollbars');
  253.  my $slice  = $cw->Subwidget('ysbslice');
  254.  my $xsb    = $cw->Subwidget('xscrollbar');
  255.  my $corner = $cw->Subwidget('corner');
  256.  my $w      = $cw->Subwidget('scrolled');
  257.  my $xside  = (($opt =~ /n/) ? 'top' : 'bottom');
  258.  my $havex  = 0;
  259.  my $havey  = 0;
  260.  $opt =~ s/r//;
  261.  $cw->{'pack_pending'} = 0;
  262.  if (defined $slice)
  263.   {
  264.    my $reqy;
  265.    my $ysb    = $cw->Subwidget('yscrollbar');
  266.    if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed))
  267.     {
  268.      my $yside = (($opt =~ /w/) ? 'left' : 'right');  
  269.      $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'});
  270.      $havey = 1;
  271.      if ($reqy)
  272.       {
  273.        $w->configure(-yscrollcommand => ['set', $ysb]);
  274.       }
  275.      else
  276.       {
  277.        $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]);
  278.       }
  279.     }
  280.    else
  281.     {
  282.      $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//;
  283.      $slice->packForget;
  284.     }
  285.    $cw->{'packysb'} = $havey;
  286.   }
  287.  if (defined $xsb)
  288.   {
  289.    my $reqx;
  290.    if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed))
  291.     {
  292.      $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'});
  293.      $havex = 1;
  294.      if ($reqx)
  295.       {
  296.        $w->configure(-xscrollcommand => ['set', $xsb]);
  297.       }
  298.      else
  299.       {
  300.        $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]);
  301.       }
  302.     }
  303.    else
  304.     {
  305.      $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//;
  306.      $xsb->packForget;
  307.     }
  308.    $cw->{'packxsb'} = $havex;
  309.   }
  310.  if (defined $corner)
  311.   {
  312.    if ($havex && $havey && defined $corner->{'before'})
  313.     {
  314.      my $anchor = $opt;
  315.      $anchor =~ s/o//g;
  316.      $corner->configure(-height => $xsb->ReqHeight);
  317.      $corner->pack(-before => $corner->{'before'}, -side => $xside, 
  318.                    -anchor => $anchor, -fill => 'x');
  319.     }
  320.    else
  321.     {
  322.      $corner->packForget;
  323.     }
  324.   }
  325. }
  326.  
  327. sub scrollbars
  328. {
  329.  my ($cw,$opt) = @_;
  330.  my $var = \$cw->{'-scrollbars'};
  331.  if (@_ > 1)
  332.   {
  333.    my $old = $$var;
  334.    if (!defined $old || $old ne $opt)
  335.     {
  336.      $$var = $opt;
  337.      $cw->queuePack;
  338.     }
  339.   }
  340.  return $$var;
  341. }
  342.  
  343. sub FindMenu
  344. {
  345.  my ($w,$char) = @_;
  346.  my $child;
  347.  my $match;
  348.  foreach $child ($w->children)
  349.   {
  350.    next unless (ref $child);
  351.    $match = $child->FindMenu($char);
  352.    return $match if (defined $match);
  353.   }
  354.  return undef;
  355. }
  356.  
  357.  
  358.