view release on metacpan or  search on metacpan

LabPopEntry.pm  view on Meta::CPAN

   }
   
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   # Perform some additional configuration options and pack the buttons onto
   # the screen.  Note that all buttons are disabled by default, and enabled
   # later in the 'setState()' method.
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   foreach my $item (@$menuitems){
      $button = $dw->{"mb_$item->[0]"};
      $button->configure(-relief=>'flat', -padx=>0, -pady=>0, -anchor=>'w');
      $button->pack(-expand=>1, -fill=>'x');
      $button->bind("<Enter>", sub{
         if($_[0]->cget('-state') ne "disabled"){
               $_[0]->configure(-relief=>'raised')
            }
         }
      );
      $button->bind('<Leave>', sub{$_[0]->configure(-relief=>'flat')});
   }
   
   # Check for state each time the menu appears
   $dw->setState;
   
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   # I like this bit of code.  This 'snaps' the pull down to the bottom left
   # corner of the Entry widget.
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   $menu->geometry(sprintf("+%d+%d", $entry->rootx, $entry->rooty+20));
   
   # A 'grabGlobal()' call is necessary here to retain selection in some cases.
   $dw->grabGlobal;
   
   # Finally, raise the menu
   $menu->deiconify;
   $menu->raise;

}

# Withdraw the menu and destroy any children to prevent "menu buildup".
sub withdrawMenu{
   my($dw,$entry) = @_;

   my $menu = $dw->cget(-menu);
   if($menu->state eq 'normal'){
      $menu->withdraw;
   }
   
   my @children = $menu->children;
   foreach my $child(@children){ $child->destroy }
   
   $dw->grabRelease;
}

#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Set the state of the various buttons based on certain criterion, detailed
# below.  Note that any non-default menu-items should automatically have 
# their state set to 'normal'.
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
sub setState{
   my $dw = shift; 
   my($entry, $entryVal, $selection, $clipboard);

   # For bind operations, the Entry widget is actually the first arg passed
   if(ref($dw) eq "Tk::Entry"){ 
      $entry = $dw;
      $dw = $entry->parent;
   }
   else{ $entry = $dw->cget(-entry) }

   my $menuitems = $dw->cget(-menuitems);

   $entryVal  = $entry->get;
   $selection = getSelection($dw, 'PRIMARY');
   $clipboard = getSelection($dw, 'CLIPBOARD');

   foreach my $item(@$menuitems){
      if($item->[0] =~ /Cut|Copy|Paste|Delete|Sel. All/){
         eval{$dw->{"mb_$item->[0]"}->configure(-state=>'disabled')};
      }
   }

   #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   # Only set state to 'normal' for default items if clipboard is
   # not empty or selection is present.
   #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if(($clipboard) && ($dw->{mb_Paste})){
      eval{$dw->{mb_Paste}->configure(-state=>'normal')};
   }
   if(($selection) && ($dw->{mb_Cut})){
      eval{$dw->{mb_Cut}->configure(-state=>'normal')};
   }
   if(($selection) && ($dw->{mb_Copy})){
      eval{$dw->{mb_Copy}->configure(-state=>'normal')};
   }
   if(($selection) && ($dw->{mb_Delete})){
      eval{$dw->{mb_Delete}->configure(-state=>'normal')};
   }
   if(($entry) && ($dw->{"mb_Sel. All"}) && ($selection eq "") && ($entry->get ne "")){
      eval{$dw->{"mb_Sel. All"}->configure(-state=>'normal')};
   }

   return;


   #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   # Only set state to 'normal' for default items if clipboard is
   # not empty or selection is present.
   #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if(defined $dw->{"mb_Paste"}){
      if(($clipboard) && ($dw->{"mb_Paste"}->cget(-state) ne 'normal')){
         eval{ $dw->{mb_Paste}->configure(-state=>'normal') };
      }
   }
   if(defined $dw->{"mb_Cut"}){
      if(($selection) && ($dw->{"mb_Cut"}->cget(-state) ne 'normal')){
         eval{ $dw->{mb_Cut}->configure(-state=>'normal') };
      }
   }
   if(defined $dw->{"mb_Copy"}){
      if(($selection) && ($dw->{"mb_Copy"}->cget(-state) ne 'normal')){
         eval{ $dw->{mb_Copy}->configure(-state=>'normal') };
      }
   }
   if(defined $dw->{"mb_Delete"}){
      if(($selection) && ($dw->{"mb_Delete"}->cget(-state) ne 'normal')){
         eval{ $dw->{mb_Delete}->configure(-state=>'normal') };
      }
   }
   if(defined $dw->{"mb_Sel. All"}){
      if(($entryVal) && ($dw->{"mb_Sel. All"}->cget(-state) ne 'normal')){
         eval{ $dw->{"mb_Sel. All"}->configure(-state=>'normal') };
      }
   }   
}

