I heard this on a CBC jazz show Tonic last night, best laugh I had all day. It is a takeoff on a poem by Dorothy Parker

#!/usr/bin/perl
use warnings;
use strict;
use Tk;

my $mw=tkinit;

$mw->geometry('+300+300');

$mw->fontCreate('big',
   -family=>'arial',
  -weight=>'bold',
  -size=>int(-18*18/14));

my $c=$mw->Canvas(-width=>300,-height=>125,-bg=>'white')->pack;

$c->Pixmap( 'martini', -data => get_one() );

my $t1 = $c->create('text',310,40,
              -anchor=>'w',
              -font => 'big',
              -text=>'My limit is 1 martini');

my $t2 = $c->create('text',310,60,
              -anchor=>'w',
              -font => 'big',
              -text=>'2 at the very most');

my $t3 = $c->create('text',310,80,
              -anchor=>'w',
              -font => 'big',
              -text=>'3 I\'m under the table');

my $t4 = $c->create('text',310,100,
              -anchor=>'w',
              -font => 'big',
              -text=>'4 I\'m under the host');


my @mover;
$mw->after(500,sub{ 
                 $c->createImage(30, 10,
                  -image  => 'martini',
                  -anchor => 'nw',);
                  
                 $mover[0] = $mw->repeat(5, sub{
                 $c->move($t1,-1,0);  
                 my ($bx,$by,$bx1,$by1)= $c->bbox($t1);
                 if($bx == 20){$mover[0]->cancel}
                 })});

$mw->after(4500,sub{ 
                  $c->createImage(55, 10,
                  -image  => 'martini',
                  -anchor => 'nw',);
                 
                 $mover[1] = $mw->repeat(5, sub{
                 $c->move($t2,-1,0);  
                 my ($bx,$by,$bx1,$by1)= $c->bbox($t2);
                 if($bx == 20){$mover[1]->cancel}
                  })});


$mw->after(8500,sub{ 
               $c->createImage(80, 10,
                -image  => 'martini',
                -anchor => 'nw');
                                  
                 $mover[2] = $mw->repeat(5, sub{
                 $c->move($t3,-1,0);  
                 my ($bx,$by,$bx1,$by1)= $c->bbox($t3);
                 if($bx == 20){$mover[2]->cancel}
                 })});


$mw->after(12500,sub{ 
             $c->createImage(105, 10,
                  -image  => 'martini',
                  -anchor => 'nw');
                
             $mover[3]=  $mw->repeat(5, sub{
                     $c->move($t4,-1,0);  
                     my ($bx,$by,$bx1,$by1)= $c->bbox($t4);
                     if($bx == 20){$mover[3]->cancel}
                          })});


MainLoop;

sub get_one{

my $o = qq(/* XPM */
static char * o_xpm[] = {
"24 24 2 1",
"       c None",
".      c #000000",
"                        ",
"                        ",
"  ....................  ",
"   ..................   ",
"    ................    ",
"     ..............     ",
"      ............      ",
"       ..........       ",
"        ........        ",
"         ......         ",
"          ....          ",
"           ..           ",
"           ..           ",
"           ..           ",
"           ..           ",
"           ..           ",
"           ..           ",
"           ..           ",
"     .............      ",
"                        ",
"                        ",
"                        ",
"                        ",
"                        "};
);

return $o;
}
[download]