package Tk::MyOwnBalloon;

use strict;
use warnings;
use Carp qw/croak/;

use Tk::widgets qw/ Balloon /;
use base qw/ Tk::Derived Tk::Balloon /;

Construct Tk::Widget 'MyOwnBalloon';


=head1 Beschreibung

Modifikation von Tk::Ballon: Zeigt einen Hintergrundschatten für das Popup an.




=head1 METHODEN

=head2 ClassInit( $mw )

=cut

sub ClassInit {
	my( $class, $mw ) = @_;
	#... e.g., class bindings here ...
	$class->SUPER::ClassInit( $mw );
} # /ClassInit




=head2 Populate( $args )

=cut

sub Populate {
	my( $self, $args ) = @_;
	$self->SUPER::Populate( $args );
} # /Populate




=head2 Popup( ??? )

=cut

sub Popup {
    # -- Inhalt der Tk::Balloon::Popup-Funktion, aus technischen Gründen gekürzt....
	
	# -- Modifikation ab hier
	
    $w->stayOnTop ();

    # the shadow:
    unless ( $w->{'shadow'} ) {
		
		# create the toplevel 'shadow':
        $w->{'shadow'} = $w->Toplevel(
            -height	=> $w->height(),
            -width 	=> $w->width(),
		);
        $w->{'shadow'}->overrideredirect(1);

        $w->{'shadow'}->configure(-background => '#666666');
        $w->{'shadow'}->Label(-takefocus => 1)->place();

		my ($shadow_x, $shadow_y) = ($xx+2, $y+11);
        $w->{'shadow'}->geometry("+$shadow_x+$shadow_y");
		
    }else {

		my ($shadow_x, $shadow_y) = ($xx+2, $y+11);
        $w->{'shadow'}-> geometry ("+$shadow_x+$shadow_y");

		$w->{'shadow'}->configure(
			-height	=> $w->height(),
			-width	=> $w->width(),
		);

		$w->{'shadow'}->deiconify();
    }
	
} # /Popup



=head2 Deactivate( ??? )

=cut

sub Deactivate {
    my ($w) = @_;
    my $delay = delete $w->{'delay'};
    $delay->cancel if defined $delay;
    if ($w->{'popped'}) {
        my $client = $w->{'client'};
        my $command = $w->GetOption(-cancelcommand => $client);
        if (defined $command) {
            # Execute the user's command and return if it returns false:
            return if not $command->Call($client);
        }
        $w->withdraw;
            $w-> {'shadow'}-> withdraw;
        $w->ClearStatus;
        $w->{'popped'} = 0;
        $w->{'menu_index'} = 'none';
        $w->{'canvas_tag'} = '';
    }
    $w->{'client'} = undef;
    $w->{'subclient'} = undef;
    $w->{'location'} = undef;
} # /Deactivate


1;

#!/Perl/bin/perl

use strict;
use warnings;
use Data::Dumper qw/Dumper/;
use Perl6::Say;
use FindBin qw/$Bin/;
use lib $Bin;
use Tk;
use Tk::Balloon;
use Tk::PNG;
use Tk::MyOwnBalloon;

my $mw = Tk::MainWindow->new();
$mw->packPropagate(0);

# -- Tk::Baloon (Original)

my $widget = $mw->Button(
    -text       => 'press me...',
    -command    => sub{ say "push!"; },
)->pack();

my $b = $mw->Balloon();

$b->attach($widget,
    -position => 'widget',
    -balloonmsg => "Balloon help message",
);


# -- Baloon mit Schatten (modifiziert)

my $widget2 = $mw->Button(
    -text       => 'press me...',
    -command    => sub{ say "push (2)!"; },
)->pack();

my $b2 = $mw->MyOwnBalloon();

$b2->attach($widget2,
    -position => 'widget',
    -balloonmsg => "Balloon (mod.) help message",
);



$mw->MainLoop();