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