#!/usr/bin/perl -w

use Tk;
use strict;

# Globals
my $b_button_1_down = 0;    # Is the left mouse button currently down?
my ($x0, $y0, $x1, $y1);    # Starting and ending (x,y) coordinates
my $rect_id = 0;            # Last rectangle drawn

# Main program / GUI setup
my $mw = MainWindow->new;
my $c = $mw->Scrolled('Canvas', -width => 100, -height => 100);
$c->configure(-background =>'blue', -scrollregion => [ 0, 0, 500, 500 ]);
$c->pack(-expand => 1, -fill => 'both');
bind_left_mouse($c);
MainLoop;

# Subroutines

sub bind_left_mouse {
    my ($c) = @_;

    # Create "callback"; subroutines which get called whenever the
    # corresponding event is triggered.  Note that Ev('x') and Ev('y')
    # will tell us, at the time they're used, what the current (x,y)
    # coordinate pair was.
    #
    my $cb1 = [ \&left_mouse_down, $c, Ev('x'), Ev('y')];
    my $cb2 = [ \&left_mouse_release, $c, Ev('x'), Ev('y')];
    my $cb3 = [ \&left_mouse_moving, $c, Ev('x'), Ev('y')];

    # Bind the callbacks
    $c->CanvasBind("<ButtonPress-1>",   $cb1);
    $c->CanvasBind("<ButtonRelease-1>", $cb2);
    $c->CanvasBind("<Motion>",          $cb3);
}

sub left_mouse_down {
    # This gets called whenever the left-mouse button is clicked
    my ($ev, $c, $x, $y) = @_;
    $b_button_1_down = 1;
    ($x0, $y0) = ($x, $y);
    print "(debug) button1 down, (x,y) => ($x,$y)\n";
}

sub left_mouse_moving {
    # This gets called whenever the mouse moves.  It's true for ALL
    # mouse motion, but we're really just interested in when the mouse
    # is moving -and- the left mouse button is held down; hence the name.
    #
    my ($ev, $c, $x, $y) = @_;
    return unless $b_button_1_down;
    print "(debug) button1 moving, (x,y) => ($x,$y)\n";
    $rect_id and $c->delete($rect_id); # Delete any old rectangle first
    $rect_id = $c->createRectangle($x0, $y0, $x, $y, -fill => 'yellow');
}

sub left_mouse_release {
    # This gets called whenever the left-mouse button is released
    my ($ev, $c, $x, $y) = @_;
    $b_button_1_down = 0;
    ($x1, $y1) = ($x, $y);
    print "(debug) button1 release, (x,y) => ($x,$y)\n";
    # Now do something with the triangle at (x0,y0,x1,y1)...
    $rect_id and $c->delete($rect_id); # Delete any old rectangle first
    $rect_id = $c->createRectangle($x0, $y0, $x, $y, -fill => 'red');
}