home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _f9f10fe93fa3156b4ab97955e5679137 < prev    next >
Encoding:
Text File  |  2004-06-01  |  4.0 KB  |  136 lines
  1. #
  2. # DialogBox is similar to Dialog except that it allows any widget
  3. # in the top frame. Widgets can be added with the add method. Currently
  4. # there exists no way of deleting a widget once it has been added.
  5.  
  6. package Tk::DialogBox;
  7.  
  8. use strict;
  9. use Carp;
  10.  
  11. use vars qw($VERSION);
  12. $VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
  13.  
  14. use base  qw(Tk::Toplevel);
  15.  
  16. Tk::Widget->Construct('DialogBox');
  17.  
  18. sub Populate {
  19.     my ($cw, $args) = @_;
  20.  
  21.     $cw->SUPER::Populate($args);
  22.     my $buttons = delete $args->{'-buttons'};
  23.     $buttons = ['OK'] unless defined $buttons;
  24.     my $default_button = delete $args->{'-default_button'};
  25.     $default_button = $buttons->[0] unless defined $default_button;
  26.  
  27.     $cw->{'selected_button'} = '';
  28.     $cw->transient($cw->Parent->toplevel);
  29.     $cw->withdraw;
  30.     if (@$buttons == 1) {
  31.     $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke });
  32.     } else {
  33.     $cw->protocol('WM_DELETE_WINDOW' => sub {});
  34.     }
  35.  
  36.     # create the two frames
  37.     my $top = $cw->Component('Frame', 'top');
  38.     $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32';
  39.     my $bot = $cw->Component('Frame', 'bottom');
  40.     $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32';
  41.     $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/);
  42.     $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/);
  43.  
  44.     # create a row of buttons in the bottom.
  45.     my $bl;  # foreach my $var: perl > 5.003_08
  46.     foreach $bl (@$buttons)
  47.      {
  48.     my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } );
  49.     $b->bind('<Return>' => [ $b, 'Invoke']);
  50.     $cw->Advertise("B_$bl" => $b);
  51.         if ($Tk::platform eq 'MSWin32')
  52.          {
  53.           $b->configure(-width => 10, -pady => 0);
  54.          }
  55.     if ($bl eq $default_button) {
  56.             if ($Tk::platform eq 'MSWin32') {
  57.                 $b->pack(-side => 'left', -expand => 1,  -padx => 1, -pady => 1);
  58.             } else {
  59.             my $db = $bot->Frame(-relief => 'sunken', -bd => 1);
  60.             $b->raise($db);
  61.             $b->pack(-in => $db, -padx => '2', -pady => '2');
  62.             $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1);
  63.             }
  64.         $cw->{'default_button'} = $b;
  65.         $cw->bind('<Return>' => [ $b, 'Invoke']);
  66.     } else {
  67.         $b->pack(-side => 'left', -expand => 1,  -padx => 1, -pady => 1);
  68.     }
  69.     }
  70.     $cw->ConfigSpecs(-command    => ['CALLBACK', undef, undef, undef ],
  71.                      -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'],
  72.                      -background => ['DESCENDANTS', 'background','Background',  undef],
  73.              -focus     => ['PASSIVE', undef, undef, undef],
  74.              -showcommand => ['CALLBACK', undef, undef, undef],
  75.                     );
  76.     $cw->Delegates('Construct',$top);
  77. }
  78.  
  79. sub add {
  80.     my ($cw, $wnam, @args) = @_;
  81.     my $w = $cw->Subwidget('top')->$wnam(@args);
  82.     $cw->Advertise("\L$wnam" => $w);
  83.     return $w;
  84. }
  85.  
  86. sub Wait
  87. {
  88.  my $cw = shift;
  89.  $cw->Callback(-showcommand => $cw);
  90.  $cw->waitVariable(\$cw->{'selected_button'});
  91.  $cw->grabRelease;
  92.  $cw->withdraw;
  93.  $cw->Callback(-command => $cw->{'selected_button'});
  94. }
  95.  
  96. sub Show {
  97.  
  98.     croak 'DialogBox: "Show" method requires at least 1 argument'
  99.     if scalar @_ < 1;
  100.     my $cw = shift;
  101.     my ($grab) = @_;
  102.     my $old_focus = $cw->focusSave;
  103.     my $old_grab = $cw->grabSave;
  104.  
  105.     shift if defined $grab && length $grab && ($grab =~ /global/);
  106.     $cw->Popup(@_);
  107.  
  108.     Tk::catch {
  109.     if (defined $grab && length $grab && ($grab =~ /global/)) {
  110.     $cw->grabGlobal;
  111.     } else {
  112.     $cw->grab;
  113.     }
  114.     };
  115.     if (my $focusw = $cw->cget(-focus)) {
  116.     $focusw->focus;
  117.     } elsif (defined $cw->{'default_button'}) {
  118.     $cw->{'default_button'}->focus;
  119.     } else {
  120.     $cw->focus;
  121.     }
  122.     $cw->Wait;
  123.     &$old_focus;
  124.     &$old_grab;
  125.     return $cw->{'selected_button'};
  126. }
  127.  
  128. sub Exit
  129. {
  130.  my $cw = shift;
  131.  #kill the dialogbox, by faking a 'DONE'
  132.  $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text);
  133. }
  134.  
  135. 1;
  136.