Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Copyright (c) 1995-1999 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 = '3.047'; # $Id: //depot/Tk8/Tk/MainWindow.pm#47 $ | |
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 | $mw->eventAdd(qw[<<LeftTab>> <Shift-Tab>]); | |
85 | catch { $mw->eventAdd(qw[<<LeftTab>> <ISO_Left_Tab>]) }; | |
86 | $mw->bind('all','<<LeftTab>>','focusPrev'); | |
87 | if ($Tk::platform eq 'unix') | |
88 | { | |
89 | $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Key-F20> <Meta-Key-w>]); | |
90 | $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Key-F16> <Control-Key-w>]); | |
91 | $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Key-F18> <Control-Key-y>]); | |
92 | $mw->eventAdd(qw[<<Undo>> <Control-Key-z> <Key-Undo> <Key-F14> | |
93 | <Control-Key-underscore>]); | |
94 | $mw->eventAdd(qw[<<Redo>> <Control-Key-y> <Shift-Key-Undo> <Key-F12> <Shift-Key-F14>]); | |
95 | } | |
96 | else | |
97 | { | |
98 | $mw->eventAdd(qw[<<Cut>> <Control-Key-x> <Shift-Key-Delete>]); | |
99 | $mw->eventAdd(qw[<<Copy>> <Control-Key-c> <Control-Key-Insert>]); | |
100 | $mw->eventAdd(qw[<<Paste>> <Control-Key-v> <Shift-Key-Insert>]); | |
101 | $mw->eventAdd(qw[<<Undo>> <Control-Key-z>]); | |
102 | $mw->eventAdd(qw[<<Redo>> <Control-Key-y>]); | |
103 | } | |
104 | ||
105 | # FIXME - Should these move to Menubutton ? | |
106 | my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton'; | |
107 | $mw->bind($c,'<Alt-KeyPress>',['TraverseToMenu',Tk::Ev('K')]); | |
108 | $mw->bind($c,'<F10>','FirstMenu'); | |
109 | } | |
110 | ||
111 | sub Existing | |
112 | { | |
113 | my @Windows; | |
114 | foreach my $name (keys %Windows) | |
115 | { | |
116 | my $obj = $Windows{$name}; | |
117 | if (Tk::Exists($obj)) | |
118 | { | |
119 | push(@Windows,$obj); | |
120 | } | |
121 | else | |
122 | { | |
123 | delete $Windows{$name}; | |
124 | } | |
125 | } | |
126 | return @Windows; | |
127 | } | |
128 | ||
129 | END | |
130 | { | |
131 | if ($pid == $$) | |
132 | { | |
133 | foreach my $top (values %Windows) | |
134 | { | |
135 | if ($top->IsWidget) | |
136 | { | |
137 | # Tk data structuctures are still in place | |
138 | # this can occur if non-callback perl code did a 'die'. | |
139 | # It will also handle some cases of non-Tk 'exit' being called | |
140 | # Destroy this mainwindow and hence is descendants ... | |
141 | $top->destroy; | |
142 | } | |
143 | } | |
144 | } | |
145 | } | |
146 | ||
147 | sub CmdLine { return shift->command } | |
148 | ||
149 | sub WMSaveYourself | |
150 | { | |
151 | my $mw = shift; | |
152 | my @args = @{$mw->command}; | |
153 | warn 'preWMSaveYourself:'.join(' ',@args)."\n"; | |
154 | @args = ($0) unless (@args); | |
155 | my $i = 1; | |
156 | while ($i < @args) | |
157 | { | |
158 | if ($args[$i] eq '-iconic') | |
159 | { | |
160 | splice(@args,$i,1); | |
161 | } | |
162 | elsif ($args[$i] =~ /^-(geometry|iconposition)$/) | |
163 | { | |
164 | splice(@args,$i,2); | |
165 | } | |
166 | } | |
167 | ||
168 | my @ip = $mw->wm('iconposition'); | |
169 | print 'ip ',join(',',@ip),"\n"; | |
170 | my $icon = $mw->iconwindow; | |
171 | if (defined($icon)) | |
172 | { | |
173 | @ip = $icon->geometry =~ /\d+x\d+([+-]\d+)([+-]\d+)/; | |
174 | } | |
175 | splice(@args,1,0,'-iconposition' => join(',',@ip)) if (@ip == 2); | |
176 | ||
177 | splice(@args,1,0,'-iconic') if ($mw->state() eq 'iconic'); | |
178 | ||
179 | splice(@args,1,0,'-geometry' => $mw->geometry); | |
180 | warn 'postWMSaveYourself:'.join(' ',@args)."\n"; | |
181 | $mw->command([@args]); | |
182 | } | |
183 | ||
184 | 1; | |
185 | ||
186 | __END__ | |
187 | ||
188 | =cut |