File Coverage

blib/lib/Tk/TabFrame.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package Tk::TabFrame;
2              
3 1     1   3174 use Tk;
  0            
  0            
4             use Tk::ChildNotification;
5             use Tk::Frame;
6             use Tk::Label;
7              
8             use base qw (Tk::Derived Tk::Frame);
9             use vars qw ($VERSION);
10             use strict;
11             use Carp;
12              
13             $VERSION = '0.01';
14              
15             Tk::Widget->Construct ('TabFrame');
16              
17             sub Populate
18             {
19             my $this = shift;
20              
21             my $l_ButtonFrame = $this->{m_ButtonFrame} = $this->Component
22             (
23             'Frame' => 'ButtonFrame',
24             '-borderwidth' => 0,
25             '-relief' => 'flat',
26             '-height' => 40,
27             );
28              
29             my $l_ClientFrame = $this->{m_ClientFrame} = $this->Component
30             (
31             'TabChildFrame' => 'TabChildFrame',
32             '-relief' => 'flat',
33             '-borderwidth' => 0,
34             '-height' => 60,
35             );
36              
37             my $l_MagicFrame = $this->Component
38             (
39             'Frame' => 'MagicFrame',
40             );
41              
42             $l_ButtonFrame->pack
43             (
44             '-anchor' => 'nw',
45             '-side' => 'top',
46             '-fill' => 'x',
47             );
48              
49             $l_ClientFrame->pack
50             (
51             '-side' => 'top',
52             '-expand' => 'true',
53             '-fill' => 'both',
54             );
55              
56             $this->ConfigSpecs
57             (
58             '-borderwidth' => [['SELF', 'PASSIVE'], 'borderwidth', 'BorderWidth', '1'],
59             '-tabcurve' => [['SELF', 'PASSIVE'], 'tabcurve', 'TabCurve', 2],
60             '-padx' => [['SELF', 'PASSIVE'], 'padx', 'padx', 5],
61             '-pady' => [['SELF', 'PASSIVE'], 'pady', 'pady', 5],
62             '-font' => ['METHOD', 'font', 'Font', undef],
63             '-current' => ['METHOD'],
64             '-raised' => ['METHOD'],
65              
66             # These are historical. Their use is deprecated
67              
68             '-trimcolor' => ['PASSIVE', 'trimcolor','trimcolor', undef],
69             '-bottomedge' => ['PASSIVE', 'bottomedge', 'BottomEdge', undef],
70             '-sideedge' => ['PASSIVE', 'sideedge', 'SideEdge', undef],
71             '-tabstart' => ['PASSIVE', 'tabstart', 'TabStart', undef],
72             );
73              
74             $l_ClientFrame->bind ('' => sub {$this->configure ('-current' => $this->{m_Raised});});
75             $this->Delegates ('Construct' => $l_ClientFrame);
76             $this->SUPER::Populate (@_);
77             return $this;
78             }
79              
80             sub TabCreate
81             {
82             my ($this, $p_Widget, $p_Caption, $p_Color) = (shift, @_);
83              
84             my $l_Previous =
85             (
86             defined (${$this->{m_ClientList}}[-1]) ?
87             $this->{m_ButtonFrame}->Subwidget ('Button_'.${$this->{m_ClientList}}[-1])->Subwidget ('Button') :
88             undef
89             );
90              
91             my $l_TabFrame = $this->{m_ButtonFrame}->Component
92             (
93             'Frame' => 'Button_'.$p_Widget,
94             '-foreground' => $this->cget ('-foreground'),
95             '-relief' => 'flat',
96             '-borderwidth' => 0,
97             );
98              
99             my $l_Button = $l_TabFrame->Component
100             (
101             'Button' => 'Button',
102             '-command' => sub {$this->configure ('-current' => $p_Widget);},
103             (defined ($p_Color) ? ('-bg' => $p_Color) : ()),
104             '-text' => $p_Caption || $p_Widget->name(),
105             '-font' => $this->cget (-font),
106             '-relief' => 'flat',
107             '-borderwidth' => 0,
108             '-takefocus' => 1,
109             '-padx' => 2,
110             '-pady' => 2,
111             );
112              
113             $l_TabFrame->bind ('' => sub {$l_Button->invoke();});
114             $l_Button->bind ('', sub {$l_Button->configure ('-highlightthickness' => 0);});
115             $l_Button->bind ('', sub {$l_Button->configure ('-highlightthickness' => 1);});
116             $l_Button->bind ('', sub {($this->children())[0]->focus();});
117             $l_Button->bind ('' => sub {$l_Button->invoke();});
118              
119             if (defined ($l_Previous))
120             {
121             $l_Button->bind ('', sub {$l_Previous->focus();});
122             $l_Button->bind ('', sub {$l_Previous->invoke();});
123             $l_Previous->bind ('', sub {$l_Button->focus();});
124             $l_Previous->bind ('', sub {$l_Button->invoke();});
125             }
126            
127             $this->TabBorder ($l_TabFrame);
128              
129             $this->{m_ClientFrame}->configure
130             (
131             '-borderwidth' => $this->cget ('-borderwidth'),
132             '-relief' => 'raised',
133             );
134              
135             $l_Button->configure
136             (
137             '-highlightcolor' => $l_Button->Darken ($l_Button->cget (-background), 50),
138             '-activebackground' => $l_Button->cget (-background),
139             );
140              
141             $l_Button->pack
142             (
143             '-expand' => 'true',
144             '-fill' => 'both',
145             '-ipadx' => 0,
146             '-ipady' => 0,
147             '-padx' => 3,
148             '-pady' => 3,
149             );
150              
151             $l_TabFrame->place
152             (
153             '-width' => ($l_Button->reqwidth() || 20) + 5,
154             '-x' => $this->GetButtonRowWidth(),
155             '-relheight' => 1.0,
156             '-anchor' => 'nw',
157             );
158              
159             $this->{m_ButtonFrame}->GeometryRequest
160             (
161             $this->{m_ButtonFrame}->width(),
162             $this->GetButtonRowHeight() + 5,
163             );
164              
165             push (@{$this->{m_ClientList}}, $p_Widget);
166             return $this->TabCurrent ($p_Widget);
167             }
168              
169             sub TabRaise
170             {
171             my ($this, $p_Widget) = (shift, @_);
172              
173             my $l_ButtonFrame = $this->{m_ButtonFrame};
174             my $l_TabFrame = $l_ButtonFrame->Subwidget ('Button_'.$p_Widget);
175             my $l_MagicFrame = $this->Subwidget ('MagicFrame');
176             my %l_Hash = $l_TabFrame->placeInfo();
177              
178             foreach my $l_Client (@{$this->{m_ClientList}})
179             {
180             if ($l_Client ne $p_Widget)
181             {
182             my $l_TabButton = $l_ButtonFrame->Subwidget ('Button_'.$l_Client);
183             $l_TabButton->place ('-height' => - 5, '-y' => 5);
184             $l_TabButton->lower ($l_TabFrame);
185             }
186             }
187              
188             $l_MagicFrame->place
189             (
190             '-x' => $l_Hash {'-x'},
191             '-y' => $this->{m_ClientFrame}->rooty() - $this->rooty() - 1,
192             '-height' => $this->{m_ClientFrame}->cget ('-borderwidth'),
193             '-width' => $l_Hash {'-width'},
194             '-anchor' => 'nw',
195             );
196              
197             $l_MagicFrame->configure ('-bg' => $l_TabFrame->cget ('-background'));
198             $l_TabFrame->place ('-height' => - 1, '-y' => 1);
199             $l_TabFrame->Subwidget ('Button')->focus();
200             $l_TabFrame->Subwidget ('Button')->raise();
201             $l_MagicFrame->raise ();
202             $l_TabFrame->raise();
203              
204             foreach my $l_Sibling ($p_Widget->parent()->children())
205             {
206             $l_Sibling->lower ($p_Widget) if ($l_Sibling ne $p_Widget);
207             }
208              
209             $p_Widget->raise();
210             return $p_Widget;
211             }
212              
213             sub TabBorder
214             {
215             my ($this, $p_TabFrame) = (shift, @_);
216             my $l_LineWidth = $this->cget ('-borderwidth');
217             my $l_Background = $this->cget ('-background');
218             my $l_InnerBackground = $p_TabFrame->Darken ($l_Background, 120),
219             my $l_Curve = $this->cget ('-tabcurve');
220              
221             my $l_LeftOuterBorder = $p_TabFrame->Frame
222             (
223             '-background' => 'white',
224             '-borderwidth' => 0,
225             );
226              
227             my $l_LeftInnerBorder = $p_TabFrame->Frame
228             (
229             '-background' => $l_InnerBackground,
230             '-borderwidth' => 0,
231             );
232              
233             my $l_TopOuterBorder = $p_TabFrame->Frame
234             (
235             '-background' => 'white',
236             '-borderwidth' => 0,
237             );
238              
239             my $l_TopInnerBorder = $p_TabFrame->Frame
240             (
241             '-background' => $l_InnerBackground,
242             '-borderwidth' => 0,
243             );
244              
245             my $l_RightOuterBorder = $p_TabFrame->Frame
246             (
247             '-background' => 'black',
248             '-borderwidth' => 0,
249             );
250              
251             my $l_RightInnerBorder = $p_TabFrame->Frame
252             (
253             '-background' => $p_TabFrame->Darken ($l_Background, 80),
254             '-borderwidth' => 0,
255             );
256              
257             $l_LeftOuterBorder->place
258             (
259             '-x' => 0,
260             '-y' => $l_Curve - 1,
261             '-width' => $l_LineWidth,
262             '-relheight' => 1.0,
263             );
264              
265             $l_LeftInnerBorder->place
266             (
267             '-x' => $l_LineWidth,
268             '-y' => $l_Curve - 1,
269             '-width' => $l_LineWidth,
270             '-relheight' => 1.0,
271             );
272              
273             $l_TopInnerBorder->place
274             (
275             '-x' => $l_Curve - 1,
276             '-y' => $l_LineWidth,
277             '-relwidth' => 1.0,
278             '-height' => $l_LineWidth,
279             '-width' => - ($l_Curve * 2),
280             );
281              
282             $l_TopOuterBorder->place
283             (
284             '-x' => $l_Curve - 1,
285             '-y' => 0,
286             '-relwidth' => 1.0,
287             '-height' => $l_LineWidth,
288             '-width' => - ($l_Curve * 2),
289             );
290              
291             $l_RightOuterBorder->place
292             (
293             '-x' => - ($l_LineWidth),
294             '-relx' => 1.0,
295             '-width' => $l_LineWidth,
296             '-relheight' => 1.0,
297             '-y' => $l_Curve,
298             );
299              
300             $l_RightInnerBorder->place
301             (
302             '-x' => - ($l_LineWidth * 2),
303             '-width' => $l_LineWidth,
304             '-relheight' => 1.0,
305             '-y' => $l_Curve / 2,
306             '-relx' => 1.0,
307             );
308             }
309              
310             sub TabCurrent
311             {
312             return
313             (
314             defined ($_[1]) ?
315             $_[0]->TabRaise ($_[0]->{m_Raised} = $_[1]) :
316             $_[0]->{m_Raised}
317             );
318             }
319              
320             sub GetButtonRowWidth
321             {
322             my ($l_Width, $this) = (0, shift, @_);
323             my $l_ButtonFrame = $this->{m_ButtonFrame};
324              
325             foreach my $l_Client (@{$this->{m_ClientList}})
326             {
327             $l_Width += $l_ButtonFrame->Subwidget ('Button_'.$l_Client)->Subwidget ('Button')->reqwidth();
328             }
329              
330             return $l_Width ? $l_Width - 10 : $l_Width;
331             }
332              
333             sub GetButtonRowHeight
334             {
335             my ($l_Height, $this) = (0, shift, @_);
336             my $l_ButtonFrame = $this->{m_ButtonFrame};
337              
338             foreach my $l_Client (@{$this->{m_ClientList}})
339             {
340             my $l_NewHeight = $l_ButtonFrame->Subwidget ('Button_'.$l_Client)->Subwidget ('Button')->reqheight();
341             $l_Height = $l_NewHeight if ($l_NewHeight > $l_Height);
342             }
343              
344             return $l_Height;
345             }
346              
347             sub Font
348             {
349             my ($this, $p_Font) = (shift, @_);
350              
351             return ($this->{m_Font}) unless (defined ($p_Font));
352              
353             my $l_ButtonFrame = $this->{m_ButtonFrame};
354              
355             foreach my $l_Client (@{$this->{m_ClientList}})
356             {
357             $l_ButtonFrame->Subwidget ('Button_'.$l_Client)->Subwidget ('Button')->configure
358             (
359             '-font' => $p_Font,
360             );
361             }
362              
363             return ($this->{m_Font} = $p_Font);
364             }
365              
366             sub current
367             {
368             shift->TabCurrent (@_);
369             }
370              
371             sub raised
372             {
373             shift->TabCurrent (@_);
374             }
375              
376             sub font
377             {
378             shift->Font (@_);
379             }
380              
381             1;
382              
383             package Tk::TabChildFrame;
384              
385             use Tk::ChildNotification;
386             use Tk;
387              
388             use vars qw ($VERSION @ISA);
389              
390             use strict;
391              
392             $VERSION = '1.01';
393              
394             @ISA = qw (Tk::Widget Tk::Frame);
395              
396             Tk::Widget->Construct ('TabChildFrame');
397              
398             sub Populate
399             {
400             my ($this, $p_Parameters) = (shift, @_);
401              
402             $this->SUPER::Populate (@_);
403              
404             return $this;
405             }
406              
407             sub QueueLayout
408             {
409             $_[0]->DoWhenIdle (['ExecuteLayout', $_[0]]) unless ($_[0]->{'LayoutPending'}++);
410             }
411              
412             sub SlaveGeometryRequest
413             {
414             shift->QueueLayout();
415             }
416              
417             sub LostSlave
418             {
419             shift->QueueLayout();
420             }
421              
422             sub ExecuteLayout
423             {
424             my $this = shift;
425              
426             $this->{'LayoutPending'} = 0;
427              
428             my $l_PadX = $this->parent()->cget ('-padx');
429             my $l_PadY = $this->parent()->cget ('-pady');
430             my $l_Height = 0;
431             my $l_Width = 0;
432              
433             foreach my $l_Child ($this->children())
434             {
435             next unless Exists ($l_Child);
436              
437             my @l_Dimensions =
438             (
439             $l_Child->reqwidth(),
440             $l_Child->reqheight(),
441             );
442              
443             $l_Height = $l_Dimensions [1] if ($l_Dimensions [1] > $l_Height);
444             $l_Width = $l_Dimensions [0] if ($l_Dimensions [0] > $l_Width);
445             }
446              
447             foreach my $l_Child ($this->children())
448             {
449             next unless Exists ($l_Child);
450              
451             $l_Child->MoveResizeWindow
452             (
453             $l_PadX,
454             $l_PadY,
455             $l_Width,
456             $l_Height,
457             );
458              
459             $l_Child->MapWindow();
460             }
461              
462             $this->GeometryRequest
463             (
464             $l_Width + ($l_PadX * 2),
465             $l_Height + ($l_PadY * 2),
466             );
467             }
468              
469             sub ChildNotification
470             {
471             my ($this, $p_Child, $p_Arguments) = (shift, @_);
472              
473             $p_Child->packForget();
474              
475             $this->ManageGeometry ($p_Child);
476              
477             $this->parent()->TabCreate
478             (
479             $p_Child,
480             delete $p_Arguments->{'-caption'},
481             delete $p_Arguments->{'-tabcolor'},
482             );
483             }
484              
485             1;
486              
487             __END__