home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / MainWindow.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  2.9 KB  |  141 lines
  1. # Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::MainWindow;
  5. @Tk::MainWindow::ISA = qw(Tk::Toplevel);
  6. @MainWindow::ISA = 'Tk::MainWindow';
  7.  
  8. use AutoLoader;  
  9.  
  10. use strict;
  11. use Tk::CmdLine;
  12. require Tk;
  13. require Tk::Toplevel;
  14.  
  15. use Carp;
  16.  
  17. $| = 1;
  18.  
  19.  
  20. my $pid = $$;
  21.  
  22. my @Windows = ();
  23.  
  24. sub CreateArgs
  25. {
  26.  my ($class,$args) = @_;
  27.  my $cmd = Tk::CmdLine::CreateArgs();
  28.  my $key;
  29.  foreach $key (keys %$cmd)
  30.   {
  31.    $args->{$key} = $cmd->{$key} unless exists $args->{$key};
  32.   }
  33.  my %result = $class->SUPER::CreateArgs(undef,$args);
  34.  my $name = delete($args->{'-name'});
  35.  $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'});
  36.  $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'};
  37.  return ("\l$name",%result);
  38. }
  39.  
  40. sub new
  41. {
  42.  my $package = shift;
  43.  if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/)
  44.   {
  45.    carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W;
  46.    unshift(@_,'-screen');
  47.   }
  48.  croak("Odd number of args"."$package->new(" . join(',',@_) .")") if @_ % 2;
  49.  my %args = @_;
  50.  my $top = eval { bless Create($package->CreateArgs(\%args)), $package };
  51.  croak($@ . "$package->new(" . join(',',@_) .")") if ($@);
  52.  $top->apply_command_line;
  53.  $top->InitBindings;
  54.  $top->InitObject(\%args);
  55.  eval { $top->configure(%args) };
  56.  croak "$@" if ($@);
  57.  $top->SetBindtags;
  58.  push(@Windows,$top);
  59.  return $top;
  60. }
  61.  
  62. sub InitBindings
  63. {
  64.  my $mw = shift;
  65.  $mw->bind('all',"<Tab>","focusNext");
  66.  $mw->bind('all',"<Shift-Tab>","focusPrev");
  67.                                     
  68.  $mw->bind('all',"<Alt-KeyPress>",['TraverseToMenu',Tk::Ev('A')]);
  69.  $mw->bind('all',"<F10>",'FirstMenu');
  70. }
  71.  
  72.  
  73. sub Existing
  74. {
  75.  grep( Tk::Exists($_), @Windows);  
  76. }
  77.  
  78.  
  79. END
  80. {
  81.  if ($pid == $$)
  82.   {
  83.    my $top;
  84.    while ($top = pop(@Windows))
  85.     {
  86.      if ($top->IsWidget)
  87.       {
  88.        # Tk data structuctures are still in place
  89.        # this can occur if non-callback perl code did a 'die'.
  90.        # It will also handle some cases of non-Tk 'exit' being called
  91.        # Destroy this mainwindow and hence is descendants ...
  92.        $top->destroy; 
  93.       }
  94.     }
  95.   }
  96. }
  97.  
  98. sub CmdLine { return shift }
  99.  
  100. sub WMSaveYourself
  101. {
  102.  my $mw  = shift;
  103.  my @args = @{$mw->command};
  104.  warn "preWMSaveYourself:".join(' ',@args)."\n";
  105.  @args = ($0) unless (@args);
  106.  my $i = 1;
  107.  while ($i < @args)
  108.   {
  109.    if ($args[$i] eq '-iconic')
  110.     {
  111.      splice(@args,$i,1); 
  112.     }
  113.    elsif ($args[$i] =~ /^-(geometry|iconposition)$/)
  114.     {
  115.      splice(@args,$i,2); 
  116.     }
  117.   }
  118.  
  119.  my @ip = $mw->wm('iconposition');
  120.  print "ip ",join(',',@ip),"\n";
  121.  my $icon = $mw->iconwindow;
  122.  if (defined($icon))
  123.   {
  124.    @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/;
  125.   }
  126.  splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2);
  127.  
  128.  splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic');
  129.  
  130.  splice(@args,1,0,'-geometry' => $mw->geometry);
  131.  warn "postWMSaveYourself:".join(' ',@args)."\n";
  132.  $mw->command([@args]);
  133. }
  134.  
  135.  
  136. 1;
  137.  
  138. __END__
  139.  
  140.  
  141.