1#!/usr/local/bin/perl -w
2
3use Tk;
4
5{
6 package Packer;
7use base  qw(Tk::Frame);
8 Construct Tk::Widget 'Packer';
9
10 sub new
11  {my $class  = shift;
12   my $parent = shift;
13   my $obj = $parent->Frame('-class' => Packer);
14   $obj->{Slaves} = [];
15   $obj->{LayoutPending} = 0;
16   bless $obj,$class;
17  }
18
19 sub Layout
20 {
21  my $m = shift;
22  $m->{LayoutPending} = 0;
23  my $w = 0;
24  my $h = 0;
25  my $x = 0;
26  my $y = 0;
27  my $s;
28  # find size of largest slave
29  foreach $s (@{$m->{Slaves}})
30   {
31    my $sw = $s->ReqWidth;
32    my $sh = $s->ReqHeight;
33    $w = $sw if ($sw > $w);
34    $h = $sh if ($sh > $h);
35   }
36  # Set size and position of slaves
37  foreach $s (@{$m->{Slaves}})
38   {
39    $s->MoveResizeWindow($x,$y,$w,$h);
40    $s->MapWindow;
41    $y += $h;
42   }
43  # Now ask for enough space
44  $m->GeometryRequest($w,$y);
45 }
46
47 sub QueueLayout
48 {
49  my $m = shift;
50  $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending}++);
51 }
52
53 sub SlaveGeometryRequest
54 {
55  shift->QueueLayout;
56 }
57
58 sub LostSlave
59 {
60  my ($m,$s) = @_;
61  @{$m->{Slaves}} = grep($_ != $s,@{$m->{Slaves}});
62  $m->QueueLayout;
63 }
64
65 sub Manage
66 {
67  my ($m,$s) = @_;
68  $m->ManageGeometry($s);
69  push(@{$m->{Slaves}},$s);
70  $m->QueueLayout;
71 }
72
73}
74
75$top = MainWindow->new();
76
77$packer = $top->Packer();
78
79$var = "This can grow";
80
81$one  = $top->Label('-text' => 'Label One');
82
83$packer->Manage($one);
84$packer->Manage($packer->Label('-textvariable' => \$var));
85$packer->Manage($packer->Label('-text' => 'A Very Long Label'));
86
87$packer->pack;
88
89$top->Button('-text' => 'Grow', '-command' => sub { $var .= " more" })->pack;
90$top->Button('-text' => 'Loose', '-command' => [ 'pack' , $one])->pack;
91$top->Button('-text' => 'Add', '-command' => [
92   sub
93   {
94    my $packer = shift;
95     $packer->Manage($packer->Label('-text' => 'Added thing'));
96   }, $packer ])->pack;
97  $top->Button('-text' => 'Quit', '-command' => [ 'destroy' , $top ])->pack;
98
99MainLoop;
100