#!/usr/bin/perl
use warnings;
use strict;
use Tk;
require Tk::DialogBox;
use Tk::PNG;

#by zentara on Sept 30, 2005

# Usage:
# Press and drag Mouse Button 1 to draw lines
# Right click to add text at click point
# Middle Click(or both mouse buttons ) to delete item under mouse
# Save will write the canvas to postscript

my $file = shift or die "Need image $!\n";

my @s;            #line drawing buffer 
my $count_l = 0;  #count for lines tags
my $count_t = 0;  #count for text tags

my $mw = tkinit;

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

my $topframe = $mw->Frame(-bg=>'black')->pack(-fill =>'x');

$topframe->Button(-text=>'Exit',-command=>sub{ exit })
                     ->pack(-side => 'right', -padx => 5);

my $canvas = $mw->Canvas( -width => 640, 
                      -height => 480,
              -bg => 'white',
         )->pack(-fill=>'both', -expand => 1);

$canvas->Tk::bind('<1>', [ \&Start, Ev('x'), Ev('y') ] );
$canvas->Tk::bind("<B1-Motion>", [ \&Move, Ev('x'), Ev('y') ]);
$canvas->Tk::bind('<ButtonRelease>', sub { @s =() });

#text insert with right button click
$canvas->Tk::bind('<3>', [ \&Text_insert, Ev('x'), Ev('y') ] );

#undo with a middle mouse click
$canvas->Tk::bind('<2>', sub{
           $canvas->delete( ($canvas->gettags("current"))[0] );
          });


my $image = $mw->Photo(-file => $file);

my $png = $canvas->createImage(0,0,
                 -anchor => 'nw',
                 -image=> $image,
           );



$topframe->Button(
     -text    => "Save",
    -command => [sub {
           $canvas->update;
           my @capture=();
           my ($x0,$y0,$x1,$y1)=$canvas->bbox('all');
           @capture=('-x'=>$x0,'-y'=>$y0,-height=>$y1-$y0,-width=>$x1-
+$x0);
           $canvas -> postscript(-colormode=>'color',
                               -file=>$0.'.ps',
                   -rotate=>0,
                   -width=>800,
                   -height=>500,    
                   @capture);
                      } 
         ])->pack(-side=>'left', -padx =>5);

$topframe->Button(
     -text    => "Restart",
    -command => sub{   
          $canvas->delete('line','text');
       })->pack(-side=>'left', -padx =>5);

MainLoop;
#############################################################
sub Start {
     my ($canv, $x, $y) = @_;
     $count_l++;
     @s =();
     my @coords = ($canv->canvasx($x) , $canv->canvasx($y) );
     push @s, @coords;
}
#############################################################
sub Move {
   my ($canv, $x, $y) = @_;
   my @coords = ($canv->canvasx($x) , $canv->canvasx($y) );
   push @s, @coords;

   $canvas->createLine( @s,
               -width => 5,
               -smooth => 1,
           -tags => [ 'l'.$count_l , 'line'],
               -fill => 'black');

  #shift off previous points to avoid overlapping
  shift @s; shift @s;
}
##############################################################
sub Text_insert {
     my ($canv, $x, $y) = @_;
     $count_t++;
     my @coords = ($canv->canvasx($x) , $canv->canvasx($y) );

     my $dialog = $mw->DialogBox(
       -buttons => ['Ok'],
       -title => 'Text Insert',
                   -bg    => 'lightsteelblue',
                  ); 
  
     my $dentry = $dialog->add('Entry', 
                -bg=>'yellow',
        -font => 'big',
        )->pack();
    
     $dialog->configure(-focus => $dentry);
     my $button = $dialog->Show();
     
     if ( $button eq "Ok" ) {
        my $text = $dialog->Subwidget('entry')->get();
      
        $canvas->createText( @coords,
               -text => $text,
               -anchor => 'w',
           -justify => 'left',
           -font => 'big',
           -tags => [ 't'.$count_t, 'text' ],
           -fill => 'red');
     }
}
################################################################

__END__
[download]