Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

opening multiple sub-windows in perl tk

by vr786 (Sexton)
on Nov 18, 2010 at 05:53 UTC ( [id://872146]=perlquestion: print w/replies, xml ) Need Help??

vr786 has asked for the wisdom of the Perl Monks concerning the following question:

Hi monks, I have written a small script to open a file , but it is opening multiple files (infinite),by clicking "View result" button continuously, it should not open another file unless i close the initial file, the problem is it should not allow to open multiple files and when i click "save" button the result window is going background,it should not happen.....can you help me out of this problem 

#!/usr/bin/perl -w
use warnings;
use strict;
use Tk;
use Tk::FileSelect;

my $mw = MainWindow->new;

$mw->configure( -background => 'black', -foreground => 'white' );
$mw->geometry( "400x100" );
$mw->title( "Multiple Windows Test" );

my $button1 = $mw->Button(
   -text       => "view Results",
   -background => "cyan",
   -command    => \&button1_sub
)->pack( -side => "right" );

$mw->Button( -text => "Exit", -command => sub { exit } )
 ->pack( -side => "bottom" );

sub button1_sub {
   my $subwin1 = $mw->Toplevel;
   $subwin1->geometry( "500x400" );
$subwin1->title( "Sub Window #1" );

   my $fh;
  open( $fh, '+<', "./test.txt" ) or die $!;
   my @contents = <$fh>;
#   print "@contents\n";
   close( $fh );

  my $sublable = $subwin1->Scrolled( 'Text', -scrollbars => 'osoe', )-
+>pack;
  $sublable->insert( 'end', @contents );

 my $subwin_button = $subwin1->Button(
      -text    => "Close window",
      -command => [$subwin1 => 'destroy'],
    )->pack( -side => "bottom" );

#=================Creating save buttion on subwindow ===========

my $save_button = $subwin1->Button(-text=>'save',
   -command =>\&get_save, -background =>'cyan')->pack(-side=>'right');
}
MainLoop;
sub get_save {

        my $dst  = $mw->getSaveFile(
            -initialdir       => '/root/',
            -defaultextension => '.in',
            -initialfile        =>'test.txt',
             -title            => 'Save',
            -filetypes        => [
                [ 'myfiles'    => '.in' ],
                [ 'All files' => '*'    ],
            ],
        );

      $dst ||= '<undef>';
      warn "dst=$dst";
}

[download]

Replies are listed 'Best First'.
Re: opening multiple sub-windows in perl tk
by zentara (Archbishop) on Nov 18, 2010 at 13:27 UTC
    I'm not sure exactly what you are after... but this prevents multiple view button pushes, closes the subwindow, and resets the view button. The downside is needing subwin1 to be a global, but that is good anyways for memory reuse of the subwin1 object. 
    #!/usr/bin/perl -w
use warnings;
use strict;
use Tk;
use Tk::FileSelect;

my $mw = MainWindow->new;

$mw->configure( -background => 'black', -foreground => 'white' );
$mw->geometry( "400x100" );
$mw->title( "Multiple Windows Test" );

my $button1;
my $subwin1;

$button1 = $mw->Button(
   -text       => "view Results",
   -background => "cyan",
   -command    => \&button1_sub
)->pack( -side => "right" );

$mw->Button( -text => "Exit", -command => sub { exit } )
 ->pack( -side => "bottom" );

sub button1_sub {
   $button1->configure(-state=>'disabled'); 
   $subwin1 = $mw->Toplevel;
   $subwin1->geometry( "500x400" );
   $subwin1->title( "Sub Window #1" );

   my $fh;
  open( $fh, '+<', "./test.txt" ) or die $!;
   my @contents = <$fh>;
#   print "@contents\n";
   close( $fh );

  my $sublable = $subwin1->Scrolled( 'Text', -scrollbars => 'osoe', )-
+>pack;
  $sublable->insert( 'end', @contents );

 my $subwin_button = $subwin1->Button(
      -text    => "Close window",
      -command => [$subwin1 => 'destroy'],
    )->pack( -side => "bottom" );

#=================Creating save buttion on subwindow ===========

my $save_button = $subwin1->Button(-text=>'save',
   -command =>\&get_save, -background =>'cyan')->pack(-side=>'right');
}

MainLoop;

sub get_save {

        my $dst  = $mw->getSaveFile(
            -initialdir       => '/root/',
            -defaultextension => '.in',
            -initialfile        =>'test.txt',
             -title            => 'Save',
            -filetypes        => [
                [ 'myfiles'    => '.in' ],
                [ 'All files' => '*'    ],
            ],
        );

      $dst ||= '<undef>';
      warn "dst=$dst";
  
     $button1->configure(-state=>'normal'); 
     $subwin1->withdraw;
}

    [download]
    I'm not really a human, but I play one on earth.
    Old Perl Programmer Haiku ................... flash japh
[reply]
[d/l]
Re: opening multiple sub-windows in perl tk
by kcott (Archbishop) on Nov 18, 2010 at 17:21 UTC

    Here's two ways you can stop the button from being repeatedly invoked:

    1. Check if the Toplevel already exists.
    2. Use a local grab.

    Checking for existence:

    use strict;
use warnings;

use Tk;

my $mw = MainWindow->new();

my $single_tl;

$mw->Button(-text => 'Open Toplevel',
    -command => sub {
        if (Exists($single_tl)) {
            $mw->messageBox(-message => 'Already Open');
        }
        else {
            $single_tl = $mw->Toplevel();
            $single_tl->Button(-text => 'Close',
                -command => sub { $single_tl->destroy(); },
            )->pack();
        }
    },
)->pack();

$mw->Button(-text => 'Exit', -command => sub { exit })->pack();

MainLoop;

    [download]

    Using a grab:

    use strict;
use warnings;

use Tk;

my $mw = MainWindow->new();

$mw->Button(-text => 'Open Toplevel',
    -command => sub {
        my $single_tl = $mw->Toplevel();
        $single_tl->Button(-text => 'Close',
            -command => sub { $single_tl->destroy(); },
        )->pack();
        $single_tl->grab();
    },
)->pack();

$mw->Button(-text => 'Exit', -command => sub { exit })->pack();

MainLoop;

    [download]

    Please note that both of these pieces of code are self-contained, will run without requiring further code and are not cluttered with irrelevant, cosmetic instructions (e.g. changing colours, resizing windows and so on). Please read How do I post a question effectively? paying particular attention to "... a minimal script that reproduces your problem ..."

    Furthermore, your zig-zag indentation is not particularly easy to ready. Please choose an indentation style and use it. perlstyle may help you with this.

    You've received help on quite a few questions you've posted in recent weeks. Consider helping those who are helping you.

    -- Ken

[reply]
[d/l]
[select]
Re: opening multiple sub-windows in perl tk
by viveksnv (Sexton) on Nov 18, 2010 at 11:39 UTC
    Hi,
    I am not an expert in perl.
    I tried the code below, surely this is not the correct way. but i wanted to share it with perlmonks.
    Another possibility is, if possible, we can pass the variable $subwin1 with all Tk properties to subroutine get_save. I tried, but the properties are not going to travel to sub get_save.
    #!/usr/bin/perl -w
use warnings;
use strict;
use Tk;
use Tk::FileSelect;

my $mw = MainWindow->new;

$mw->configure( -background => 'black', -foreground => 'white' );
$mw->geometry( "400x100" );
$mw->title( "Multiple Windows Test" );

my $button1 = $mw->Button(
   -text       => "view Results",
   -background => "cyan",
   -command    => \&button1_sub
)->pack( -side => "right" );

$mw->Button( -text => "Exit", -command => sub { exit } )
 ->pack( -side => "bottom" );

sub button1_sub {
   our $subwin1 = $mw->Toplevel;
   $subwin1->geometry( "500x400" );
$subwin1->title( "Sub Window #1" );

   my $fh;
  open( $fh, '+<', "./test.txt" ) or die $!;
   my @contents = <$fh>;
#   print "@contents\n";
   close( $fh );

  my $sublable = $subwin1->Scrolled( 'Text', -scrollbars => 'osoe', )-
+>pack;
  $sublable->insert( 'end', @contents );

 my $subwin_button = $subwin1->Button(
      -text    => "Close window",
      -command => [$subwin1 => 'destroy'],
    )->pack( -side => "bottom" );

#=================Creating save buttion on subwindow ===========

my $save_button = $subwin1->Button(-text=>'save',
   -command =>\&get_save, -background =>'cyan')->pack(-side=>'right');

sub get_save {

        my $dst  = $subwin1->getSaveFile(
            -initialdir       => '/root/',
            -defaultextension => '.in',
            -initialfile        =>'test.txt',
             -title            => 'Save',
            -filetypes        => [
                [ 'myfiles'    => '.in' ],
                [ 'All files' => '*'    ],
            ],
        );

      $dst ||= '<undef>';
      warn "dst=$dst";
}


}
MainLoop;

    [download]

    Regards,
    Vivek
[reply]
[d/l]
Re: opening multiple sub-windows in perl tk
by zentara (Archbishop) on Nov 18, 2010 at 16:23 UTC
    Here are a couple of scripts to show how to make a reusable toplevel window. The first is very simple, the second shows repacking the toplevel with new widgets. 
    #!/usr/bin/perl
use warnings;
use strict;
use Tk;

my $tl;
my $mw = MainWindow->new;
$mw->title( "MainWindow" );

my $spawn_button = $mw->Button( -text => "Toplevel", 
                -command => \&do_Toplevel )->pack();

MainLoop;

sub do_Toplevel {
        $spawn_button->configure(-state=>'disabled');

    if ( !Exists( $tl ) ) {
        $tl = $mw->Toplevel();
        
        $tl->protocol('WM_DELETE_WINDOW' => sub {
                     print "do nothing here\n"; #prevents destruction 
+of $tl
                                        #by WM control
         });
        
        $tl->geometry('300x100+100+100');
        $tl->title( "Toplevel" );
        $tl->Button(
            -text    => "Close",
            -command => sub { $tl->withdraw; 
                 $spawn_button->configure(-state=>'normal');
                 }
        )->pack;
    }
    else {
        $tl->deiconify();
        $tl->raise();
    }
}

    [download]
    more complex.....and useful 
    #!/usr/bin/perl
use warnings;
use strict;
use Tk;


my $mw = MainWindow->new;
$mw->title( "MainWindow" );

my $spawn_button = $mw->Button( -text => "Toplevel", 
                -command => \&do_Toplevel )->pack();

my $change_button = $mw->Button( -text => "Toplevel repacked", 
                -command => \&do_Toplevel_repack )->pack();

######### make a top level withdrawn ##################
# make $tl global so it's memory space is reused
my $tl = $mw->Toplevel();
$tl->protocol('WM_DELETE_WINDOW' => sub {
         print "do nothing here\n"; #prevents destruction of $tl
                                #by WM control
  });
        
$tl->geometry('300x300+100+100');
$tl->title( "Toplevel" );
$tl->Button(
    -text    => "Close",
    -command => sub { $tl->withdraw; 
        $spawn_button->configure(-state=>'normal');
        $change_button->configure(-state=>'normal');
     })->pack();

$tl->withdraw;


MainLoop;

sub do_Toplevel {
        $spawn_button->configure(-state=>'disabled');
        $change_button->configure(-state=>'disabled');
        $tl->deiconify();
        $tl->raise();
}

sub do_Toplevel_repack {
        $spawn_button->configure(-state=>'disabled');
        $change_button->configure(-state=>'disabled');
    
    #clean out top level
    my @w = $tl->packSlaves;
    foreach (@w) { $_->packForget; }

        $tl->title( "Toplevel repack" );
        $tl->geometry('300x500+100+100');
        $tl->Button(
    -text    => "Close1",
    -command => sub { $tl->withdraw; 
           $spawn_button->configure(-state=>'normal');
           $change_button->configure(-state=>'normal');
        })->pack();

         my $text = $tl->Scrolled('Text')->pack();
    
         for (1..100){
        $text->insert('end', "$_\n");
        $text->see('end');
    }

     #add whatever widgets you want here
     # Entries, etc

        $tl->Button(
    -text    => "Add button to mainwindow",
    -command => sub { 
        $mw->Button(-text=>'new Button')->pack(-side =>'bottom');
    })->pack();

    
    $tl->deiconify();
    $tl->raise();
}

    [download]
    I'm not really a human, but I play one on earth.
    Old Perl Programmer Haiku ................... flash japh
[reply]
[d/l]
[select]

Back to Seekers of Perl Wisdom

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: perlquestion [id://872146]
Approved by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others browsing the Monastery: (2)
As of 2024-04-26 04:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found