summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/site/lib/Tk/demos/widget_lib/slide.pl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/Tk/demos/widget_lib/slide.pl')
-rw-r--r--Master/tlpkg/tlperl/site/lib/Tk/demos/widget_lib/slide.pl178
1 files changed, 178 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/Tk/demos/widget_lib/slide.pl b/Master/tlpkg/tlperl/site/lib/Tk/demos/widget_lib/slide.pl
new file mode 100644
index 00000000000..7bd31a0b369
--- /dev/null
+++ b/Master/tlpkg/tlperl/site/lib/Tk/demos/widget_lib/slide.pl
@@ -0,0 +1,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