#!/usr/bin/perl --
use strict;
use warnings;
use Tk;
use Tk::Dialog;
my $mw = new MainWindow;
$mw->geometry( "300x300" );
my $label = $mw -> Label(-text=>"Hello World") -> pack();
for my $relief ( qw/ raised sunken flat ridge solid groove / ){
    my $button = $mw -> Button(
        -text => $relief, 
        -command => sub {
            myMessageBox(
                -parent => $Tk::widget,
                -relief => $relief,,
#~             $Tk::widget->messageBox(
                -message => "The $relief glossary has been merged", 
                -icon=> 'info',
            );
        },
        -relief => $relief,
        -width => 10,
    )-> pack();
}
#~ $mw->WidgetDump;use Tk::WidgetDump;
$mw->MainLoop;

sub myMessageBox {
    my (%args) = @_;
    require Tk::Dialog;
    my $parent = delete $args{'-parent'};
    my $relief = delete $args{'-relief'};
    my $args   = \%args;

    $args->{-bitmap} = delete $args->{-icon}    if defined $args->{-ic
+on};
    $args->{-text}   = delete $args->{-message} if defined $args->{-me
+ssage};
    $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($ty
+pe) ) ) );
        $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);
        for my $b ( grep { $_->isa('Tk::Button') } $md->Subwidget('bot
+tom')->children )
        {
            $b->configure( -relief => $relief, -overrelief => $relief 
+);
        }
        my $an = $md->Show;
        $md->destroy if Tk::Exists($md);
        return $an;
    }
}


__END__
[download]