1 files changed, 159 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
new file mode 100644
index 00000000000..4ac75d63c40
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
@@ -0,0 +1,159 @@
+package Tk::DragDrop::XDNDSite;
+use strict;
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+use base qw(Tk::DropSite);
+
+sub XDND_PROTOCOL_VERSION () { 4 }
+
+Tk::DropSite->Type('XDND');
+
+sub InitSite
+{my ($class,$site) = @_;
+ my $w = $site->widget;
+}
+
+sub XdndEnter
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,@types) = unpack('LLLLL',$event->A);
+ my $ver = ($flags >> 24) & 0xFF;
+ if ($flags & 1)
+  {
+   my @prop;
+   Tk::catch { @prop = $t->property('get','XdndTypeList',$src) };
+   @types = @prop if (!$@ && shift(@prop) eq 'ATOM');
+  }
+ else
+  {
+   $t->MakeAtom(@types);
+  }
+ # print "XdndEnter $src $ver @types\n";
+ $t->{"XDND$src"} = { ver => $ver, types => \@types };
+}
+
+sub XdndLeave
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,@types) = unpack('LLLLL',$event->A);
+ # print "XdndLeave $src\n";
+ my $info = $t->{"XDND$src"};
+ if ($info)
+  {
+   my $over = $info->{site};
+   if ($over)
+    {
+     my $X = $info->{X};
+     my $Y = $info->{Y};
+     $over->Apply(-entercommand => $X, $Y, 0)
+    }
+  }
+ delete $t->{"XDND$src"};
+}
+
+sub XdndPosition
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,$xy,$time,$action) = unpack('LLLLL',$event->A);
+ $t->MakeAtom($action);
+ my $X = $xy >> 16;
+ my $Y = $xy & 0xFFFF;
+ my $info = $t->{"XDND$src"};
+ $info->{X}      = $X;
+ $info->{Y}      = $Y;
+ $info->{action} = $action;
+ $info->{t}      = $time;
+ my ($id)  = $t->wrapper;
+ my $sxy   = 0;
+ my $swh   = 0;
+ my $sflags = 0;
+ my $saction = 0;
+ my $over = $info->{site};
+ foreach my $site (@$sites)
+  {
+   if ($site->Over($X,$Y))
+    {
+     $sxy = ($site->X << 16)     | $site->Y;
+     $swh = ($site->width << 16) | $site->height;
+     $saction = $action;
+     $sflags |= 1;
+     if ($over)
+      {
+       if ($over == $site)
+        {
+         $site->Apply(-motioncommand => $X, $Y);
+        }
+       else
+        {
+         $over->Apply(-entercommand => $X, $Y, 0);
+         $site->Apply(-entercommand => $X, $Y, 1);
+        }
+      }
+     else
+      {
+       $site->Apply(-entercommand => $X, $Y, 1);
+      }
+     $info->{site} = $site;
+     last;
+    }
+  }
+ unless ($sflags & 1)
+  {
+   if ($over)
+    {
+     $over->Apply(-entercommand => $X, $Y, 0)
+    }
+   delete $info->{site};
+  }
+ my $data = pack('LLLLL',$id,$sflags,$sxy,$swh,$action);
+ $t->SendClientMessage('XdndStatus',$src,32,$data);
+}
+
+sub XdndDrop
+{
+ my ($t,$sites) = @_;
+ my $event = $t->XEvent;
+ my ($src,$flags,$time,$res1,$res2) = unpack('LLLLL',$event->A);
+ my $info   = $t->{"XDND$src"};
+ my $sflags = 0;
+ my $action = 0;
+ if ($info)
+  {
+   $info->{t} = $time;
+   my $site = $info->{'site'};
+   if ($site)
+    {
+     my $X = $info->{'X'};
+     my $Y = $info->{'Y'};
+     $action = $info->{action};
+     $site->Apply(-dropcommand => $X, $Y, 'XdndSelection',$action,$info->{types});
+     $site->Apply(-entercommand => $X, $Y, 0);
+    }
+  }
+ my ($id) = $t->wrapper;
+ my $data  = pack('LLLLL',$id,$sflags,$action,0,0);
+ $t->SendClientMessage('XdndFinished',$src,32,$data);
+}
+
+sub NoteSites
+{my ($class,$t,$sites) = @_;
+ my ($wrapper) = $t->wrapper;
+ if (@$sites)
+  {
+   $t->BindClientMessage('XdndLeave',[\&XdndLeave,$sites]);
+   $t->BindClientMessage('XdndEnter',[\&XdndEnter,$sites]);
+   $t->BindClientMessage('XdndPosition',[\&XdndPosition,$sites]);
+   $t->BindClientMessage('XdndDrop',[\&XdndDrop,$sites]);
+   $t->property('set','XdndAware','ATOM',32,[XDND_PROTOCOL_VERSION],$wrapper);
+  }
+ else
+  {
+   $t->property('delete','XdndAware',$wrapper);
+  }
+}
+
+1;
+__END__