view release on metacpan or  search on metacpan

EntryDialog.pm  view on Meta::CPAN

    my $b = $w -> Button (-text => 'Dialog',
                          -command => sub{&show_dialog($w)}) -> pack;

    sub show_dialog {
        my ($w) = @_;
        my $e;
        if (not defined $e) {
	    $e = $w -> EntryDialog (-title => 'Enter Text');
            $e -> configure (-defaultentry => 'Default text');
	    $e -> configure (-textlabel => 'Please enter your text:');
        }
        my $resp = $e -> WaitForInput;
	print "$resp\n";
	$e -> configure (-textlabel => '');
	$e -> configure (-defaultentry => 'New entry without label.');
        my $resp = $e -> WaitForInput;
	print "$resp\n";
        return $resp;
    }

    MainLoop;

=head1 VERSION

  $Revision: 0.10 $

  Licensed for free distribution under the terms of the 
  Perl Artistic License.

  Written by Robert Allan Kiesling <rkiesling@earthlink.net>.

  Dave Scheck <cds033@email.mot.com> provided the input for the 
  -textlabel option.

=cut

use Tk qw(Ev);
use strict;
use Carp;
use base qw(Tk::Toplevel);
use Tk::widgets qw(Entry Button);

Construct Tk::Widget 'EntryDialog';

sub Accept {$_[0]->{Configure}{-accept} += 1}

sub Cancel {
    $_[0] -> {Configure}{-defaultentry} = '';
    $_[0] -> {Configure}{-accept} += 1;
}

sub textlabel {
    my $w = $_[0];
    my $text = $_[1];
    if (defined $text and length ($text)) {
	my $l1 = $w->Component (Label => 'textlabel', 
			-textvariable => \$w->{Configure}{-textlabel},
			-font => $w -> {Configure}{-font});
	$l1->grid( -column => 1, -row => 1, -padx => 5, -pady => 5,
		   -sticky => 'ew', -columnspan => 5 );
	$w->Advertise('textlabel' => $l1);

	$w -> Subwidget ('entry')  -> 
	    grid ( -column => 1, -row => 2, -padx => 5, -pady => 5,
		-sticky => 'ew', -columnspan => 5 );
	$w -> Subwidget ('acceptbutton') -> 
	    grid( -column => 2, -row => 3, -padx => 5, -pady => 5, 
		  -sticky => 'new' );
	$w -> Subwidget ('cancelbutton') -> 
	    grid ( -column => 4, -row => 3, -padx => 5, -pady => 5, 
		   -sticky => 'new' );
    } else {
	$w -> Subwidget ('textlabel') -> destroy if 
	    defined $w -> Subwidget ('textlabel');
    }
}

sub Populate {
  my ($w,$args) = @_;
  require Tk::Button;
  require Tk::Toplevel;
  require Tk::Label;
  require Tk::Entry;
  $w->SUPER::Populate($args);

  $w->ConfigSpecs( -font =>    ['CHILDREN',undef,undef,
	                         '*-helvetica-medium-r-*-*-12-*'],
		   -defaultentry => ['PASSIVE',undef,undef,''],
		   -textlabel => ['METHOD',undef,undef,''],
		   -accept => ['PASSIVE',undef,undef,0] );

  my $row = 1;
  $w -> withdraw;
  
  $row++ if (defined $args->{-textlabel} and length ($args->{-textlabel}));

  my $e1 = $w -> Component (Entry => 'entry', 
		            -textvariable => \$w->{Configure}{-defaultentry});
  $e1 -> grid ( -column => 1, -row => $row++, -padx => 5, -pady => 5,
		-sticky => 'ew', -columnspan => 5 );
  $w -> Advertise ('entry' => $e1);
  $e1 -> bind ('<Return>', sub {$w -> Accept});
  my $b1 = $w -> Component (Button => 'acceptbutton',
			    -text => 'Accept',
			    -default => 'active' );
  $b1->grid( -column => 2, -row => $row, -padx => 5, -pady => 5, -sticky => 'new' );
  $b1 -> bind ('<Button-1>', sub {$w -> Accept});
  $b1->focus;
  my $b2 = $w -> Component (Button => 'cancelbutton',
			    -text => 'Cancel',
			    -command => sub{$w -> Cancel},
			    -default => 'normal' );
  $b2->grid( -column => 4, -row => $row, -padx => 5, -pady => 5, -sticky => 'new' );

  $w -> bind ('<Escape>', sub {$w -> withdraw});

  return $w;
}

sub WaitForInput {
  my ($w, @args) = @_;
  $w -> Popup (@args);
  $w -> waitVariable(\$w->{Configure}{-accept});
  $w -> withdraw;
  return $w -> {Configure}{-defaultentry};
}

1;