home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _2c9a74741f5b52a2bb678c161d7e3e14 < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.1 KB  |  110 lines
  1. # Tranlation of FloatEnt.tcl in Tix4.1
  2.  
  3. # TODO/IDEA:
  4. #    o extract a widget (SimpleEntry?) without post/unpost methods
  5. #      and derive FloatEntry fron this widget.
  6.  
  7. package Tk::FloatEntry;
  8. use strict;
  9.  
  10. BEGIN
  11.   {
  12.     use vars '$DEBUG';
  13.     $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'achx') ? 1 : 0;
  14.     print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG;
  15.   }
  16.  
  17. require Tk;
  18. require Tk::Widget;
  19. require Tk::Derived;
  20. require Tk::Entry;
  21.  
  22. use vars qw($VERSION);
  23. $VERSION = '4.004'; # $Id: //depot/Tkutf8/TixGrid/FloatEntry.pm#4 $
  24.  
  25. use base  qw(Tk::Derived Tk::Entry);
  26.  
  27. Construct Tk::Widget 'FloatEntry';
  28.  
  29. sub ClassInit
  30.   {
  31.     my ($class, $mw) = @_;
  32.     $class->SUPER::ClassInit($mw);
  33.     $mw->bind($class, '<Return>', 'invoke');
  34.     $mw->bind($class, '<FocusIn>', 'FocusIn');
  35.     $class;
  36.   }
  37.  
  38. sub Populate
  39.   {
  40.     my ($e, $args) = @_;
  41.     $e->ConfigSpecs(
  42.     -value     =>            ['METHOD',   'value',              'Value',              undef],
  43.     -highlightthickness => [$e,         'highlightThickness', 'HighlightThickness', 0    ],
  44.     -command =>            ['CALLBACK', 'command',            'Command',            undef],
  45.     );
  46.     print "FloatEntry Init: $e\n" if $DEBUG;
  47.     $e;
  48.   }
  49.  
  50. ## option method
  51.  
  52. sub value
  53.   {
  54.     my $e = shift;
  55.     unless (@_)
  56.       {
  57.     return $e->get
  58.       }
  59.     $e->delete(0,'end');
  60.     $e->insert(0,$_[0]);
  61.     $e->selection('from', 0);
  62.     $e->selection('to', 'end');
  63.  
  64.   }
  65.  
  66. ## public methods
  67.  
  68. sub invoke
  69.   {
  70.     my ($e) = @_;
  71.     $e->Callback('-command', $e->get);
  72.   }
  73.  
  74. sub post
  75.   {
  76.     my ($e, $x, $y, $dx, $dy) = @_;
  77.  
  78.     $dx = $e->reqwidth  unless defined $dx;
  79.     $dy = $e->reqheight unless defined $dy;
  80.  
  81.     $e->place('-x'=>$x, '-y'=>$y, -width=>$dx, -height=>$dy, -bordermode=>'ignore');
  82.     $e->raise;
  83.     $e->focus;
  84.   }
  85.  
  86. sub unpost
  87.   {
  88.     my ($e) = @_;
  89.     $e->place('forget');
  90.   }
  91.  
  92. ## bindings
  93.  
  94. sub FocusIn
  95.   {
  96.     my ($e) = @_;
  97.  
  98.     # FIX: xxx only if entry has not already focus
  99.       {
  100.     $e->focus;
  101.     $e->selection('from', 0);
  102.     $e->selection('to', 'end');
  103.     $e->icursor('end');
  104.       }
  105.   }
  106.  
  107. 1;
  108. __END__
  109.  
  110.