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