view release on metacpan or  search on metacpan

LabPopEntry.pm  view on Meta::CPAN

package Tk::LabPopEntry;

use strict;
require Tk::LabEntry;

use vars qw(@ISA $VERSION);
@ISA = qw(Tk::Derived Tk::LabEntry);
$VERSION = 0.05;

Construct Tk::Widget 'LabPopEntry';

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

   $dw->Advertise('popupmenu' => $menu);
   
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   # The -entry and -menu options are for convenience, but are 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],
      -entry      => ['PASSIVE',undef,undef,$entry],
      DEFAULT     => [$dw],
   );
    
   $dw->setBindings($entry, $menuitems);
}

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

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