# 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.
$VERSION = '3.028'; # $Id: //depot/Tk8/Tk/Toplevel.pm#28 $
use base qw(Tk::Wm Tk::Frame);
Construct Tk
::Widget
'Toplevel';
sub Tk_cmd
{ \
&Tk
::toplevel
}
return (shift->SUPER::CreateOptions
,'-screen','-use')
$cw->SUPER::Populate
($arg);
$cw->ConfigSpecs('-title',['METHOD',undef,undef,$cw->class]);
my $icon = $top->iconwindow;
if ($state ne 'withdrawn')
$top->update; # Let attributes propogate
$icon = Tk
::Toplevel
->new($top,'-borderwidth' => 0,'-class'=>'Icon');
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
$lab->DisableButtonEvents;
$top->iconimage($args{'-image'}) if (exists $args{'-image'});
$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');
$menu = $w->cget('-menu');
$w->configure(-menu
=> ($menu = $w->SUPER::menu
))
$menu->configure(@_) if @_;
#----------------------------------------------------------------------
# Focus groups are used to handle the user's focusing actions inside a
# One example of using focus groups is: when the user focuses on an
# entry, the text in the entry is highlighted and the cursor is put to
# the end of the text. When the user changes focus to another widget,
# the text in the previously focused entry is validated.
#----------------------------------------------------------------------
# Create a focus group. All the widgets in a focus group must be
# within the same focus toplevel. Each toplevel can have only
# one focus group, which is identified by the name of the
unless (exists $t->{'_fg'}) {
$t->bind('<FocusIn>', sub {
$t->bind('<FocusOut>', sub {
$t->bind('<Destroy>', sub {
# <Destroy> is not sufficient to break loops if never mapped.
$t->OnDestroy([$t,'FG_Destroy']);
# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
# called when the widget is focused on by the user.
$t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
$t->{'_FocusIn'}{$w} = Tk
::Callback
->new($cmd);
# tkFocusGroup_BindOut --
# Add a widget into the "FocusOut" list of the focus group. The
# $cmd will be called when the widget loses the focus (User
# types Tab or click on another widget).
$t->Error("focus group \"$t\" doesn't exist") unless (exists $t->{'_fg'});
$t->{'_FocusOut'}{$w} = Tk
::Callback
->new($cmd);
# tkFocusGroup_Destroy --
# Cleans up when members of the focus group is deleted, or when the
# toplevel itself gets deleted.
if (!defined($w) || $t == $w) {
delete $t->{'_FocusOut'};
if (exists $t->{'_focus'}) {
delete $t->{'_focus'} if ($t->{'_focus'} == $w);
delete $t->{'_FocusIn'}{$w};
delete $t->{'_FocusOut'}{$w};
# Handles the <FocusIn> event. Calls the FocusIn command for the newly
# focused widget in the focus group.
my($t, $w, $detail) = @_;
if (defined $t->{'_focus'} and $t->{'_focus'} eq $w) {
# This is already in focus
$t->{'_FocusIn'}{$w}->Call if exists $t->{'_FocusIn'}{$w};
# Handles the <FocusOut> event. Checks if this is really a lose
# focus event, not one generated by the mouse moving out of the
# toplevel window. Calls the FocusOut command for the widget
my($t, $w, $detail) = @_;
if ($detail ne 'NotifyNonlinear' and $detail ne 'NotifyNonlinearVirtual') {
# This is caused by mouse moving out of the window
unless (exists $t->{'_FocusOut'}{$w}) {
$t->{'_FocusOut'}{$w}->Call;