1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
# Copyright (c) 1995-1998 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.
package Tk::Toplevel;
require Tk::Frame;
require Tk::Wm;
use AutoLoader;
use vars qw($VERSION @ISA);
$VERSION = '3.012'; # $Id: //depot/Tk8/Tk/Toplevel.pm#12$
use base qw(Tk::Wm Tk::Frame);
Construct Tk::Widget 'Toplevel';
sub Tk_cmd { \&Tk::toplevel }
sub CreateOptions
{
return (shift->SUPER::CreateOptions,'-screen','-use')
}
sub Populate
{
my ($cw,$arg) = @_;
$cw->SUPER::Populate($arg);
$cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]);
}
sub Icon
{
my ($top,%args) = @_;
my $icon = $top->iconwindow;
my $state = $top->state;
if ($state ne 'withdrawn')
{
$top->withdraw;
$top->update; # Let attributes propogate
}
unless (defined $icon)
{
$icon = Tk::Toplevel->new($top,'-borderwidth' => 0,'-class'=>'Icon');
$icon->withdraw;
# Fake Populate
my $lab = $icon->Component('Label' => 'icon');
$lab->pack('-expand'=>1,'-fill' => 'both');
$icon->ConfigSpecs(DEFAULT => ['DESCENDANTS']);
# Now do tail of InitObject
$icon->ConfigDefault(\%args);
# And configure that new would have done
$top->iconwindow($icon);
$top->update;
$lab->DisableButtonEvents;
$lab->update;
}
$icon->configure(%args);
$icon->idletasks; # Let size request propogate
$icon->geometry($icon->ReqWidth . "x" . $icon->ReqHeight);
$icon->update; # Let attributes propogate
$top->deiconify if ($state eq 'normal');
$top->iconify if ($state eq 'iconic');
}
1;
__END__
|
