home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _d74222e815075b596af93b21b4a25a1e < prev    next >
Encoding:
Text File  |  2004-06-01  |  5.7 KB  |  214 lines
  1. # Copyright (c) 1995-2003 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. use base qw(Tk::Toplevel);
  6. BEGIN { @MainWindow::ISA = 'Tk::MainWindow' }
  7.  
  8. use strict;
  9.  
  10. use vars qw($VERSION);
  11. $VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/;
  12.  
  13. use Tk::CmdLine;
  14. use Tk qw(catch);
  15. require Tk::Toplevel;
  16.  
  17. use Carp;
  18.  
  19. $| = 1;
  20.  
  21. my $pid = $$;
  22.  
  23. my %Windows = ();
  24.  
  25. sub CreateArgs
  26. {
  27.  my ($class,$args) = @_;
  28.  my $cmd = Tk::CmdLine->CreateArgs();
  29.  my $key;
  30.  foreach $key (keys %$cmd)
  31.   {
  32.    $args->{$key} = $cmd->{$key} unless exists $args->{$key};
  33.   }
  34.  my %result = $class->SUPER::CreateArgs(undef,$args);
  35.  my $name = delete($args->{'-name'});
  36.  unless (Tk::tainting)
  37.   {
  38.    $ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'});
  39.    $result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'};
  40.   }
  41.  return (-name => "\l$name",%result);
  42. }
  43.  
  44. sub new
  45. {
  46.  my $package = shift;
  47.  if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/)
  48.   {
  49.    carp "Usage $package->new(-screen => '$_[0]' ...)" if $^W;
  50.    unshift(@_,'-screen');
  51.   }
  52.  croak('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2;
  53.  my %args = @_;
  54.  
  55.  my $top = eval { bless Create($package->CreateArgs(\%args)), $package };
  56.  croak($@ . "$package->new(" . join(',',@_) .')') if ($@);
  57.  $top->apply_command_line;
  58.  $top->InitBindings;
  59.  $top->SetBindtags;
  60.  $top->InitObject(\%args);
  61.  eval { $top->configure(%args) };
  62.  croak "$@" if ($@);
  63.  if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') {
  64.      my $geometry = $top->optionGet(qw(geometry Geometry));
  65.      if ($geometry) {
  66.      $top->geometry($geometry);
  67.      }
  68.  }
  69.  $Windows{$top} = $top;
  70.  return $top;
  71. }
  72.  
  73. sub _Destroyed
  74. {
  75.  my $top = shift;
  76.  $top->SUPER::_Destroyed;
  77.  delete $Windows{$top};
  78. }
  79.  
  80. sub InitBindings
  81. {
  82.  my $mw = shift;
  83.  $mw->bind('all','<Tab>','focusNext');
  84.  # <<LeftTab>> is named <<PrevWindow>> in Tcl/Tk
  85.  $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]);
  86.  # This is needed for XFree86 systems
  87.  catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) };
  88.  # This seems to be correct on *some* HP systems.
  89.  catch { $mw->eventAdd(qw[<<LeftTab>> <hpBackTab>]) };
  90.  $mw->bind('all','<<LeftTab>>','focusPrev');
  91.  if ($mw->windowingsystem eq 'x11')
  92.   {
  93.    $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]);
  94.    $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]);
  95.    $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]);
  96.    $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
  97.    $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14>
  98.                     <Control-Key-underscore>]);
  99.    $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]);
  100.   }
  101.  elsif ($mw->windowingsystem eq 'win32')
  102.   {
  103.    $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]);
  104.    $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]);
  105.    $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]);
  106.    $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]);
  107.    $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]);
  108.   }
  109.  elsif ($mw->windowingsystem eq 'aqua')
  110.   {
  111.    $mw->eventAdd(qw[<<Cut>> <Command-Key-x> <Key-F2>]);
  112.    $mw->eventAdd(qw[<<Copy>> <Command-Key-c> <Key-F3>]);
  113.    $mw->eventAdd(qw[<<Paste>> <Command-Key-v> <Key-F4>]);
  114.    $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
  115.    $mw->eventAdd(qw[<<Clear>> <Clear>]);
  116.    $mw->eventAdd(qw[<<Undo>> <Command-Key-z>]);
  117.    $mw->eventAdd(qw[<<Redo>> <Command-Key-y>]);
  118.   }
  119.  elsif ($mw->windowingsystem eq 'classic')
  120.   {
  121.    $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F2>]);
  122.    $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F3>]);
  123.    $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F4>]);
  124.    $mw->eventAdd(qw[<<PasteSelection>> <ButtonRelease-2>]);
  125.    $mw->eventAdd(qw[<<Clear>> <Clear>]);
  126.    $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-F1>]);
  127.    $mw->eventAdd(qw[<<Redo>> <Control-Key-Z>]);
  128.   }
  129.  
  130.  # FIXME - Should these move to Menubutton ?
  131.  my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton';
  132.  $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]);
  133.  $mw->bind($c,'<F10>','FirstMenu');
  134. }
  135.  
  136. sub Existing
  137. {
  138.  my @Windows;
  139.  foreach my $name (keys %Windows)
  140.   {
  141.    my $obj = $Windows{$name};
  142.    if (Tk::Exists($obj))
  143.     {
  144.      push(@Windows,$obj);
  145.     }
  146.    else
  147.     {
  148.      delete $Windows{$name};
  149.     }
  150.   }
  151.  return @Windows;
  152. }
  153.  
  154. END
  155. {
  156.  if (Tk::IsParentProcess())
  157.   {
  158.    foreach my $top (values %Windows)
  159.     {
  160.      if ($top->IsWidget)
  161.       {
  162.        # Tk data structuctures are still in place
  163.        # this can occur if non-callback perl code did a 'die'.
  164.        # It will also handle some cases of non-Tk 'exit' being called
  165.        # Destroy this mainwindow and hence is descendants ...
  166.        $top->destroy;
  167.       }
  168.     }
  169.   }
  170. }
  171.  
  172. sub CmdLine { return shift->command }
  173.  
  174. sub WMSaveYourself
  175. {
  176.  my $mw  = shift;
  177.  my @args = @{$mw->command};
  178. # warn 'preWMSaveYourself:'.join(' ',@args)."\n";
  179.  @args = ($0) unless (@args);
  180.  my $i = 1;
  181.  while ($i < @args)
  182.   {
  183.    if ($args[$i] eq '-iconic')
  184.     {
  185.      splice(@args,$i,1);
  186.     }
  187.    elsif ($args[$i] =~ /^-(geometry|iconposition)$/)
  188.     {
  189.      splice(@args,$i,2);
  190.     }
  191.   }
  192.  
  193.  my @ip = $mw->wm('iconposition');
  194. # print 'ip ',join(',',@ip),"\n";
  195.  my $icon = $mw->iconwindow;
  196.  if (defined($icon))
  197.   {
  198.    @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/;
  199.   }
  200.  splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2);
  201.  
  202.  splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic');
  203.  
  204.  splice(@args,1,0,'-geometry' => $mw->geometry);
  205. # warn 'postWMSaveYourself:'.join(' ',@args)."\n";
  206.  $mw->command([@args]);
  207. }
  208.  
  209. 1;
  210.  
  211. __END__
  212.  
  213. =cut
  214.