summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/slide.pl
blob: 7bd31a0b369343a0b9031e9c18f9fe3d63a06395 (plain)
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