use strict;
use FindBin;
use lib "$FindBin::Bin";
use Tk;
use Tk::HList;
use Tk::JPEG;
use Tk::DragDrop;
use Tk::DropSite;
use Tk::Photo;
use Tk::ItemStyle;

############
# globals
my ($mw);
my $hlRes;
my $hlDocRout;
my $hlDocType;
my $dnd_token;
my @ImgArr;
my $TextOver;

DoMain();

=pod
layout
=cut

sub DoMain {

        # main window
        $mw = MainWindow->new;
        $mw->title("Work Flow Routing");
        #$mw->configure(-width => 1200, height => 600);

        # toolbar TODO add frame and left justify
        $mw->Button(-text => "info", -command => \&Info)->pack(-side => "top",
-anchor => "w");

        # Doc type list
        $hlDocType = $mw->Scrolled("HList",
                                                -itemtype   => 'text',
                                                -selectmode => 'browse',
                                                -height => 50,
                                                -width => 20,
                                                -scrollbars => 'osoe',
                                                )->pack(-side => 'left', -expand => 1, -fill => 'both');

        # load document types
        my @DocTypes = qw(PurchaseOrder CustomerOrder);
        for my $t (@DocTypes) {
                my $e=$hlDocType->addchild("");
                $hlDocType->itemCreate($e, 0,
                        -itemtype => "text",
                        -text => $t,
                    );
        }

        # picture routing and resource lists
        $hlDocRout = $mw->Scrolled("HList",
                                                -itemtype   => 'image',
                                                -selectmode => 'browse',
                                                -browsecmd  => \&OnClick,
                                                -height => 50,
                                                -width => 20,
                                                -scrollbars => 'osoe',
                                                )->pack(-side => 'left', -expand => 1, -fill => 'both');

        $hlRes = $mw->Scrolled("HList",
                                                -itemtype   => 'image',
                                                -selectmode => 'browse',
                                                -browsecmd  => \&OnClick,
                                                -height => 50,
                                                -width => 20,
                                                -scrollbars => 'osoe',
                                                )->pack(-side => 'right', -expand => 1, -fill => 'both');
        $TextOver=$hlRes->ItemStyle("imagetext", -textanchor => "n");

        # drag and drop stuff
        $dnd_token = $hlRes->DragDrop
          (-event     => '<B1-Motion>',
           -sitetypes => ['Local'],
           -startcommand => sub { StartDrag($dnd_token) },
          );
        $hlDocRout->DropSite
          (-droptypes     => ['Local'],
           -dropcommand   => [ \&Drop, $hlDocRout, $dnd_token ],
          );
        $hlDocRout->bind("<Delete>", \&Delete);

        # load data for resource list
        my $i=0;
        for my $fn (glob ("*.jpg")) {
                my $SrcImg=$mw->Photo(-file => $fn);
                my $DstImg=$mw->Photo();
                my $w=$SrcImg->width();
                my $h=$SrcImg->height();
                my $f=int($h/75);
                $DstImg->copy($SrcImg, -subsample => ($f, $f));  # rescales image to one size
                $i++;
                push @ImgArr, $DstImg;
                print "$i:$fn:$w $h\n";
                $SrcImg->delete();
                my $e=$hlRes->addchild("", -data => $fn,);
                $hlRes->itemCreate($e, 0,
                        -itemtype => "imagetext",
                        -image => $DstImg,
                        -text => $fn,
                        -style => $TextOver,
                    );
        }

        MainLoop;

}

sub StartDrag {

my($token) = @_;
     my $w = $token->parent; # $w is the source listbox
     my $e = $w->XEvent;
     my $idx = $w->nearest($e->y); # get the listbox entry under cursor

        #print "y:", $e->y, "\n";
     if (defined $idx) {
                # Configure the dnd token to show the listbox entry
                my $opt=$token->configure();
                $token->configure(-image => $ImgArr[$idx]);
                $token->configure(-text => $w->info("data", $
idx));
                # Show the token
                my($X, $Y) = ($e->X, $e->Y);
                $token->MoveToplevelWindow

($X, $Y);
                $token->raise;
                $token->deiconify;
                $token->FindSite($X, $Y, $e);
                #print "$token\n";
     }

}

