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