home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _aa863c4515da661933e29ca0c54efaa2 < prev    next >
Text File  |  2004-06-01  |  14KB  |  545 lines
  1. # Tk::Pane.pm
  2. #
  3. # Copyright (c) 1997-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6.  
  7. package Tk::Pane;
  8.  
  9. use vars qw($VERSION);
  10. $VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/Pane.pm#7 $
  11.  
  12. use Tk;
  13. use Tk::Widget;
  14. use Tk::Derived;
  15. use Tk::Frame;
  16.  
  17. use strict;
  18.  
  19. use base qw(Tk::Derived Tk::Frame);
  20.  
  21. Construct Tk::Widget 'Pane';
  22.  
  23. use Tk::Submethods(
  24.   grid => [qw/bbox columnconfigure location propagate rowconfigure size slaves/],
  25.   pack => [qw/propagate slaves/]
  26. );
  27.  
  28. sub ClassInit {
  29.     my ($class,$mw) = @_;
  30.     $mw->bind($class,'<Configure>',['QueueLayout',4]);
  31.     $mw->bind($class,'<FocusIn>',  'NoOp');
  32.     return $class;
  33. }
  34.  
  35. sub Populate {
  36.     my $pan = shift;
  37.  
  38.     my $frame    = $pan->Component(Frame => "frame");
  39.  
  40.     $pan->afterIdle(['Manage',$pan,$frame]);
  41.     $pan->afterIdle(['QueueLayout',$pan,1]);
  42.  
  43.     $pan->Delegates(
  44.     DEFAULT => $frame,
  45.     # FIXME
  46.     # These are a hack to avoid an existing bug in Tk::Widget::DelegateFor
  47.     # which has been reported and should be fixed in the next Tk release
  48.     see    => $pan,
  49.     xview    => $pan,
  50.     yview    => $pan,
  51.     );
  52.  
  53.     $pan->ConfigSpecs(
  54.     DEFAULT        => [$frame],
  55.     -sticky        => [PASSIVE    => undef, undef, undef],
  56.     -gridded    => [PASSIVE    => undef, undef, undef],
  57.     -xscrollcommand => [CALLBACK    => undef, undef, undef],
  58.     -yscrollcommand => [CALLBACK    => undef, undef, undef],
  59.     );
  60.  
  61.  
  62.     $pan;
  63. }
  64.  
  65.  
  66. sub grid {
  67.     my $w = shift;
  68.     $w = $w->Subwidget('frame')
  69.     if (@_ && $_[0] =~ /^(?: bbox
  70.                 |columnconfigure
  71.                 |location
  72.                 |propagate
  73.                 |rowconfigure
  74.                 |size
  75.                 |slaves)$/x);
  76.     $w->SUPER::grid(@_);
  77. }
  78.  
  79. sub slave {
  80.     my $w = shift;
  81.     $w->Subwidget('frame');
  82. }
  83.  
  84. sub pack {
  85.     my $w = shift;
  86.     $w = $w->Subwidget('frame')
  87.     if (@_ && $_[0] =~ /^(?:propagate|slaves)$/x);
  88.     $w->SUPER::pack(@_);
  89. }
  90.  
  91. sub QueueLayout {
  92.     shift if ref $_[1];
  93.     my($m,$why) = @_;
  94.     $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending});
  95.     $m->{LayoutPending} |= $why;
  96. }
  97.  
  98. sub AdjustXY {
  99.     my($w,$Wref,$X,$st,$scrl,$getx) = @_;
  100.     my $W = $$Wref;
  101.  
  102.     if($w >= $W) {
  103.     my $v = 0;
  104.     if($getx) {
  105.         $v |= 1 if $st =~ /[Ww]/;
  106.         $v |= 2 if $st =~ /[Ee]/;
  107.     }
  108.     else {
  109.         $v |= 1 if $st =~ /[Nn]/;
  110.         $v |= 2 if $st =~ /[Ss]/;
  111.     }
  112.  
  113.     if($v == 0) {
  114.         $X = int(($w - $W) / 2);
  115.     }
  116.     elsif($v == 1) {
  117.         $X = 0;
  118.     }
  119.     elsif($v == 2) {
  120.         $X = int($w - $W);
  121.     }
  122.     else {
  123.         $X = 0;
  124.         $$Wref = $w;
  125.     }
  126.     $scrl->Call(0,1)
  127.         if $scrl;
  128.     }
  129.     elsif($scrl) {
  130.     $X = 0
  131.         if $X > 0;
  132.     $X = $w - $W
  133.         if(($X + $W) < $w);
  134.     $scrl->Call(-$X / $W,(-$X + $w) / $W);
  135.     }
  136.     else {
  137.     $X = 0;
  138.     $$Wref = $w;
  139.     }
  140.  
  141.     return $X;
  142. }
  143.  
  144. sub Layout {
  145.     my $pan = shift;
  146.     my $why = $pan->{LayoutPending};
  147.  
  148.     my $slv = $pan->Subwidget('frame');
  149.  
  150.     return unless $slv;
  151.  
  152.     my $H = $slv->ReqHeight;
  153.     my $W = $slv->ReqWidth;
  154.     my $X = $slv->x;
  155.     my $Y = $slv->y;
  156.     my $w = $pan->width;
  157.     my $h = $pan->height;
  158.     my $yscrl = $pan->{Configure}{'-yscrollcommand'};
  159.     my $xscrl = $pan->{Configure}{'-xscrollcommand'};
  160.  
  161.     $yscrl = undef
  162.     if(defined($yscrl) && UNIVERSAL::isa($yscrl, 'SCALAR') && !defined($$yscrl));
  163.     $xscrl = undef
  164.     if(defined($xscrl) && UNIVERSAL::isa($xscrl, 'SCALAR') && !defined($$xscrl));
  165.  
  166.     if($why & 1) {
  167.     $h = $pan->{Configure}{'-height'} || 0
  168.         unless($h > 1);
  169.     $w = $pan->{Configure}{'-width'} || 0
  170.         unless($w > 1);
  171.  
  172.     $h = $H
  173.         unless($h > 1 || defined($yscrl));
  174.     $w = $W
  175.         unless($w > 1 || defined($xscrl));
  176.  
  177.     $w = 100 if $w <= 1;
  178.     $h = 100 if $h <= 1;
  179.  
  180.     $pan->GeometryRequest($w,$h);
  181.     }
  182.  
  183.     my $st = $pan->{Configure}{'-sticky'} || '';
  184.  
  185.     $pan->{LayoutPending} = 0;
  186.  
  187.     $slv->MoveResizeWindow(
  188.     AdjustXY($w,\$W,$X,$st,$xscrl,1),
  189.     AdjustXY($h,\$H,$Y,$st,$yscrl,0),
  190.     $W,$H
  191.     );
  192. }
  193.  
  194. sub SlaveGeometryRequest {
  195.     my ($m,$s) = @_;
  196.     $m->QueueLayout(1);
  197. }
  198.  
  199. sub LostSlave {
  200.     my($m,$s) = @_;
  201.     $m->{Slave} = undef;
  202. }
  203.  
  204. sub Manage {
  205.     my $m = shift;
  206.     my $s = shift;
  207.  
  208.     $m->{Slave} = $s;
  209.     $m->ManageGeometry($s);
  210.     $s->MapWindow;
  211.     $m->QueueLayout(2);
  212. }
  213.  
  214. sub xview {
  215.     my $pan = shift;
  216.  
  217.     unless(@_) {
  218.         my $scrl = $pan->{Configure}{'-xscrollcommand'};
  219.     return (0,1) unless $scrl;
  220.     my $slv = $pan->Subwidget('frame');
  221.     my $sw  = $slv->ReqWidth;
  222.     my $ldx = $pan->rootx - $slv->rootx;
  223.     my $rdx = $ldx + $pan->width;
  224.     $ldx = $ldx <= 0   ? 0 : $ldx / $sw;
  225.     $rdx = $rdx >= $sw ? 1 : $rdx / $sw;
  226.     return( $ldx , $rdx);
  227.     }
  228.     elsif(@_ == 1) {
  229.     my $widget = shift;
  230.     my $slv = $pan->Subwidget('frame');
  231.     xyview(1,$pan,
  232.         moveto => ($widget->rootx - $slv->rootx) / $slv->ReqWidth);
  233.     }
  234.     else {
  235.     xyview(1,$pan,@_);
  236.     }
  237. }
  238.  
  239. sub yview {
  240.     my $pan = shift;
  241.  
  242.     unless(@_) {
  243.     my $scrl = $pan->{Configure}{'-yscrollcommand'};
  244.     return (0,1) unless $scrl;
  245.     my $slv = $pan->Subwidget('frame');
  246.     my $sh  = $slv->ReqHeight;
  247.     my $tdy = $pan->rooty - $slv->rooty;
  248.     my $bdy = $tdy + $pan->height;
  249.     $tdy = $tdy <= 0   ? 0 : $tdy / $sh;
  250.     $bdy = $bdy >= $sh ? 1 : $bdy / $sh;
  251.     return( $tdy, $bdy);
  252.     }
  253.     elsif(@_ == 1) {
  254.     my $widget = shift;
  255.     my $slv = $pan->Subwidget('frame');
  256.     xyview(0,$pan,
  257.         moveto => ($widget->rooty - $slv->rooty) / $slv->ReqHeight);
  258.     }
  259.     else {
  260.     xyview(0,$pan,@_);
  261.     }
  262. }
  263.  
  264. sub xyview {
  265.     my($horz,$pan,$cmd,$val,$mul) = @_;
  266.     my $slv = $pan->Subwidget('frame');
  267.     return unless $slv;
  268.  
  269.     my($XY,$WH,$wh,$scrl,@a);
  270.  
  271.     if($horz) {
  272.     $XY   = $slv->x;
  273.     $WH   = $slv->ReqWidth;
  274.     $wh   = $pan->width;
  275.     $scrl = $pan->{Configure}{'-xscrollcommand'};
  276.     }
  277.     else {
  278.     $XY   = $slv->y;
  279.     $WH   = $slv->ReqHeight;
  280.     $wh   = $pan->height;
  281.     $scrl = $pan->{Configure}{'-yscrollcommand'};
  282.     }
  283.  
  284.     $scrl = undef
  285.     if(UNIVERSAL::isa($scrl, 'SCALAR') && !defined($$scrl));
  286.  
  287.     if($WH < $wh) {
  288.     $scrl->Call(0,1);
  289.     return;
  290.     }
  291.  
  292.     if($cmd eq 'scroll') {
  293.     my $dxy = 0;
  294.  
  295.     my $gridded = $pan->{Configure}{'-gridded'} || '';
  296.     my $do_gridded = ($gridded eq 'both'
  297.                 || (!$horz == ($gridded ne 'x'))) ? 1 : 0;
  298.  
  299.     if($do_gridded && $mul eq 'pages') {
  300.         my $ch = ($slv->children)[0];
  301.         if(defined($ch) && $ch->manager eq 'grid') {
  302.         @a = $horz
  303.             ? (1-$XY,int($slv->width / 2))
  304.             : (int($slv->height / 2),1-$XY);
  305.         my $rc = ($slv->gridLocation(@a))[$horz ? 0 : 1];
  306.         my $mrc = ($slv->gridSize)[$horz ? 0 : 1];
  307.         $rc += $val;
  308.         $rc = 0 if $rc < 0;
  309.         $rc = $mrc if $rc > $mrc;
  310.         my $gsl;
  311.         while($rc >= 0 && $rc < $mrc) {
  312.             $gsl = ($slv->gridSlaves(-row => $rc))[0];
  313.             last
  314.             if defined $gsl;
  315.             $rc += $val;
  316.         }
  317.         if(defined $gsl) {
  318.             @a = $horz ? ($rc,0) : (0,$rc);
  319.             $XY = 0 - ($slv->gridBbox(@a))[$horz ? 0 : 1];
  320.         }
  321.         else {
  322.             $XY = $val > 0 ? $wh - $WH : 0;
  323.         }
  324.         $dxy = $val; $val = 0;
  325.         }
  326.     }
  327.     $dxy = $mul eq 'pages' ? ($horz ? $pan->width : $pan->height) : 10
  328.         unless $dxy;
  329.     $XY -= $dxy * $val;
  330.     }
  331.     elsif($cmd eq 'moveto') {
  332.     $XY = -int($WH * $val);
  333.     }
  334.  
  335.     $XY = $wh - $WH
  336.     if($XY < ($wh - $WH));
  337.     $XY = 0
  338.     if $XY > 0;
  339.  
  340.     @a = $horz
  341.     ? ( $XY, $slv->y)
  342.     : ($slv->x, $XY);
  343.  
  344.     $slv->MoveWindow(@a);
  345.  
  346.     $scrl->Call(-$XY / $WH,(-$XY + $wh) / $WH);
  347. }
  348.  
  349. sub see {
  350.     my $pan = shift;
  351.     my $widget = shift;
  352.     my %opt = @_;
  353.     my $slv = $pan->Subwidget('frame');
  354.  
  355.     my $anchor = defined $opt{'-anchor'} ? $opt{'-anchor'} : "";
  356.  
  357.     if($pan->{Configure}{'-yscrollcommand'}) {
  358.     my $yanchor = lc(($anchor =~ /([NnSs]?)/)[0] || "");
  359.     my $pty = $pan->rooty;
  360.     my $ph  = $pan->height;
  361.     my $pby = $pty + $ph;
  362.     my $ty  = $widget->rooty;
  363.     my $wh  = $widget->height;
  364.     my $by  = $ty + $wh;
  365.     my $h   = $slv->ReqHeight;
  366.  
  367.     if($yanchor eq 'n' || ($yanchor ne 's' && ($wh >= $h || $ty < $pty))) {
  368.         my $y = $ty - $slv->rooty;
  369.         $pan->yview(moveto => $y / $h);
  370.     }
  371.     elsif($yanchor eq 's' || $by > $pby) {
  372.         my $y = $by - $ph - $slv->rooty;
  373.         $pan->yview(moveto => $y / $h);
  374.     }
  375.     }
  376.  
  377.     if($pan->{Configure}{'-xscrollcommand'}) {
  378.     my $xanchor = lc(($anchor =~ /([WwEe]?)/)[0] || "");
  379.     my $ptx = $pan->rootx;
  380.     my $pw  = $pan->width;
  381.     my $pbx = $ptx + $pw;
  382.     my $tx  = $widget->rootx;
  383.     my $ww  = $widget->width;
  384.     my $bx  = $tx + $ww;
  385.     my $w   = $slv->ReqWidth;
  386.  
  387.     if($xanchor eq 'w' || ( $xanchor ne 'e' && ($ww >= $w || $tx < $ptx))) {
  388.         my $x = $tx - $slv->rootx;
  389.         $pan->xview(moveto => $x / $w);
  390.     }
  391.     elsif($xanchor eq 'e' || $bx > $pbx) {
  392.         my $x = $bx - $pw - $slv->rootx;
  393.         $pan->xview(moveto => $x / $w);
  394.     }
  395.     }
  396. }
  397.  
  398. 1;
  399.  
  400. __END__
  401.  
  402. =head1 NAME
  403.  
  404. Tk::Pane - A window panner
  405.  
  406. =for category Derived Widgets
  407.  
  408. =head1 SYNOPSIS
  409.  
  410.     use Tk::Pane;
  411.  
  412.     $pane = $mw->Scrolled(Pane, Name => 'fred',
  413.     -scrollbars => 'soe',
  414.     -sticky => 'we',
  415.     -gridded => 'y'
  416.     );
  417.  
  418.     $pane->Frame;
  419.  
  420.     $pane->pack;
  421.  
  422. =head1 DESCRIPTION
  423.  
  424. B<Tk::Pane> provides a scrollable frame widget. Once created it can be
  425. treated as a frame, except it is scrollable.
  426.  
  427. =head1 OPTIONS
  428.  
  429. =over 4
  430.  
  431. =item B<-gridded> =E<gt> I<direction>
  432.  
  433. Specifies if the top and left edges of the pane should snap to a
  434. grid column. This option is only useful if the widgets in the pane
  435. are managed by the I<grid> geometry manager. Possible values are
  436. B<x>, B<y> and B<xy>.
  437.  
  438. =item B<-sticky> =E<gt> I<style>
  439.  
  440. If Pane is larger than its requested dimensions, this option may be used to
  441. position (or stretch) the slave within its cavity. I<Style> is a string that
  442. contains zero or more of the characters n, s, e or w. The string can optionally
  443. contains spaces or commas, but they are ignored. Each letter refers to a side
  444. (north, south, east, or west) that the slave will "stick" to. If both n and s
  445. (or e and w) are specified, the slave will be stretched to fill the entire
  446. height (or width) of its cavity.
  447.  
  448. =back
  449.  
  450. =head1 METHODS
  451.  
  452. =over 4
  453.  
  454. =item I<$pane>-E<gt>B<see>(I<$widget> ?,I<options>?)
  455.  
  456. Adjusts the view so that I<$widget> is visable. Aditional parameters in
  457. I<options-value> pairs can be passed, each I<option-value> pair must be
  458. one of the following
  459.  
  460. =over 8
  461.  
  462. =item B<-anchor> =E<gt> I<anchor>
  463.  
  464. Specifies how to make the widget visable. If not given then as much of
  465. the widget as possible is made visable.
  466.  
  467. Possible values are B<n>, B<s>, B<w>, B<e>, B<nw>, B<ne>, B<sw> and B<se>.
  468. This will cause an edge on the widget to be aligned with the corresponding
  469. edge on the pane. for example B<nw> will cause the top left of the widget
  470. to be placed at the top left of the pane. B<s> will cause the bottom of the
  471. widget to be placed at the bottom of the pane, and as much of the widget
  472. as possible made visable in the x direction.
  473.  
  474. =back
  475.  
  476. =item I<$pane>-E<gt>B<xview>
  477.  
  478. Returns a list containing two elements, both of which are real fractions
  479. between 0 and 1. The first element gives the position of  the left of the
  480. window, relative to the Pane as a whole (0.5 means it is halfway through the
  481. Pane, for example). The second element gives the position of the right of the
  482. window, relative to the Pane as a whole.
  483.  
  484. =item I<$pane>-E<gt>B<xview>(I<$widget>)
  485.  
  486. Adjusts the view in the window so that I<widget> is displayed at the left of
  487. the window.
  488.  
  489. =item I<$pane>-E<gt>B<xview>(B<moveto> =E<gt> I<fraction>)
  490.  
  491. Adjusts the view in the window so that I<fraction> of the total width of the
  492. Pane is off-screen to the left. fraction must be a fraction between 0 and 1.
  493.  
  494. =item I<$pane>-E<gt>B<xview>(B<scroll> =E<gt> I<number>, I<what>)
  495.  
  496. This command shifts the view in the window left or right according to I<number>
  497. and I<what>. I<Number> must be an integer. I<What> must be either B<units> or
  498. B<pages> or an abbreviation of one of these. If I<what> is B<units>, the view
  499. adjusts left or right by I<number>*10 screen units on the display; if it is
  500. B<pages> then the view adjusts by number screenfuls. If number is negative then
  501. widgets farther to the left become visible; if it is positive then widgets
  502. farther to the right become visible.
  503.  
  504. =item I<$pane>-E<gt>B<yview>
  505.  
  506. Returns a list containing two elements, both of which are real fractions
  507. between 0 and 1. The first element gives the position of  the top of the
  508. window, relative to the Pane as a whole (0.5 means it is halfway through the
  509. Pane, for example). The second element gives the position of the bottom of the
  510. window, relative to the Pane as a whole.
  511.  
  512. =item I<$pane>-E<gt>B<yview>(I<$widget>)
  513.  
  514. Adjusts the view in the window so that I<widget> is displayed at the top of the
  515. window.
  516.  
  517. =item I<$pane>-E<gt>B<yview>(B<moveto> =E<gt> I<fraction>)
  518.  
  519. Adjusts the view in the window so that I<fraction> of the total width of the
  520. Pane is off-screen to the top. fraction must be a fraction between 0 and 1.
  521.  
  522. =item I<$pane>-E<gt>B<yview>(B<scroll> =E<gt> I<number>, I<what>)
  523.  
  524. This command shifts the view in the window up or down according to I<number>
  525. and I<what>. I<Number> must be an integer. I<What> must be either B<units> or
  526. B<pages> or an abbreviation of one of these. If I<what> is B<units>, the view
  527. adjusts up or down by I<number>*10 screen units on the display; if it is
  528. B<pages> then the view adjusts by number screenfuls. If number is negative then
  529. widgets farther up become visible; if it is positive then widgets farther down
  530. become visible.
  531.  
  532. =back
  533.  
  534. =head1 AUTHOR
  535.  
  536. Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
  537.  
  538. =head1 COPYRIGHT
  539.  
  540. Copyright (c) 1997-1998 Graham Barr. All rights reserved.
  541. This program is free software; you can redistribute it and/or modify it
  542. under the same terms as Perl itself.
  543.  
  544. =cut
  545.