1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
# slide.pl
$Tk::SlideSwitch::VERSION = '1.1';
package Tk::SlideSwitch;
use Tk;
use Tk::widgets qw/Label Scale/;
use base qw/Tk::Frame/;
use strict;
Construct Tk::Widget 'SlideSwitch';
sub Populate {
my($self, $args) = @_;
$self->SUPER::Populate($args);
my $ll = $self->Label->pack(-side => 'left');
my $sl = $self->Scale->pack(-side => 'left');
my $rl = $self->Label->pack(-side => 'left');
$self->ConfigSpecs(
-command => [$sl, qw/command Command /],
-from => [$sl, qw/from From 0/],
-highlightthickness => [$sl,
qw/highlightThickness HighlightThickness 0/],
-length => [$sl, qw/length Length 30/],
-llabel => [qw/METHOD llabel Llabel /],
-orient => [$sl, qw/orient Orient horizontal/],
-rlabel => [qw/METHOD rlabel Rlabel /],
-showvalue => [$sl, qw/showValue ShowValue 0/],
-sliderlength => [$sl, qw/sliderLength SliderLength 15/],
-sliderrelief => [$sl, qw/sliderRelief SliderRelief raised/],
-to => [$sl, qw/to To 1/],
-troughcolor => [$sl, qw/troughColor TroughColor /],
-width => [$sl, qw/width Width 8/],
-variable => [$sl, qw/variable Variable /],
'DEFAULT' => [$ll, $rl],
);
$self->{ll} = $ll;
$self->{sl} = $sl;
$self->{rl} = $rl;
$self->bind('<Configure>' => sub {
my ($self) = @_;
my $orient = $self->cget(-orient);
return if $orient eq 'horizontal';
my ($ll, $sl, $rl) = ($self->{ll}, $self->{sl}, $self->{rl});
$ll->packForget;
$sl->packForget;
$rl->packForget;
$ll->pack;
$sl->pack;
$rl->pack;
});
} # end Populate
# Private methods and subroutines.
sub llabel {
my ($self, $args) = @_;
$self->{ll}->configure(@$args);
} # end llabel
sub rlabel {
my ($self, $args) = @_;
$self->{rl}->configure(@$args);
} # end rlabel
1;
package main;
use vars qw / $TOP /;
use strict;
sub slide {
my( $demo ) = @_;
$TOP = $MW->WidgetDemo(
-name => $demo,
-text => "This demonstration creates a new composite SlideSwitch widget that can be either on or off. The widget is really a customized Scale widget.",
-title => 'A binary sliding switch',
-iconname => 'slide',
);
my $mw = $TOP;
my $sl = $mw->SlideSwitch(
-bg => 'gray',
-orient => 'horizontal',
-command => sub {print "Switch value is @_\n"},
-llabel => [-text => 'OFF', -foreground => 'blue'],
-rlabel => [-text => 'ON', -foreground => 'blue'],
-troughcolor => 'tan',
)->pack(qw/-side left -expand 1/);
} # end slide
__END__
=head1 NAME
Tk::SlideSwitch - a 2 position horizontal or vertical switch.
=head1 SYNOPSIS
use Tk::SlideSwitch;
my $sl = $frame1->SlideSwitch(
-bg => 'gray',
-orient => 'horizontal',
-command => [$self => 'on'],
-llabel => [-text => 'OFF', -foreground => 'blue'],
-rlabel => [-text => 'ON', -foreground => 'blue'],
-troughcolor => 'tan',
)->pack(qw/-side left -expand 1/);
=head1 DESCRIPTION
Tk::SlideSwitch is a Frame based composite mega-widget featuring a binary Scale
widget surrounded by two Label widgets. The Scale's value can be either 0 or
1. The Labels are positioned to the left and right of the Scale if its
orientation is horizontal, else on the top and bottom of the Scale.
=head1 OPTIONS
In addition to all Scale options, the following option/value pairs are
also supported:
=over 4
=item B<-llabel>
A reference to an array of left (or top) Label configuration options.
=item B<-rlabel>
A reference to an array of right (or bottom) Label configuration options.
=back
=head1 METHODS
There are no special methods.
=head1 ADVERTISED WIDGETS
Component subwidgets can be accessed via the B<Subwidget> method.
This mega widget has no advertised subwidgets.
=head1 EXAMPLE
See Synopsis.
=head1 BUGS
This widget uses only the pack geometry manager.
=head1 AUTHOR
sol0@Lehigh.EDU
Copyright (C) 2002 - 2003, Steve Lidie. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 KEYWORDS
SlideSwitch, Scale
=cut
|