home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / NumEntryPlain.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  6.8 KB  |  308 lines
  1. # $Id: NumEntryPlain.pm,v 1.2 2003/09/16 18:16:45 joker Exp $
  2.  
  3. package Tk::NumEntryPlain;
  4.  
  5. use Tk ();
  6. use Tk::Derived;
  7. use Tk::Entry;
  8. use strict;
  9.  
  10. use vars qw(@ISA $VERSION);
  11. @ISA = qw(Tk::Derived Tk::Entry);
  12. $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
  13.  
  14. Construct Tk::Widget 'NumEntryPlain';
  15.  
  16. sub ClassInit {
  17.     my ($class,$mw) = @_;
  18.  
  19.     $class->SUPER::ClassInit($mw);
  20.  
  21.     $mw->bind($class,'<Leave>', 'Leave');
  22.     $mw->bind($class,'<FocusOut>', 'Leave');
  23.     $mw->bind($class,'<Return>', 'Return');
  24.     $mw->bind($class,'<Up>', 'Up');
  25.     $mw->bind($class,'<Down>', 'Down');
  26.     $mw->bind($class,'<Home>', 'Home');
  27.     $mw->bind($class,'<End>', 'End');
  28.     $mw->bind($class,'<Prior>', 'Prior');
  29.     $mw->bind($class,'<Next>', 'Next');
  30. }
  31.  
  32.  
  33. ## Bindings callbacks
  34.  
  35. sub Leave {
  36.     my $e = shift;
  37.     $e->incdec(0);  # range check
  38. }
  39.  
  40. sub Return {
  41.     my $e = shift;
  42.  
  43.     my $v = $e->value; # range check
  44.  
  45.     $e->Callback(-command => $v);
  46. }
  47.  
  48. sub Up {
  49.     my $e = shift;
  50.     $e->incdec($e->cget(-increment));
  51. }
  52.  
  53. sub Down {
  54.     my $e = shift;
  55.     $e->incdec(-$e->cget(-increment));
  56. }
  57.  
  58. sub Prior {
  59.     my $e = shift;
  60.     $e->incdec($e->cget(-bigincrement) || 1);
  61. }
  62.  
  63. sub Next {
  64.     my $e = shift;
  65.     $e->incdec(-($e->cget(-bigincrement) || 1));
  66. }
  67.  
  68. sub Insert {
  69.     my($e,$c) = @_;
  70.  
  71.     my $dot = ($e->cget(-increment) =~ /\./ ? '.' : '');
  72.  
  73.     if($c =~ /^[-0-9$dot]$/) {
  74.     $e->SUPER::Insert($c);
  75.     }
  76.     elsif(defined($c) && length($c)) {
  77.     $e->_ringBell;
  78.     }
  79. }
  80.  
  81. sub Home {
  82.     my $e = shift;
  83.     my $min_val = $e->cget(-minvalue);
  84.     return unless defined $min_val;
  85.     $e->value($min_val);
  86. }
  87.  
  88. sub End {
  89.     my $e = shift;
  90.     my $max_val = $e->cget(-maxvalue);
  91.     return unless defined $max_val;
  92.     $e->value($max_val);
  93. }
  94.  
  95. ## Widget constructor
  96.  
  97. sub Populate {
  98.     my ($e, $args) = @_;
  99.  
  100. #    $e->SUPER::Populate($args);
  101.  
  102.  
  103.     $e->ConfigSpecs(
  104.         -value       => [METHOD   => undef,         undef,         "0"       ],
  105.         -defaultvalue
  106.              => [PASSIVE  => undef,         undef,         undef     ],
  107.         -maxvalue    => [PASSIVE  => undef,         undef,         undef     ],
  108.         -minvalue    => [PASSIVE  => undef,         undef,         undef     ],
  109.         -bell        => [PASSIVE  => "bell",        "Bell",        1         ],
  110.         -command     => [CALLBACK => undef,         undef,         undef     ],
  111.     -browsecmd   => [CALLBACK => undef,         undef,         undef     ],
  112.         -increment    => [PASSIVE => undef,         undef,         1         ],
  113.         -bigincrement => [PASSIVE => undef,         undef,         undef     ],
  114.         ($Tk::platform eq 'MSWin32' ?
  115.           (-background => ['PASSIVE', qw/background Background/, undef]) :
  116.           ()),
  117.         DEFAULT      => [$e],
  118.     );
  119. }
  120.  
  121. ## Options implementation
  122.  
  123. sub value {
  124.     my $e = shift;
  125.     my $old;
  126.  
  127.     if(@_) {
  128.         my $new = 0 + shift;
  129.         my $pos = $e->index('insert');
  130.  
  131.         $old = $e->get;
  132.  
  133.         $e->delete(0,'end');
  134.         $e->insert(0,$new);
  135.         $e->icursor($pos);
  136.     }
  137.     else {
  138.         $e->incdec(0); # range check
  139.         $old = $e->get;
  140.     }
  141.  
  142.     # Do a range check after all configuration has finished,
  143.     # as we may not yet know the range
  144.  
  145.     $e->afterIdle([ $e => 'incdec', 0]);
  146.  
  147.     length($old) ? $old + 0 : $e->{Configure}{'-defaultvalue'};
  148. }
  149.  
  150. sub _ringBell {
  151.     my $e = shift;
  152.     my $v;
  153.     return
  154.         unless defined($v = $e->{Configure}{'-bell'});
  155.     $e->bell
  156.         if(($v =~ /^\d+$/ && $v) || $v =~ /^true$/i);
  157. }
  158.  
  159.  
  160. sub incdec {
  161.     my($e,$inc) = @_;
  162.     my $val = $e->get;
  163.  
  164.     if($inc == 0 && $val =~ /^-?$/) {
  165.         $val = "";
  166.     }
  167.     else {
  168.         my $min = $e->{Configure}{'-minvalue'};
  169.         my $max = $e->{Configure}{'-maxvalue'};
  170.  
  171.     $val = 0 if !$val;
  172.         $val += $inc;
  173.         my $limit = undef;
  174.  
  175.         $limit = $val = $min
  176.             if(defined($min) && $val < $min);
  177.  
  178.         $limit = $val = $max
  179.             if(defined($max) && $val > $max);
  180.  
  181.         if(defined $limit) {
  182.             $e->_ringBell
  183.                 if $inc;
  184.         }
  185.     }
  186.  
  187.     my $pos = $e->index('insert');
  188.     $e->delete(0,'end');
  189.     $e->insert(0,$val);
  190.     $e->icursor($pos);
  191.     $e->Callback(-browsecmd) if $inc;
  192. }
  193.  
  194.  
  195. 1;
  196.  
  197. __END__
  198.  
  199. =head1 NAME
  200.  
  201. Tk::NumEntryPlain - A numeric entry widget
  202.  
  203. =head1 SYNOPSIS
  204.  
  205. S<    >B<use Tk::NumEntryPlain>;
  206.  
  207. =head1 DESCRIPTION
  208.  
  209. B<Tk::NumEntryPlain> defines a widget for entering integer numbers.
  210.  
  211. B<Tk::NumEntryPlain> supports all the options and methods that a normal
  212. L<Entry|Tk::Entry> widget provides, plus the following options
  213.  
  214. =head1 STANDARD OPTIONS
  215.  
  216. B<-repeatdelay>
  217. B<-repeatinterval>
  218.  
  219. =head1 WIDGET-SPECIFIC OPTIONS
  220.  
  221. =over 4
  222.  
  223. =item -minvalue
  224.  
  225. Defines the minimum legal value that the widget can hold. If this
  226. value is C<undef> then there is no minimum value (default = undef).
  227.  
  228. =item -maxvalue
  229.  
  230. Defines the maximum legal value that the widget can hold. If this
  231. value is C<undef> then there is no maximum value (default = undef).
  232.  
  233. =item -bell
  234.  
  235. Specifies a boolean value. If true then a bell will ring if the user
  236. attempts to enter an illegal character into the entry widget, and
  237. when the user reaches the upper or lower limits when using the
  238. up/down buttons for keys (default = true).
  239.  
  240. =item -textvariable
  241.  
  242. Reference to a scalar variable that contains the value currently
  243. in the B<NumEntry>.  Use the variable only for reading (see
  244. L<"CAVEATS"> below).
  245.  
  246. =item -value
  247.  
  248. Specifies the value to be inserted into the entry widget. Similar
  249. to the standard B<-text> option, but will perform a range
  250. check on the value.
  251.  
  252. =item -command
  253.  
  254. A callback which is called if <Return> is pressed.
  255.  
  256. =item -browsecmd
  257.  
  258. A callback which is called every time an increment or decrement
  259. happens in the entry widget.
  260.  
  261. =back
  262.  
  263. =head1 WIDGET METHODS
  264.  
  265. =over 4
  266.  
  267. =item I<$numentry>->B<incdec>(I<increment>)
  268.  
  269. Increment the value of the entry widget by the specified increment. If
  270. increment is 0, then perform a range check.
  271.  
  272. =back
  273.  
  274. =head1 CAVEATS
  275.  
  276. =over 4
  277.  
  278. =item -textvariable
  279.  
  280. B<-textvariable> should only be used to read out the current
  281. value in the B<NumEntry>.
  282.  
  283. Values set via B<-textvariable> are not valided. Therefore
  284. it's possible to insert, e.g., 'abc', into the B<NumEntry>.
  285.  
  286. =back
  287.  
  288. =head1 SEE ALSO
  289.  
  290. L<Tk::NumEntry|Tk::NumEntry>
  291. L<Tk::Entry|Tk::Entry>
  292.  
  293. =head1 HISTORY
  294.  
  295. The code was extracted from B<Tk::NumEntry> and slightly modified
  296. by Achim Bohnet E<lt>ach@mpe.mpg.deE<gt>.  B<Tk::NumEntry>'s author
  297. is Graham Barr E<lt>gbarr@pobox.comE<gt>.
  298.  
  299. Current maintainer is Slaven Rezic E<lt>slaven.rezic@berlin.deE<gt>.
  300.  
  301. =head1 COPYRIGHT
  302.  
  303. Copyright (c) 1997-1998 Graham Barr. All rights reserved.
  304. This program is free software; you can redistribute it and/or modify it
  305. under the same terms as Perl itself.
  306.  
  307. =cut
  308.