# Accept a drop and insert a new item in the destination listbox.
sub Drop {
     my($hlist, $dndtoken) = @_;
        # token info
        my $img = $dndtoken->cget(-image);
        my $text = $dndtoken->cget(-text);
        #print "image:$img\n";
        #my @list=$hlist->info("children");

        # get position to insert or append at
     my $end = ($hlist->info("children"))[-1];
     my @pos = (-after => $end) if defined $end;
     my $y = $hlist->pointery - $hlist->rooty;
     my $nearest = $hlist->nearest($y);
     if (defined $nearest) {
                my(@bbox) = $hlist->infoBbox($nearest);
                if ($y > ($bbox[3]-$bbox[1])/2+$bbox[1]) {
                        @pos = (-after => $nearest);
                } else {
                        @pos = (-before => $nearest);
                }
     }

        # add the line
        my $fn="";
        my $e=$hlist->addchild("", @pos, -data => $fn);
        $hlist->itemCreate($e, 0,
                -itemtype => "imagetext",
                -image => $img,
                -text => $text,
                -style => $TextOver,
                );
        $hlist->see($e);

}

sub Delete {
        my ($w) = @_;
        my @sl=$hlDocRout->info("selection");
        print "got delete: $w, selected: @sl\n";
        $hlDocRout->delete("entry", @sl) if ($#sl >= 0);

}

sub OnClick {
        my $entry=shift;
        my $data=$hlRes->info("data", $entry);
        my $val=$hlRes->entrycget($entry, "-image");
        my $d=$hlRes->entrycget($entry, "-data");
        my @l=$hlRes->info("children");
        my $i=$entry-1;
        my $h=$ImgArr[$i]->height();
        my $t=$ImgArr[$i]->type();
        my $f=$ImgArr[$i]->cget("-file");
        #my $d=$ImgArr[$i]->cget("-data");
=pod
        print "$entry:$data\n";
        print "image:$val\n";
        print "height:$h\n";
        print "type:$t\n";
        #print "size:$#l\n";
        #print "filename:$f\n";
        print "data:$d\n";
        my @opt=$hlRes->entryconfigure($entry);
        $#opt;
=cut
=pod
        for my $a (@opt) {
                print "$a\n";
                print "@$a\n";
                #for $b (@$a) {
                #       my $val=$hlRes->entryconfigure($entry, $b);
                #       print "$b:$val\n";
                #}
        }
=cut

}

sub Info {
        my @il=$mw->imageNames;
        for my $a (@il) {
                my $h=$a->height;
                my $type=$a->type;
                print "$a:$h:$type\n";
        } 

>> C:/Perl/site/lib/Tk/Widget.pm:218:    $widget = $w->Subwidget($widget) if (d
fined $widget && !ref $widget);
>> C:/Perl/site/lib/Tk/Widget.pm:219:    last unless (defined $widget);
>> C:/Perl/site/lib/Tk/Widget.pm:220:    last if $widget == $w;
>> C:/Perl/site/lib/Tk/Widget.pm:221:    $w = $widget;
>> C:/Perl/site/lib/Tk/Widget.pm:223:  return $w;
>> C:/Perl/site/lib/Tk/Derived.pm:458:  if ($widget == $cw)
>> C:/Perl/site/lib/Tk/Derived.pm:462:  my @result;
>> C:/Perl/site/lib/Tk/Derived.pm:463:  if (wantarray)
>> C:/Perl/site/lib/Tk/Derived.pm:469:    $result[0] = $widget->$method(@args);
>> C:/Perl/site/lib/Tk.pm:247:    *{$package."::$meth"} = sub { shift->WidgetMe
hod($name,@_) };

This application has requested the Runtime to terminate it in an unusual way.
Please contact the application's support team for more information.