view release on metacpan or  search on metacpan

PopEntry.pm  view on Meta::CPAN

package Tk::PopEntry;

use strict;
require Tk::Entry;

use vars qw(@ISA $VERSION);
@ISA = qw(Tk::Derived Tk::Entry);
$VERSION = 0.06;

Construct Tk::Widget 'PopEntry';

sub Populate{
   my($dw, $args) = @_;
   $dw->SUPER::Populate($args);
   
   my $menuitems = delete $args->{-menuitems};
   my $nomenu = delete $args->{-nomenu};
   
   # Create the toplevel here, for easier reference later
   my $menu = $dw->Toplevel(-bd=>2, -relief=>'raised');
   $menu->withdraw;
   $menu->overrideredirect(1);
   $menu->transient;
   
   # The default menu items
   if(!defined($menuitems)){
      $menuitems = [
         ["Cut",     'Tk::PopEntry::cutToClip',      '<Control-x>', 2],
         ["Copy",    'Tk::PopEntry::copyToClip',     '<Control-c>', 0],
         ["Paste",   'Tk::PopEntry::pasteFromClip',  '<Control-v>', 0],
         ["Delete",  'Tk::PopEntry::deleteSelected', '<Control-d>', 0],
         ["Sel. All",'Tk::PopEntry::selectAll',      '<Control-a>', 7],
      ];
   }

   $dw->Advertise('popupmenu' => $menu);
   
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   # The -menu options is for convenience, but is not generally 
   # meant to be called as a configure option once created.  Caveat Progammor.
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   $dw->ConfigSpecs(
      -pattern    => ['PASSIVE'],
      -case       => ['PASSIVE'],
      -maxwidth   => ['PASSIVE'],
      -maxvalue   => ['PASSIVE'],
      -minvalue   => ['PASSIVE'],
      -nomenu     => ['PASSIVE',undef,undef,$nomenu],
      -nospace    => ['PASSIVE',undef,undef,0],
      -menuitems  => ['PASSIVE',undef,undef,$menuitems],
      -menu       => ['PASSIVE',undef,undef,$menu],
      DEFAULT     => [$dw],
   );
    
   $dw->setBindings($menuitems);
}

# Set the default bindings
sub setBindings{
   my($dw, $menuitems) = @_;
      
   my($callback, $binding);
   my $popupmenu = $dw->Subwidget('popupmenu');

   $dw->bind("<Key>", sub{ $dw->validate } );

   $dw->bind("<Button-3>",