# Get the selected contents of the Entry widget
sub getSelection{
   my($dw, $selectionType) = @_;

   my($entry,$string);

   # For bind operations, the Entry widget is actually the first arg passed
   if(ref($dw) eq "Tk::Entry"){ 
      $entry = $dw;
      $dw = $entry->parent;
   }
   else{ $entry = $dw->cget(-entry) }

   Tk::catch { $string = $entry->SelectionGet(-selection=>$selectionType) };

   $string = '' unless defined $string;
   return $string;
}

# Select all the contents of the Entry widget
sub selectAll{
   my $dw = shift;

   my $entry;

   # For bind operations, the Entry widget is actually the first arg passed
   if(ref($dw) eq "Tk::Entry"){ 
      $entry = $dw;
      $dw = $entry->parent;
   }
   else{ $entry = $dw->cget(-entry) }
   
   $entry->selectionRange(0,'end');
   setState($dw);
}

# Copy data to the clipboard
sub copyToClip{
   my $dw = shift;
   my $entry;

   # For bind operations, the Entry widget is actually the first arg passed
   if(ref($dw) eq "Tk::Entry"){ 
      $entry = $dw;
      $dw = $entry->parent;
   }
   else{ $entry = $dw->cget(-entry) }

   if($entry->selectionPresent){
      my $string = $entry->SelectionGet(-selection=>'PRIMARY');
      $dw->clipboardClear;
      $dw->clipboardAppend('--',$string);
   }

   my $popupmenu = $dw->Subwidget('popupmenu');
   $dw->withdrawMenu if($popupmenu->ismapped);
}

# Automatically put cut data into the clipboard
sub cutToClip{
   my $dw = shift;
   my $entry;

   # For bind operations, the Entry widget is actually the first arg passed
   if(ref($dw) eq "Tk::Entry"){ 
      $entry = $dw;
      $dw = $entry->parent;
   }
   else{ $entry = $dw->cget(-entry) }

   if($entry->selectionPresent){
      my $string = deleteSelected($entry);
      $entry->clipboardClear;
      $entry->clipboardAppend('--', $string);
   }

   my $popupmenu = $dw->Subwidget('popupmenu');
   $dw->withdrawMenu if($popupmenu->ismapped);
}

# Delete selected text
sub deleteSelected{
   my $dw = shift;

   my($entry, $deleted_string);

   # For bind operations, the Entry widget is actually the first arg passed
   if(ref($dw) eq "Tk::Entry"){ 
      $entry = $dw;
      $dw = $entry->parent;
   }
   else{ $entry = $dw->cget(-entry) }

   my($from,$to);
   if( ($entry->selectionPresent) ){
      $from = $entry->index('sel.first');
      $to = $entry->index('sel.last');
      $deleted_string = substr($entry->get, $from, $to-$from);
      $entry->delete($from,$to);
   }

   #$dw->clipboardClear;

   my $popupmenu = $dw->Subwidget('popupmenu');
   $dw->withdrawMenu if($popupmenu->ismapped);
   
   return $deleted_string;
}

# Paste data from the clipboard into the Entry widget
sub pasteFromClip{
   my $dw = shift;

   my($entry, $from);

   # For bind operations, the Entry widget is actually the first arg passed
   if(ref($dw) eq "Tk::Entry"){ 
      $entry = $dw;
      $dw = $entry->parent;
   }
   else{ $entry = $dw->cget(-entry) }

   if($entry->selectionPresent){
      $from = $entry->index('sel.first');
      deleteSelected($dw);
   }
   else{ $from = $entry->index('insert') }

   my $string = getSelection($entry,'CLIPBOARD');

   $entry->insert($from,$string);

   my $popupmenu = $dw->Subwidget('popupmenu');
   $dw->withdrawMenu if($popupmenu->ismapped);
}

