home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / VStack.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  6.7 KB  |  279 lines
  1. # $Id: VStack.pm,v 1.4 1997/02/08 19:12:36 rsi Exp $
  2. #
  3. # Virtual base class needed to implement the NoteBook widget. This should
  4. # not be used directly by the application programmer.
  5. #
  6. # Derived from VStack.tcl in Tix 4.0
  7.  
  8. package Tk::VStack;
  9. require Tk::Frame;
  10.  
  11. use strict;
  12. use Carp;
  13.  
  14. @Tk::VStack::ISA = qw(Tk::Frame);
  15.  
  16. sub Populate {
  17.     my ($w, $args) = @_;
  18.  
  19.     $w->SUPER::Populate($args);
  20.     $w->{"pad-x1"} = 0;
  21.     $w->{"pad-x2"} = 0;
  22.     $w->{"pad-y1"} = 0;
  23.     $w->{"pad-y2"} = 0;
  24.  
  25.     $w->{"nWindows"} = 0;
  26.     $w->{"minH"} = 1;
  27.     $w->{"minW"} = 1;
  28.     
  29.     $w->{"top"} = $w;
  30.     $w->{"counter"} = 0;
  31.     $w->{"resize"} = 0;
  32.  
  33.     $w->ConfigSpecs(-ipadx => ["PASSIVE", "ipadX", "Pad", 0],
  34.             -ipady => ["PASSIVE", "ipadY", "Pad", 0],
  35.             -dynamicgeometry => ["PASSIVE", "dynamicGeometry", "DynamicGeometry", 0]);
  36.  
  37.     # SetBindings
  38.     $w->bind("<Configure>", sub {$w->MasterGeomProc;});
  39.     $w->{"top"}->bind("<Destroy>", sub {$w->DestroyTop;});
  40.  
  41.     $w->QueueResize;
  42. }
  43.  
  44. sub add {
  45.     my ($w, $child, %args) = @_;
  46.  
  47.     my $f = $w->Frame(Name => $child);
  48.     $f->configure(-relief => "raised");
  49.     $f->{-raisecmd} = $args{-raisecmd} if (defined $args{-raisecmd});
  50.     $f->{-createcmd} = $args{-createcmd} if (defined $args{-createcmd});
  51.  
  52.     # manage our geometry
  53.     $w->ManageGeometry($f);
  54.     # create default bindings
  55.     $f->bind("<Configure>", sub {$w->ClientGeomProc('-configure', $f)});
  56.     $f->bind("<Destroy>", sub {$w->delete($child);}); # XXX
  57.     $w->{$child} = $f;
  58.     $w->{"nWindows"}++;
  59.     push(@{$w->{"windows"}}, $child);
  60.     
  61.     return $f;
  62. }
  63.  
  64. sub delete {
  65.     my ($w, $child) = @_;
  66.  
  67.     if (defined $w->{$child}) {
  68.     # see if the child to be deleted was the top child
  69.     if ($w->{"topchild"} eq $child) {
  70.         foreach (@{$w->{"windows"}}) {
  71.         if ($_ !~ /$child/) {
  72.             $w->raise ( $_  );
  73.             $w->{"topchild"} = $_;
  74.             next;
  75.         }
  76.         }
  77.     }
  78.     $w->{$child}->bind("<Destroy>", undef);
  79.     $w->{$child}->destroy;
  80.     
  81.     @{$w->{"windows"}} = grep($_ !~ /$child/, @{$w->{"windows"}});
  82.     # if $w->{'windows'} is empty then set topchild to null
  83.     if ( $#{$w->{'windows'}} == -1 ) {
  84.         $w->{'topchild'} = undef;
  85.     }
  86.     $w->{"nWindows"}--;
  87.     delete $w->{$child};
  88.     } else {
  89.     carp "page $child does not exist";
  90.     }
  91. }
  92.  
  93. sub pagecget {
  94.     my ($w, $child, $opt) = @_;
  95.  
  96.     if (defined $w->{$child}) {
  97.     return $w->{$child}->{-createcmd} if ($opt =~ /-createcmd/);
  98.     return $w->{$child}->{-raisecmd} if ($opt =~ /-raisecmd/);
  99.     return $w->{"top"}->pagecget($child, $opt);
  100.     } else {
  101.     carp "page $child does not exist";
  102.     }
  103. }
  104.  
  105. sub pageconfigure {
  106.     my ($w, $child, %args) = @_;
  107.  
  108.     if (defined $w->{$child}) {
  109.     my $ccmd = delete $args{-createcmd};
  110.     my $rcmd = delete $args{-raisecmd};
  111.     $w->{-createcmd} = $ccmd if (defined $ccmd);
  112.     $w->{-raisecmd} = $rcmd if (defined $rcmd);
  113.     if (keys %args) {
  114.         $w->{"top"}->pageconfigure($child, %args);
  115.     }
  116.     }
  117. }
  118.  
  119. sub pages {
  120.     my ($w) = @_;
  121.  
  122.     return @{$w->{"windows"}};
  123. }
  124.  
  125. sub raise {
  126.     my ($w, $child) = @_;
  127.  
  128.     if (defined $w->{$child}) {
  129.     if (defined $w->{$child}->{-createcmd}) {
  130.         &{$w->{$child}->{-createcmd}}($w->{$child});
  131.         delete $w->{$child}->{-createcmd};
  132.     }
  133.     # hide the original visible window
  134.     if (defined $w->{"topchild"} && ($w->{"topchild"} ne $child)) {
  135.         $w->{$w->{"topchild"}}->UnmapWindow;
  136.     }
  137.     my $oldtop = $w->{"topchild"};
  138.     $w->{"topchild"} = $child;
  139.     my $myW = $w->winfo("width");
  140.     my $myH = $w->winfo("height");
  141.  
  142.     my $cW = $myW - $w->{"pad-x1"} - $w->{"pad-x2"} - 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  143.     my $cH = $myH - $w->{"pad-y1"} - $w->{"pad-y2"} - 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
  144.     my $cX = $w->{"pad-x1"} + (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  145.     my $cY = $w->{"pad-y1"} + (defined $w->{-ipady} ? $w->{-ipady} : 0);
  146.  
  147.     if ($cW > 0 && $cH > 0) {
  148.         $w->{$child}->MoveResizeWindow($cX, $cY, $cW, $cH);
  149.         $w->{$child}->MapWindow;
  150.         $w->{$child}->raise;
  151.     }
  152.     if ((not defined $oldtop) || ($oldtop ne $child)) {
  153.         if (defined $w->{$child}->{-raisecmd}) {
  154.         &{$w->{$child}->{-raisecmd}}($w->{$child});
  155.         }
  156.     }
  157.     }
  158. }
  159.  
  160. sub raised {
  161.     my ($w) = @_;
  162.     return $w->{"topchild"};
  163. }
  164.  
  165. # ------
  166. # Private routines
  167. # ------
  168. sub DestroyTop {
  169.     my ($w) = @_;
  170.     eval { $w->destroy; }
  171. }
  172.  
  173. sub MasterGeomProc {
  174.     my ($w, %args) = @_;
  175.     if ($w->winfo("exists")) {
  176.     if (not defined $w->{"resize"}) {
  177.         $w->{"resize"} = 0;
  178.     }
  179.     $w->QueueResize;
  180.     }
  181. }
  182.  
  183. sub SlaveGeometryRequest {
  184.     my $w = shift;
  185.     if ($w->winfo("exists")) {
  186.     $w->QueueResize;
  187.     }
  188. }
  189.  
  190. sub LostSlave {
  191.     my ($w, $s) = @_;
  192.     $s->UnmapWindow;
  193. }
  194.  
  195. sub ClientGeomProc {
  196.     my ($w, $flag, $client) = @_;
  197.  
  198.     if ($w->winfo("exists")) {
  199.     $w->QueueResize;
  200.     }
  201.     if ($flag =~ /-lostslave/) {
  202.     carp "Geometry Management Error: Another geometry manager has taken control of $client. This error is usually caused because a widget has been created in the wrong frame: it should have been created inside $client instead of $w";
  203.     
  204.     }
  205. }
  206.  
  207. sub QueueResize {
  208.     my $w = shift;
  209.     $w->DoWhenIdle(['Resize', $w]) unless ($w->{"resize"}++);
  210. }
  211.  
  212. sub Resize {
  213.     my ($w) = @_;
  214.     my $top;
  215.     my $reqW = 0;
  216.     my $reqH = 0;
  217.  
  218.     return if ((!$w->winfo("exists")) || (!$w->{"nWindows"}) || (!$w->{"resize"}));
  219.     $w->{"resize"} = 0;
  220.     $reqW = $w->{-width} if (defined $w->{-width});
  221.     $reqH = $w->{-height} if (defined $w->{-height});
  222.  
  223.     if ($reqW * $reqH == 0) {
  224.     if ((not defined $w->{-dynamicgeometry}) ||
  225.         ($w->{-dynamicgeometry} == 0)) {
  226.         my $child = '';
  227.         $reqW = 1;
  228.         $reqH = 1;
  229.         
  230.         foreach $child (@{$w->{"windows"}}) {
  231.         my $cW = $w->{$child}->winfo("reqwidth");
  232.         my $cH = $w->{$child}->winfo("reqheight");
  233.         $reqW = ($reqW > $cW) ? $reqW : $cW;
  234.         $reqH = ($reqH > $cH) ? $reqH : $cH;
  235.         }
  236.     } else {
  237.         if (defined $w->{"topchild"}) {
  238.         $reqW = $w->{"topchild"}->winfo("reqwidth");
  239.         $reqH = $w->{"topchild"}->winfo("reqheight");
  240.         } else {
  241.         $reqW = 1;
  242.         $reqH = 1;
  243.         }
  244.     }
  245.     $reqW += $w->{"pad-x1"} + $w->{"pad-x2"} + 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  246.     $reqH += $w->{"pad-y1"} + $w->{"pad-y2"} + 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
  247.     $reqW = ($reqW > $w->{"minW"}) ? $reqW : $w->{"minW"};
  248.     $reqH = ($reqH > $w->{"minH"}) ? $reqH : $w->{"minH"};
  249.     }
  250.     if (($w->winfo("reqwidth") != $reqW) ||
  251.     ($w->winfo("reqheight") != $reqH)) {
  252.     $w->{"counter"} = 0 if (not defined $w->{"counter"});
  253.     if ($w->{"counter"} < 50) {
  254.         $w->{"counter"}++;
  255.         $w->GeometryRequest($reqW, $reqH);
  256.         $w->DoWhenIdle(sub {$w->Resize;});
  257.         $w->{"resize"} = 1;
  258.         return;
  259.     }
  260.     }
  261.     $w->{"counter"} = 0;
  262.     if ($w->{"top"} != $w) {
  263.     $w->{"top"}->MoveResizeWindow(0, 0, $w->winfo("width"), $w->winfo("height"));
  264.     $w->{"top"}->MapWindow;
  265.     }
  266.     if (not defined $w->{"topchild"}) {
  267.     $top = ${$w->{"windows"}}[0];
  268.     } else {
  269.     $top = $w->{"topchild"};
  270.     }
  271.     $w->raise($top);
  272.     $w->{"resize"} = 0;
  273. }
  274.  
  275. 1;
  276.  
  277. __END__
  278.     
  279.