File Coverage

blib/lib/Tk/SplitFrame.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             ######################################################################
2             # Modified on January 4, 1998 to correct order of insertion problem #
3             # Modified on January 7, 1998 to add slider decoration #
4             # Modified on January 9, 1998 to correct color name problem #
5             # Modified on January 27, 1998 to correct inaccurate border layout #
6             # Modified on January 27, 1998 to use proper notify method overload #
7             # Modified on January 27, 1998 added -padafter and -padbefore params #
8             # for controlling size of inner widget #
9             # Modified on April 6, 1998 Incorporated into release library #
10             ######################################################################
11             # THIS IS THE CORRECT ONE #
12             ######################################################################
13              
14             package Tk::SplitFrame;
15              
16 1     1   2477 use Tk;
  0            
  0            
17             use Tk::ChildNotification;
18             use Tk::Derived;
19             use Tk::Widget;
20             use Tk::Frame;
21              
22             use base qw (Tk::Derived Tk::Widget Tk::Frame);
23             use vars qw ($VERSION);
24             use strict;
25             use Carp;
26              
27             $VERSION = '0.02';
28              
29             Tk::Widget->Construct ('SplitFrame');
30              
31             sub Populate
32             {
33             my ($this) = (shift, @_);
34              
35             $this->SUPER::Populate (@_);
36              
37             my $l_LastBorder = $this->Component
38             (
39             'Frame' => 'LastBorder',
40             '-relief' => 'sunken',
41             );
42              
43             my $l_FirstBorder = $this->Component
44             (
45             'Frame' => 'FirstBorder',
46             '-relief' => 'sunken',
47             );
48              
49             my $l_Slider = $this->Component
50             (
51             'Frame' => 'Slider',
52             '-relief' => 'sunken',
53             '-borderwidth' => 0,
54             '-relief' => 'flat',
55             );
56              
57             $l_Slider->bind ('' => sub {$this->SliderReleased();});
58             $l_Slider->bind ('' => sub {$this->SliderClicked();});
59             $l_Slider->bind ('' => sub {$this->SliderMoved();});
60             $this->bind ('' => sub {$this->Redraw();});
61             $this->bind ('' => sub {$this->Redraw();});
62              
63             $this->Advertise (FirstBorder => $l_FirstBorder);
64             $this->Advertise (LastBorder => $l_LastBorder);
65             $this->Advertise (Slider => $l_Slider);
66              
67             my $l_BaseColor = $this->cget ('-background');
68              
69             $this->ConfigSpecs
70             (
71             '-orientation' => [['SELF', 'PASSIVE'], 'orientation', 'Orientation', 'vertical'],
72             '-trimcolor' => [['SELF', 'PASSIVE'], 'trimcolor','trimcolor', $l_BaseColor],
73             '-background' => ['SELF','background', 'Background', $l_BaseColor],
74             '-borderwidth' => ['METHOD', 'borderwidth', 'BorderWidth', 2],
75             '-sliderposition' => ['METHOD', 'sliderposition', 'SliderPosition', 60],
76             '-sliderwidth' => [['SELF', 'PASSIVE'], 'SliderWidth', 'SliderWidth', 7],
77             '-relief' => [['SELF', 'PASSIVE'], 'relief', 'Relief', 'flat'],
78             '-height' => [['SELF', 'PASSIVE'], 'height', 'Height', 100],
79             '-width' => [['SELF', 'PASSIVE'], 'width', 'Width', 100],
80             '-opaque' => [['SELF', 'PASSIVE'], 'opaque', 'Opaque', 1],
81             '-trimcount' => [['SELF', 'PASSIVE'], 'trimCount', 'TrimCount', 5],
82             '-padbefore' => [['SELF', 'PASSIVE'], 'padbefore', 'PadBefore', 0],
83             '-padafter' => [['SELF', 'PASSIVE'], 'padafter', 'PadAfter', 0],
84             );
85              
86             return $this;
87             }
88              
89             sub Redraw
90             {
91             my ($l_Cursor, $this) = (undef, shift, @_);
92              
93             my ($l_FirstClient, $l_LastClient) = @{$this->{m_ClientList}};
94             my $l_FirstBorderWidth = $this->cget ('-borderwidth');
95             my $l_LastBorderWidth = $this->cget ('-borderwidth');
96             my $l_Foreground = $this->cget ('-trimcolor');
97             my $l_Background = $this->cget ('-background');
98             my $l_FirstBorder = $this->Subwidget ('FirstBorder');
99             my $l_LastBorder = $this->Subwidget ('LastBorder');
100             my $l_Slider = $this->Subwidget ('Slider');
101             my $l_Position = $this->cget ('-sliderposition');
102             my $l_SliderWidth = $this->cget ('-sliderwidth');
103             my @l_FirstDimensions = (0, 0, 0, 0);
104             my @l_LastDimensions = (0, 0, 0, 0);
105             my $l_Height = $this->height();
106             my $l_Width = $this->width();
107              
108             $l_FirstBorder->configure
109             (
110             '-borderwidth' => $l_FirstBorderWidth,
111             '-background' => $l_Foreground,
112             );
113              
114             $l_LastBorder->configure
115             (
116             '-borderwidth' => $l_LastBorderWidth,
117             '-background' => $l_Foreground,
118             );
119              
120             if ($l_FirstClient->class() eq $this->class())
121             {
122             $l_FirstBorder->configure ('-borderwidth' => 0, '-relief' => 'flat');
123             $l_FirstBorderWidth = 0;
124             }
125              
126             if ($l_LastClient->class() eq $this->class())
127             {
128             $l_LastBorder->configure ('-borderwidth' => 0, '-relief' => 'flat');
129             $l_LastBorderWidth = 0;
130             }
131              
132             if ($this->cget ('-orientation') eq 'vertical')
133             {
134             $l_Slider->place
135             (
136             '-x' => $l_Position,
137             '-y' => 0,
138             '-width' => $l_SliderWidth,
139             '-height' => $l_Height,
140             );
141              
142             $l_FirstBorder->place
143             (
144             '-x' => $l_FirstDimensions [0] = 0,
145             '-y' => $l_FirstDimensions [1] = 0,
146             '-width' => $l_FirstDimensions [2] = $l_Position,
147             '-height' => $l_FirstDimensions [3] = $l_Height,
148             );
149              
150             $l_LastBorder->place
151             (
152             '-x' => $l_LastDimensions [0] = $l_Position + $l_SliderWidth,
153             '-y' => $l_LastDimensions [1] = 0,
154             '-width' => $l_LastDimensions [2] = $l_Width - ($l_Position + $l_SliderWidth),
155             '-height' => $l_LastDimensions [3] = $l_Height,
156             );
157              
158             $l_Cursor = 'sb_h_double_arrow';
159             }
160             else
161             {
162             $l_Slider->place
163             (
164             '-x' => 0,
165             '-y' => $l_Position,
166             '-width' => $l_Width,
167             '-height' => $l_SliderWidth,
168             );
169              
170             $l_FirstBorder->place
171             (
172             '-x' => $l_FirstDimensions [0] = 0,
173             '-y' => $l_FirstDimensions [1] = 0,
174             '-width' => $l_FirstDimensions [2] = $l_Width,
175             '-height' => $l_FirstDimensions [3] = $l_Position,
176             );
177              
178             $l_LastBorder->place
179             (
180             '-x' => $l_LastDimensions [0] = 0,
181             '-y' => $l_LastDimensions [1] = $l_Position + $l_SliderWidth,
182             '-width' => $l_LastDimensions [2] = $l_Width,
183             '-height' => $l_LastDimensions [3] = $l_Height - ($l_Position + $l_SliderWidth),
184             );
185              
186             $l_Cursor = 'sb_v_double_arrow';
187             }
188              
189             if (Exists ($l_FirstClient))
190             {
191             $this->Advertise (FirstClient => $l_FirstClient);
192             $this->Advertise (LastClient => $l_FirstClient);
193             $l_FirstClient->packForget();
194              
195             $l_FirstClient->place
196             (
197             '-x' => $l_FirstDimensions [0] + $l_FirstBorderWidth,
198             '-y' => $l_FirstDimensions [1] + $l_FirstBorderWidth,
199             '-width' => $l_FirstDimensions [2] - ($l_FirstBorderWidth * 2),
200             '-height' => $l_FirstDimensions [3] - ($l_FirstBorderWidth * 2),
201             );
202              
203             $l_FirstClient->GeometryRequest
204             (
205             $l_FirstDimensions [2] - ($l_FirstBorderWidth * 2),
206             $l_FirstDimensions [3] - ($l_FirstBorderWidth * 2),
207             );
208             }
209              
210             if (Exists ($l_LastClient))
211             {
212             $this->Advertise (LastClient => $l_LastClient);
213              
214             $l_LastClient->packForget();
215              
216             $l_LastClient->place
217             (
218             '-x' => $l_LastDimensions [0] + $l_LastBorderWidth,
219             '-y' => $l_LastDimensions [1] + $l_LastBorderWidth,
220             '-width' => $l_LastDimensions [2] - ($l_LastBorderWidth * 2),
221             '-height' => $l_LastDimensions [3] - ($l_LastBorderWidth * 2),
222             );
223              
224             $l_LastClient->GeometryRequest
225             (
226             $l_LastDimensions [2] - ($l_LastBorderWidth * 2),
227             $l_LastDimensions [3] - ($l_LastBorderWidth * 2),
228             );
229             }
230              
231             $l_Slider->configure
232             (
233             '-background' => $l_Foreground,
234             '-cursor' => $l_Cursor,
235             );
236              
237             $this->RedrawTrim();
238             }
239              
240             sub SliderClicked
241             {
242             my ($this) = (shift, @_);
243              
244             if ((my $l_Slider = $this->Subwidget ('Slider'))->IsMapped())
245             {
246             $l_Slider->{m_Offset} =
247             (
248             $this->cget ('-orientation') eq 'vertical' ?
249             $l_Slider->pointerx() - $l_Slider->rootx() :
250             $l_Slider->pointery() - $l_Slider->rooty()
251             );
252             }
253             }
254              
255             sub SliderMoved
256             {
257             my ($this) = (shift, @_);
258              
259             if ((my $l_Slider = $this->Subwidget ('Slider'))->IsMapped())
260             {
261             my $l_BorderWidth = ($this->cget ('-borderwidth') || 1) * 2;
262             my $l_Vertical = $this->cget ('-orientation') eq 'vertical';
263             my $l_PadBefore = $this->cget ('-padbefore');
264             my $l_PadAfter = $this->cget ('-padafter');
265              
266             my $l_Limit =
267             (
268             $l_Vertical ?
269             $this->width() :
270             $this->height()
271             ) - ($l_PadAfter + $l_BorderWidth);
272              
273             my $l_Position =
274             (
275             $l_Vertical ?
276             $this->pointerx() - $this->rootx() :
277             $this->pointery() - $this->rooty()
278             );
279              
280             if ($l_Position > $l_Limit)
281             {
282             $l_Position = $l_Limit;
283             }
284             elsif ($l_Position < $l_BorderWidth + $l_PadBefore)
285             {
286             $l_Position = $l_BorderWidth + $l_PadBefore;
287             }
288              
289             $this->configure
290             (
291             '-sliderposition' => $l_Position - $l_Slider->{m_Offset}
292             );
293            
294             $this->Redraw() if ($this->cget ('-opaque'));
295             }
296             }
297              
298             sub SliderReleased()
299             {
300             $_[0]->Redraw() if (! $_[0]->cget ('-opaque'));
301             }
302              
303             sub RedrawTrim
304             {
305             my $this = shift;
306              
307             if (Exists (my $l_Slider = $this->Subwidget ('Slider')))
308             {
309             my $l_Horizontal = $this->cget ('-orientation') eq 'vertical' ? 0 : 1;
310             my $l_Count = $this->cget ('-trimcount');
311              
312             for (my $l_Index = 0; $l_Index < $l_Count && $l_Count >= 0; ++$l_Index)
313             {
314             my $l_Widget;
315              
316             if (! Exists ($l_Widget = $l_Slider->Subwidget ('Trim_'.$l_Index)))
317             {
318             $l_Widget = $l_Slider->Component
319             (
320             'Frame' => 'Trim_'.$l_Index,
321             '-borderwidth' => 2,
322             '-relief' => 'raised',
323             '-width' => ($l_Horizontal ? 25 : 2),
324             '-height' => ($l_Horizontal ? 2 : 25),
325             '-background' => 'white',
326             );
327              
328             $l_Widget->bind ('' => sub {$this->SliderClicked();});
329             $l_Widget->bind ('' => sub {$this->SliderMoved();});
330             }
331              
332             my $l_Where = (($l_Index - int ($l_Count / 2)) * 3) + 1;
333              
334             $l_Widget->place
335             (
336             '-relx' => 0.5,
337             '-rely' => 0.5,
338             '-x' => ($l_Horizontal ? 0 : $l_Where),
339             '-y' => ($l_Horizontal ? $l_Where : 0),
340             '-anchor' => 'center',
341             );
342             }
343              
344             $l_Slider->raise();
345             }
346             }
347              
348             sub borderwidth
349             {
350             my ($this, $p_BorderWidth) = (shift, @_);
351             $this->{m_BorderWidth} = $p_BorderWidth if (defined ($p_BorderWidth));
352             return $this->{m_BorderWidth};
353             }
354              
355             sub sliderposition
356             {
357             my ($this, $p_SliderPosition) = (shift, @_);
358              
359             if (defined ($p_SliderPosition))
360             {
361             $this->{m_SliderPosition} = $p_SliderPosition;
362             $this->Redraw() if ($this->ismapped());
363             }
364              
365             return $this->{m_SliderPosition};
366             }
367              
368             sub ChildNotification
369             {
370             my ($this, $p_Child) = (shift, @_);
371             my $l_Name = $p_Child->name();
372              
373             if ($l_Name ne 'lastBorder' && $l_Name ne 'firstBorder' && $l_Name ne 'slider')
374             {
375             push (@{$this->{m_ClientList}}, $p_Child);
376             $p_Child->packForget();
377             }
378             }
379              
380             1;
381              
382             __END__