sub messageBox
{
my ($widget,%args) = @_;
# remove in a later version:
if (exists $args{'-text'})
{
warn "The -text option is deprecated. Please use -message instead";
if (!exists $args{'-message'})
{
$args{'-message'} = delete $args{'-text'};
}
}
$args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok';
$args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'});
ucfirst tk_messageBox(-parent => $widget, %args);
}
####
sub Methods
{
my ($package) = caller;
no strict 'refs';
foreach my $meth (@_)
{
my $name = $meth;
*{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) };
}
}
my %dialog = ( tk_chooseColor => 'ColorDialog',
tk_messageBox => 'MessageBox',
...
####
sub MessageBox {
my ($kind,%args) = @_;
require Tk::Dialog;
my $parent = delete $args{'-parent'};
my $args = \%args;
$args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon};
$args->{-text} = delete $args->{-message} if defined $args->{-message};
$args->{-type} = 'OK' unless defined $args->{-type};
my $type;
if (defined($type = delete $args->{-type})) {
delete $args->{-type};
my @buttons = grep($_,map(ucfirst($_),
split(/(abort|retry|ignore|yes|no|cancel|ok)/,
lc($type))));
$args->{-buttons} = [@buttons];
$args->{-default_button} = ucfirst(delete $args->{-default}) if
defined $args->{-default};
if (not defined $args->{-default_button} and scalar(@buttons) == 1) {
$args->{-default_button} = $buttons[0];
}
my $md = $parent->Dialog(%$args);
my $an = $md->Show;
$md->destroy if Tk::Exists($md);
return $an;
}
} # end messageBox
####
sub MessageBox {
my ($kind,%args) = @_;
require Tk::Dialog;
my $parent = delete $args{'-parent'};
my $args = \%args;
$args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon};
$args->{-text} = delete $args->{-message} if defined $args->{-message};
$args->{-type} = 'OK' unless defined $args->{-type};
my $type;
if (defined($type = delete $args->{-type})) {
delete $args->{-type};
my @buttons = grep($_,map(ucfirst($_),
split(/(abort|retry|ignore|yes|no|cancel|ok)/,
lc($type))));
$args->{-buttons} = [@buttons];
$args->{-default_button} = ucfirst(delete $args->{-default}) if
defined $args->{-default};
if (not defined $args->{-default_button} and scalar(@buttons) == 1) {
$args->{-default_button} = $buttons[0];
}
my $md = $parent->Dialog(%$args);
my $an = $md->Show;
$md->destroy if Tk::Exists($md);
return $an;
}
} # end messageBox