#++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Add an item to the popup menu at the specified index.  The 'item' passed 
# is a reference to an anon. array that contains four items (in this order):
# 
# 1 - A label
# 2 - A callback associated with that label
# 3 - The bind event associated with that callback
# 4 - The 'underline' index value associated with the callback
#++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
sub addItem{
   my($dw, $index, $item) = @_;
   
   #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   # Permit the programmer to omit an index, in which case the item will be
   # added to the end of the menu.
   #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if(ref($index) =~ /array/i){
      $item = $index;
      $index = 'end';
   }
   
   my $menu = $dw->cget(-menu);
   my $menuitems = $dw->cget(-menuitems);
   
   my $callback = $item->[1];
   my $binding  = $item->[2];
   
   my $length = scalar(@$menuitems);
   
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   # If index is not specified, 'end', or greater than the number of elements, 
   # just push it onto the end of the menuitem array.  
   #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if( ($index eq 'end') || ($index > $length) ){ push(@$menuitems, $item) }

LabPopEntry.pm  view on Meta::CPAN

   if($index eq 'end'){ $index = $length - 1 }
   if($last eq 'end'){ $last = $length }
   
   # Ensure that the first index is less than the second
   if( (defined $last) && ($last < $index) ){ 
      die "\nThe second index must be greater than the first";
   }
   
   my $numItems = $last - $index;
   
   # Remove a single item or group of items, as appropriate
   for(my $n = 0; $n < $length; $n++){
      if(($index == $n) && ($last eq "")){ 
         my $spliced = splice @$menuitems, $n, 1;
         return $spliced;
      }
      if(($index == $n) && ($last ne "")){
         my @spliced = splice @$menuitems, $n, $numItems;
         return \@spliced;
      } 
   }
}   
1;

__END__


=head1 NAME

LabPopEntry - A LabEntry widget with an automatic, configurable right-click
menu built in, plus input masks.

=head2 SYNOPSIS

  use LabPopEntry;
  $dw = $parent->LabPopEntry(
      -pattern   => 'alpha', 'alphanum', 'capsonly', 'signed_int', 
                 'unsigned_int', 'float', 'nondigit', or any supplied regexp.
      -nomenu    => 0 or 1,
      -case      => 'upper', 'lower', 'capitalize',
      -maxwidth  => int,
      -minvalue  => int,
      -maxvalue  => int,
      -nospace   => 0 or 1,
      -menuitems => ['string', 'callback', 'binding', 'index'],
   );
   $dw->pack;

=head2 DESCRIPTION

LabPopEntry is a LabEntry widget with a right-click menu automatically
attached.  In addition, certain field masks can easily be applied to the entry
widget in order to force the end-user into entering only the values you want
him or her to enter.

By default, there are five items attached to the right-click menu: Cut, Copy,
Paste, Delete and Sel. All.  The default bindings for the items are Control-x,
Control-c, Control-v, Control-d, and Control-a, respectively.

The difference between 'Cut' and 'Delete' is that the former automatically
copies the contents that were cut to the clipboard, while the latter does not.

=head2 OPTIONS

B<-pattern =E<gt>> I<string>

S<   The pattern specified here creates an input mask for the LabPopEntry
widget.  There are seven pre-defined masks:> 

=over 4

=item *

alpha - Upper and lower case a-z only.

=item *

alphanum - Alpha-numeric characters only.

=item *

capsonly - Upper case A-Z only.

=item *

nondigit - Any characters except 0-9.

=item *

float - A float value, which may or may not include a decimal.

=item *

signed_int - A signed integer value, which may or may not include a '+'.

=item *

unsigned_int - An unsigned integer value.

=back

S<You may also specify a regular expression of your own design using Perl's
standard regular expression mechanisms.  Be sure to use single quotes, e.g.
 '/\d\w\d/'>

B<-nomenu =E<gt>> I<B<0> or 1>

S<   If set to true, then no right-click menu will appear.  Presumably, you would
set this if you were only interested in the input-mask functionality.  The
default is, of course, 0.>

B<-nospace =E<gt>> I<B<0> or 1>

S<   If set to true (1), the user may not enter whitespace before, after or 
between words within that LabPopEntry widget.  The default is 0.>

B<-maxwidth =E<gt>> I<int>

S<   Specifies the maximum number of characters that the user can enter in that
particular LabPopEntry widget.  Note that this is not the same as the width
of the widget itself.>