# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
use base
qw(Tk::Toplevel);
BEGIN { @MainWindow::ISA
= 'Tk::MainWindow' }
$VERSION = '3.047'; # $Id: //depot/Tk8/Tk/MainWindow.pm#47 $
my $cmd = Tk
::CmdLine
->CreateArgs();
foreach $key (keys %$cmd)
$args->{$key} = $cmd->{$key} unless exists $args->{$key};
my %result = $class->SUPER::CreateArgs
(undef,$args);
my $name = delete($args->{'-name'});
$ENV{'DISPLAY'} = ':0' unless (exists $ENV{'DISPLAY'});
$result{'-screen'} = $ENV{'DISPLAY'} unless exists $result{'-screen'};
return (-name
=> "\l$name",%result);
if (@_ > 0 && $_[0] =~ /:\d+(\.\d+)?$/)
carp
"Usage $package->new(-screen => '$_[0]' ...)" if $^W
;
croak
('Odd number of args'."$package->new(" . join(',',@_) .')') if @_ % 2;
my $top = eval { bless Create
($package->CreateArgs(\
%args)), $package };
croak
($@
. "$package->new(" . join(',',@_) .')') if ($@
);
$top->apply_command_line;
$top->InitObject(\
%args);
eval { $top->configure(%args) };
if (($top->positionfrom||'') ne 'user' and ($top->sizefrom||'') ne 'user') {
my $geometry = $top->optionGet(qw(geometry Geometry));
$top->geometry($geometry);
$mw->bind('all','<Tab>','focusNext');
$mw->eventAdd(qw
[<<LeftTab>> <Shift-Tab>]);
catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab
>]) };
$mw->bind('all','<<LeftTab>>','focusPrev');
if ($Tk::platform
eq 'unix')
$mw->eventAdd(qw
[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]);
$mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]);
$mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]);
$mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key
-F14
>
<Control
-Key
-underscore
>]);
$mw->eventAdd(qw
[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]);
$mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]);
$mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]);
$mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]);
$mw->eventAdd(qw[<<Undo>> <Control-Key-z>]);
$mw->eventAdd(qw[<<Redo>> <Control
-Key
-y
>]);
# FIXME - Should these move to Menubutton ?
my $c = ($Tk::platform
eq 'unix') ?
'all' : 'Tk::Menubutton';
$mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk
::Ev
('K')]);
$mw->bind($c,'<F10>','FirstMenu');
foreach my $name (keys %Windows)
my $obj = $Windows{$name};
foreach my $top (values %Windows)
# Tk data structuctures are still in place
# this can occur if non-callback perl code did a 'die'.
# It will also handle some cases of non-Tk 'exit' being called
# Destroy this mainwindow and hence is descendants ...
sub CmdLine
{ return shift->command }
my @args = @
{$mw->command};
warn 'preWMSaveYourself:'.join(' ',@args)."\n";
@args = ($0) unless (@args);
if ($args[$i] eq '-iconic')
elsif ($args[$i] =~ /^-(geometry|iconposition)$/)
my @ip = $mw->wm('iconposition');
print 'ip ',join(',',@ip),"\n";
my $icon = $mw->iconwindow;
@ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/;
splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2);
splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic');
splice(@args,1,0,'-geometry' => $mw->geometry);
warn 'postWMSaveYourself:'.join(' ',@args)."\n";