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