use Tk;
use Tk::HList;
use Tk::Pane;
use Tk::DragDrop;
use Tk::DropSite;

use strict;
use warnings;

my $mw = MainWindow->new;



my $eyeball = '
    /* XPM */
    static char * eyeball[] = {
    "32 12 4 1",
    "   c None",
    "@  c #000000",
    "x  c #ffffff",
    "o  c #3f3fff",
    "                @@@@@@@@@       ",
    "              @@@@@@@@@@@@@     ",
    "             @@xxxxxxxxxxx@@    ",
    "            @@xxxx@@@@@@xxx@@   ",
    "            @@xxx@@oooo@@xxx@@  ",
    "            @@xx@@oooooo@@xx@@  ",
    "            @@xx@@oooooo@@xx@@  ",
    "            @@xxx@@oooo@@xxx@@  ",
    "             @@xxx@@@@@@xxx@@   ",
    "              @@xxxxxxxxxx@@    ",
    "               @@@@@@@@@@@@     ",
    "                 @@@@@@@@       ",
';


my $psym = make_image($mw, $eyeball);

my $pane = $mw->Scrolled('Pane',
                         -width => 800,
                         -height => 400,
                         -sticky => 'nsew',
                         -scrollbars => 'os',
           )->pack(-fill => 'both',
             -expand => 1);

addCol(1);
addCol(2);
addCol(3);

sub addCol {

	my $id = shift;

	my $width = 200;

	my $frame = $pane->Frame(
							-relief => "ridge",
                            -bd     => 1,
                            -width  => $width,
                        )->pack(-side => 'left',
                         -fill => 'both',
                         -expand => 1,
         );

	# DnD SUPPORT!

	#my $frame1 = $frame->Frame()->pack();
	#my $frame2 = $frame->Frame()->pack();

	my $adjuster = $pane->Adjuster();
	$adjuster->packAfter($frame, -side => 'left');

	my $label = $frame->Label(-width => 30, -text  => "Test" . $id, -bg => "lightgray",
						)->pack(-fill => "both");
#	my $label = $frame->Button(-width => 30, -text  => "Test" . $id,
#								-command => sub { print "!!!!!!!!!!!!"; },
#						)->pack(-fill => "both");


	my $press = sub {
	    my ($c_src, $label_obj, $drag_source) = @_;
    	#$drag_id = $c_src_id;
	    #my $type = $c_src->type($drag_id);
    	$drag_source->configure(-text => $label_obj->cget(-text));
	};

	my $drag_source = $label->DragDrop(
		    -event     => '<B1-Motion>',
		    -sitetypes => [qw/Local/],
			#-image     => $psym,
	);

	$label->bind('<ButtonPress-1>' => [$press, $label, $drag_source]);

	#_dragOrSort($button);

	#my $can = $frame->Canvas(-bg => 'skyblue')->pack();


	my $hlist = $frame->Scrolled("HList",
			-scrollbars => 'osoe',
			-selectmode => 'extended'
			)->pack(-fill => "both", -expand => 1);


	my $drop = $hlist->DropSite(
		-droptypes    => [qw(Local)],
		-dropcommand  => [\&perform_drop,    $label],
		-entercommand => [\&hover_over_drop, $label],
#		-dropcommand  => [\&perform_drop,    $can, $label],
#		-entercommand => [\&hover_over_drop, $can, $label],
	);
	my $drop2 = $label->DropSite(
		-droptypes    => [qw(Local)],
		-dropcommand  => [\&perform_drop,    $label],
		-entercommand => [\&hover_over_drop, $label],
#		-dropcommand  => [\&perform_drop,    $can, $label],
#		-entercommand => [\&hover_over_drop, $can, $label],
	);

}

MainLoop;



#
#  Inputs:  $1 ... the top-level widget
#           $2 ... the image data
#
# Outputs:  $1 ... a pointer to the image for use with other widgets
#
sub make_image {
    my ($w, $data) = @_;
    my $img = $w->Pixmap(-data, $data);
    return $img;
}


#
#  Inputs:  $1 ... the widget being hovered over
#           $2 ... nonzero if entering, zero if leaving
#           $3 ... label over
#
sub hover_over_drop {
	my ($drop_site, $b_entry, $x_pos, $label_obj) = @_;
	$drop_site->configure(-bg => $b_entry == 1 ? 'gray' : 'lightgray');

	if ($b_entry) {
 	    #print $label_obj . "\n";
		#$label_obj->cget(-text);
	}
}


#
#  Inputs:  $1 ... the widget being dropped into
#           $2 ... the widget being dropped
#
sub perform_drop {
    my ($drop_site, $x_pos, $drop_obj) = @_;

    #use Data::Dumper;
	#print Dumper(@_);

	#$pane->idletasks;
	#$pane->update;

	#$x_pos->configure(-bg => 'yellow');
	#$drop_site->configure(-bg => 'yellow');
	#$drop_site->configure(-bg => 'skyblue');
	#print "Debug:  Now do something with drop_obj $drop_obj " . $drop_obj->cget(-text) . "\n";
}

sub _dragOrSort {
    my ($w, $c) = @_;

    #my $w = $pane;

    #unless ($w->cget('-moveable')) {
	#if ($c->cget('-sortable')) {
	#    $w->sort (undef, $c);
	#}
	#return;
    #}

    my $h = shift;  # The heading button of the column.

    my $start_mouse_x = $h->pointerx;
    my $y_pos = $h->rooty;  # This is constant through the whole operation.
    my $width = $h->width;
    my $left_limit = $w->rootx - 1;

    # Find the rightmost, visible column
    my $right_end = 0;
    foreach (@{$w->{'_columns'}}) {
	if ($_->rootx + $_->width > $right_end) {
	    $right_end = $_->rootx + $_->width;
	}
    }
    my $right_limit = $right_end + 1;

    # Create a "copy" of the heading button, put it in a toplevel that matches
    # the size of the button, put the toplevel on top of the button.
    my $tl=$w->Toplevel;
    $tl->overrideredirect(1);
    $tl->geometry(sprintf("%dx%d+%d+%d",
			  $h->width, $h->height, $h->rootx, $y_pos));

    my $b=$tl->Button
	(map{defined($_->[4]) ? ($_->[0]=>$_->[4]) : ()} $h->configure)
	    ->pack(-expand=>1,-fill=>'both');

    # Move the toplevel with the mouse (as long as Button-1 is down).
    $h->bind("<Motion>", sub {
	my $new_x = $h->rootx - ($start_mouse_x - $h->pointerx);
	unless ($new_x + $width/2 < $left_limit ||
		$new_x + $width/2 > $right_limit)
	{
	    $tl->geometry(sprintf("+%d+%d",$new_x,$y_pos));
	}
    });

    $h->bind("<ButtonRelease-1>", sub {
	my $rootx = $tl->rootx;
	my $x = $rootx + ($tl->width/2);
	$tl->destroy;    # Don't need this anymore...
	$h->bind("<Motion>",'');  # Cancel binding

	if ($h->rootx == $rootx) {
	    # Button NOT moved, sort the column....
	    if ($c->cget('-sortable')) {
		$w->sort(undef, $c);
	    }
	    return;
	}

	# Button moved.....
	# Decide where to put the column. If the center of the dragged
	# button is on the left half of another heading, insert it -before
	# the column, otherwise insert it -after the column.
	foreach (@{$w->{'_columns'}}) {
	    if ($_->ismapped) {
		my $left = $_->rootx;
		my $right = $left + $_->width;
		if ($left <= $x && $x <= $right) {
		    if ($x - $left < $right - $x) {
			$w->columnShow($c,-before=>$_);
		    } else {
			$w->columnShow($c,'-after'=>$_);
		    }
		    $w->update;
		    $w->Callback(-configurecommand => $w);
		}
	    }
	}
    });
}