summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/DragDrop
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/DragDrop')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm61
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm61
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm110
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm34
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm200
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm107
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm8
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm50
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm145
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm159
10 files changed, 935 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm
new file mode 100644
index 00000000000..de28ce60e8b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm
@@ -0,0 +1,61 @@
+package Tk::DragDrop::Common;
+
+use strict;
+use Carp;
+
+no warnings 'once'; # cease warning about Tk::DragDrop::type
+
+use vars qw($VERSION);
+$VERSION = '4.005'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/Common.pm#4 $
+
+sub Type
+{
+ my ($base,$name,$class) = @_;
+ no strict 'refs';
+ my $hash = \%{"${base}::type"};
+ my $array = \@{"${base}::types"};
+ unless (exists $hash->{$name})
+ {
+ push(@$array,$name);
+ $class = (caller(0))[0] unless (@_ > 2);
+ $hash->{$name} = $class;
+ # confess "Strange class $class for $base/$name" unless ($class =~ /^Tk/);
+ # print "$base $name is ",$class,"\n";
+ }
+}
+
+sub import
+{
+ my $class = shift;
+ no strict 'refs';
+ my $types = \%{"${class}::type"};
+ while (@_)
+ {
+ my $type = shift;
+ unless (exists $types->{$type})
+ {
+ if ($type eq 'Local')
+ {
+ $class->Type($type,$class);
+ }
+ else
+ {
+ my ($kind) = $class =~ /([A-Z][a-z]+)$/;
+ my $file = Tk->findINC("DragDrop/${type}${kind}.pm");
+ if (defined $file)
+ {
+ # print "Loading $file\n";
+ require $file;
+ }
+ else
+ {
+ croak "Cannot find ${type}${kind}";
+ }
+ }
+ }
+ }
+}
+
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm
new file mode 100644
index 00000000000..0f5028ae64c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm
@@ -0,0 +1,61 @@
+package Tk::DragDrop::Local;
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/LocalDrop.pm#4 $
+
+use base qw(Tk::DragDrop::Rect);
+require Tk::DragDrop;
+
+my @toplevels;
+
+Tk::DragDrop->Type('Local');
+
+sub XY
+{
+ my ($site,$event) = @_;
+ return ($event->X - $site->X,$event->Y - $site->Y);
+}
+
+sub Apply
+{
+ my $site = shift;
+ my $name = shift;
+ my $cb = $site->{$name};
+ if ($cb)
+ {
+ my $event = shift;
+ $cb->Call(@_,$site->XY($event));
+ }
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$event) = @_;
+ $site->Apply(-dropcommand => $event, $seln);
+ $site->Apply(-entercommand => $event, 0);
+ $token->Done;
+}
+
+sub Enter
+{
+ my ($site,$token,$event) = @_;
+ $token->AcceptDrop;
+ $site->Apply(-entercommand => $event, 1);
+}
+
+sub Leave
+{
+ my ($site,$token,$event) = @_;
+ $token->RejectDrop;
+ $site->Apply(-entercommand => $event, 0);
+}
+
+sub Motion
+{
+ my ($site,$token,$event) = @_;
+ $site->Apply(-motioncommand => $event);
+}
+
+1;
+
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm
new file mode 100644
index 00000000000..0e62e35a5bf
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm
@@ -0,0 +1,110 @@
+package Tk::DragDrop::Rect;
+use strict;
+use Carp;
+
+# Proxy class which represents sites to the dropping side
+
+use vars qw($VERSION);
+$VERSION = '4.012'; # sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/;
+
+# Some default methods when called site side
+# XIDs and viewable-ness from widget
+
+# XID of ancestor
+sub ancestor { ${shift->widget->toplevel->WindowId} }
+
+# XID of site window
+sub win { ${shift->widget->WindowId} }
+
+# Is site window mapped
+sub viewable { shift->widget->viewable }
+
+sub Over
+{
+ my ($site,$X,$Y) = @_;
+
+ my $x = $site->X;
+ my $y = $site->Y;
+ my $w = $site->width;
+ my $h = $site->height;
+ my $val = ($X >= $x && $X < ($x + $w) && $Y >= $y && $Y < ($y + $h));
+
+ return 0 unless $val;
+
+ my $widget = $site->widget;
+
+ # Now XTranslateCoords from root window to site window's
+ # ancestor. Ancestors final descendant should be the site window.
+ # Like $win->containing but avoids a problem that dropper's "token"
+ # window may be the toplevel (child of root) that contains X,Y
+ # so if that is in another application ->containing does not
+ # give us a window.
+ my $id = $site->ancestor;
+ while (1)
+ {
+ my $cid = $widget->PointToWindow($X,$Y,$id);
+ last unless $cid;
+ $id = $cid;
+ }
+ return ($id == $site->win);
+}
+
+sub FindSite
+{
+ my ($class,$widget,$X,$Y) = @_;
+ foreach my $site ($class->SiteList($widget))
+ {
+ return $site if ($site->viewable && $site->Over($X,$Y));
+ }
+ return undef;
+}
+
+sub NewDrag
+{
+ my ($class,$widget) = @_;
+}
+
+sub Match
+{
+ my ($site,$other) = @_;
+ return 0 unless (defined $other);
+ return 1 if ($site == $other);
+ return 0 unless (ref($site) eq ref($other));
+ for ("$site")
+ {
+ if (/ARRAY/)
+ {
+ my $i;
+ return 0 unless (@$site == @$other);
+ for ($i = 0; $i < @$site; $i++)
+ {
+ return 0 unless ($site->[$i] == $other->[$i]);
+ }
+ return 1;
+ }
+ elsif (/SCALAR/)
+ {
+ return $site == $other;
+ }
+ elsif (/HASH/)
+ {
+ my $key;
+ foreach $key (keys %$site)
+ {
+ return 0 unless exists $other->{$key};
+ return 0 unless ($other->{$key} eq $site->{$key});
+ }
+ foreach $key (keys %$other)
+ {
+ return 0 unless exists $site->{$key};
+ return 0 unless ($other->{$key} eq $site->{$key});
+ }
+ return 1;
+ }
+ return 0;
+ }
+ return 0;
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm
new file mode 100644
index 00000000000..66325466e68
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm
@@ -0,0 +1,34 @@
+package Tk::DragDrop::SunConst;
+require Exporter;
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/SunConst.pm#4 $
+
+use base qw(Exporter);
+
+@EXPORT = qw(_enter _leave _motion
+ ENTERLEAVE MOTION DEFAULT_SITE
+ MOVE_FLAG ACK_FLAG TRANSIENT_FLAG FORWARDED_FLAG
+ );
+
+# Event types
+sub _enter () {7};
+sub _leave () {8};
+sub _motion () {6};
+
+# Site flags
+
+sub ENTERLEAVE () {1<<0}
+sub MOTION () {1<<1}
+sub DEFAULT_SITE () {1<<2}
+
+# Trigger flags
+sub MOVE_FLAG () {1<<0}
+sub ACK_FLAG () {1<<1}
+sub TRANSIENT_FLAG () {1<<2}
+sub FORWARDED_FLAG () {1<<3}
+
+1;
+
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm
new file mode 100644
index 00000000000..87489fed9a8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm
@@ -0,0 +1,200 @@
+package Tk::DragDrop::SunDrop;
+require Tk::DragDrop::Rect;
+
+use vars qw($VERSION);
+$VERSION = '4.006'; # sprintf '4.%03d', q$Revision: #5 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::DragDrop::Rect);
+use strict;
+use Tk::DragDrop::SunConst;
+
+Tk::DragDrop->Type('Sun');
+
+BEGIN
+ {
+ # Define the Rect API as members of the array
+ my @fields = qw(name win X Y width height flags ancestor widget);
+ my $i = 0;
+ no strict 'refs';
+ for ($i=0; $i < @fields; $i++)
+ {
+ my $j = $i;
+ *{"$fields[$i]"} = sub { shift->[$j] };
+ }
+ }
+
+
+sub Preview
+{
+ my ($site,$token,$e,$kind,$flags) = (@_);
+ $token->BackTrace('No flags') unless defined $flags;
+ my $sflags = $site->flags;
+ return if ($kind == _motion && !($sflags & MOTION));
+ return if ($kind != _motion && !($sflags & ENTERLEAVE));
+ my $data = pack('LLSSLL',$kind,$e->t,$e->X,$e->Y,$site->name,$flags);
+ $token->SendClientMessage('_SUN_DRAGDROP_PREVIEW',$site->win,32,$data);
+}
+
+sub Enter
+{
+ my ($site,$token,$e) = @_;
+ $token->AcceptDrop;
+ $site->Preview($token,$e,_enter,0);
+}
+
+sub Leave
+{
+ my ($site,$token,$e) = @_;
+ $token->RejectDrop;
+ $site->Preview($token,$e,_leave,0);
+}
+
+sub Motion
+{
+ my ($site,$token,$e) = @_;
+ $site->Preview($token,$e,_motion,0);
+}
+
+sub HandleDone
+{
+ my ($token,$seln,$offset,$max) = @_;
+ $token->Done;
+ return '';
+}
+
+sub HandleAck
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return '';
+}
+
+sub HandleItem
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return undef;
+}
+
+sub HandleCount
+{
+ my ($w,$seln,$offset,$max) = @_;
+ return 1;
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$e) = @_;
+ my $w = $token->parent;
+ $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_ACK',[\&HandleAck,$token,$seln]);
+ $w->SelectionHandle('-selection'=>$seln,'-type'=>'_SUN_DRAGDROP_DONE',[\&HandleDone,$token,$seln]);
+ my $atom = $w->InternAtom($seln);
+ my $flags = ACK_FLAG | TRANSIENT_FLAG;
+ my $data = pack('LLSSLL',$atom,$e->t,$e->X,$e->Y,$site->name,$flags);
+ $w->SendClientMessage('_SUN_DRAGDROP_TRIGGER',$site->win,32,$data);
+}
+
+sub FindSite
+{
+ my ($class,$token,$X,$Y) = @_;
+ $token->{'SunDD'} = [] unless exists $token->{'SunDD'};
+ my $site = $class->SUPER::FindSite($token,$X,$Y);
+ if (!defined $site)
+ {
+ my $id = $token->PointToWindow($X,$Y);
+ while ($id)
+ {
+ my @prop;
+ Tk::catch { @prop = $token->property('get','_SUN_DRAGDROP_INTEREST', $id) };
+ if (!$@ && shift(@prop) eq '_SUN_DRAGDROP_INTEREST' && shift(@prop) == 0)
+ {
+ # This is a "toplevel" which has some sites associated with it.
+ my ($bx,$by) = $token->WindowXY($id);
+ $token->{'SunDDSeen'} = {} unless exists $token->{'SunDDSeen'};
+ return $site if $token->{'SunDDSeen'}{$id};
+ $token->{'SunDDSeen'}{$id} = 1;
+ my $sites = $token->{'SunDD'};
+ my $count = shift(@prop);
+ while (@prop && $count-- > 0)
+ {
+ my ($xid,$sn,$flags,$kind,$n) = splice(@prop,0,5);
+ if ($kind != 0)
+ {
+ warn "Don't understand site type $kind";
+ last;
+ }
+ while (@prop >= 4 && $n-- > 0)
+ {
+ my ($x,$y,$w,$h) = splice(@prop,0,4);
+ push(@$sites,bless [$sn,$xid,$x+$bx,$y+$by,$w,$h,$flags,$id,$token],$class);
+ }
+ }
+ return $class->SUPER::FindSite($token,$X,$Y);
+ }
+ $id = $token->PointToWindow($X,$Y,$id)
+ }
+ }
+ return $site;
+}
+
+my $busy = 0;
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ delete $token->{'SunDD'} unless $busy;
+ delete $token->{'SunDDSeen'};
+}
+
+sub SiteList
+{
+ my ($class,$token) = @_;
+ return @{$token->{'SunDD'}};
+}
+
+1;
+__END__
+
+# this code is obsolete now that we look at properties ourselves
+# which means we don't need dropsite manager running
+# On Sun's running OpenLook the window manager or dropsite mananger
+# watches for and caches site info in a special selection
+# This code got sites from that
+#
+
+sub SiteList
+{
+ my ($class,$token) = @_;
+ unless (1 || $busy || exists $token->{'SunDD'})
+ {
+ Carp::confess('Already doing it!') if ($busy++);
+ my @data = ();
+ my @sites = ();
+ my $mw = $token->MainWindow;
+ $token->{'SunDD'} = \@sites;
+ Tk::catch {
+ @data = $mw->SelectionGet( '-selection'=>'_SUN_DRAGDROP_DSDM', '_SUN_DRAGDROP_SITE_RECTS');
+ };
+ if ($@)
+ {
+ $token->configure('-cursor'=>'hand2');
+ $token->grab(-global);
+ }
+ else
+ {
+ while (@data)
+ {
+ my $version = shift(@data);
+ if ($version != 0)
+ {
+ warn "Unexpected site version $version";
+ last;
+ }
+ push(@sites,bless [splice(@data,0,7)],$class);
+ }
+ }
+ $busy--;
+ }
+ return @{$token->{'SunDD'}};
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm
new file mode 100644
index 00000000000..ac6f7488a7a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm
@@ -0,0 +1,107 @@
+package Tk::DragDrop::SunSite;
+require Tk::DropSite;
+
+use vars qw($VERSION);
+$VERSION = '4.007'; # sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+
+use Tk::DragDrop::SunConst;
+use base qw(Tk::DropSite);
+use strict;
+
+Tk::DropSite->Type('Sun');
+
+sub SunDrop
+{
+ my ($w,$site) = @_;
+ my $e = $w->XEvent;
+ my ($seln,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$e->A);
+ $w->MakeAtom($seln);
+ if ($flags & &ACK_FLAG)
+ {
+ Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_ACK') };
+ }
+ my @targ = $w->SelectionGet(-selection => $seln,'TARGETS');
+ $site->Apply(-dropcommand => $x, $y, $seln, SunDrop => \@targ);
+ if ($flags & &TRANSIENT_FLAG)
+ {
+ Tk::catch { $w->SelectionGet('-selection'=>$seln,'_SUN_DRAGDROP_DONE') };
+ }
+ $w->configure('-relief' => $w->{'_DND_RELIEF_'}) if (defined $w->{'_DND_RELIEF_'});
+ $site->Apply(-entercommand => $x, $y, 0);
+}
+
+sub SunPreview
+{
+ my ($w,$site) = @_;
+ my $event = $w->XEvent;
+ my ($kind,$t,$x,$y,$id,$flags) = unpack('LLSSLL',$event->A);
+ $x -= $site->X;
+ $y -= $site->Y;
+ if ($kind == _enter)
+ {
+ $site->Callback(-entercommand => 1, $x, $y);
+ }
+ elsif ($kind == _leave)
+ {
+ $site->Callback(-entercommand => 0, $x, $y);
+ }
+ elsif ($kind == _motion)
+ {
+ $site->Callback(-motioncommand => $x, $y);
+ }
+}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ my $w = $site->widget;
+ $w->BindClientMessage('_SUN_DRAGDROP_TRIGGER',[\&SunDrop,$site]);
+ $w->BindClientMessage('_SUN_DRAGDROP_PREVIEW',[\&SunPreview,$site]);
+}
+
+sub NoteSites
+{
+ my ($class,$t,$sites) = @_;
+ my $count = @$sites;
+ my @data = (0,0);
+ my ($wrapper,$offset) = $t->wrapper;
+ if ($t->viewable)
+ {
+ my $s;
+ my $i = 0;
+ my @win;
+ my $bx = $t->rootx;
+ my $by = $t->rooty - $offset;
+ $t->MakeWindowExist;
+ foreach $s (@$sites)
+ {
+ my $w = $s->widget;
+ if ($w->viewable)
+ {
+ $w->MakeWindowExist;
+ $data[1]++;
+ push(@data,${$w->WindowId}); # XID
+ push(@data,$i++); # Our 'tag'
+ push(@data,ENTERLEAVE|MOTION); # Flags
+ push(@data,0); # Kind is 'rect'
+ push(@data,1); # Number of rects
+ push(@data,$s->X-$bx,$s->Y-$by,$s->width,$s->height); # The rect
+ }
+ }
+ }
+ if ($data[1])
+ {
+ $t->property('set',
+ '_SUN_DRAGDROP_INTEREST', # name
+ '_SUN_DRAGDROP_INTEREST', # type
+ 32, # format
+ \@data,$wrapper); # the data
+ }
+ else
+ {
+ $t->property('delete','_SUN_DRAGDROP_INTEREST',$wrapper);
+ }
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm
new file mode 100644
index 00000000000..08a4656ecce
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm
@@ -0,0 +1,8 @@
+package Tk::DragDrop::Win32Drop;
+# Dummy placeholder for symetry
+
+use vars qw($VERSION);
+$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/Win32Site/Win32Drop.pm#4 $
+
+use Tk ();
+1;
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm
new file mode 100644
index 00000000000..ca9029dc8b6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm
@@ -0,0 +1,50 @@
+package Tk::DragDrop::Win32Site;
+
+use vars qw($VERSION);
+$VERSION = '4.009'; # sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use Tk qw($XS_VERSION);
+require DynaLoader;
+require Tk::DropSite;
+
+use base qw(Tk::DropSite DynaLoader);
+
+bootstrap Tk::DragDrop::Win32Site;
+
+use strict;
+
+Tk::DropSite->Type('Win32');
+
+sub WM_DROPFILES () {563}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ my $w = $site->widget;
+ $w->BindClientMessage(WM_DROPFILES,[\&Win32Drop,$site]);
+ DragAcceptFiles($w,1);
+}
+
+sub Win32Drop
+{
+ # print join(',',@_),"\n";
+ my ($w,$site,$msg,$wParam,$lParam) = @_;
+ my ($x,$y,@files) = DropInfo($wParam);
+ my $cb = $site->{'-dropcommand'};
+ $site->Apply(-entercommand => $x, $y, 1);
+ if ($cb)
+ {
+ foreach my $file (@files)
+ {
+ # print "$file @ $x,$y\n";
+ $w->clipboardClear;
+ $w->clipboardAppend('--',$file);
+ $cb->Call('CLIPBOARD',Win32Drop => ['STRING'],$x,$y);
+ }
+ }
+ $site->Apply(-entercommand => $x, $y, 0);
+ return 0;
+}
+
+1;
+__END__
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm
new file mode 100644
index 00000000000..879874cea9d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm
@@ -0,0 +1,145 @@
+package Tk::DragDrop::XDNDDrop;
+use strict;
+use vars qw($VERSION);
+$VERSION = '4.007'; # sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/;
+use base qw(Tk::DragDrop::Rect);
+
+sub XDND_PROTOCOL_VERSION () { 4 }
+
+Tk::DragDrop->Type('XDND');
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ $token->{$class} = {};
+}
+
+sub new
+{
+ my ($class,$token,$id,@prop) = @_;
+ my $ver = $token->InternAtom(shift(@prop));
+ # warn "XDND version $ver ".join(' ',@prop)."\n";
+ $ver = XDND_PROTOCOL_VERSION if $ver > XDND_PROTOCOL_VERSION;
+ my $site = bless { id => $id, token => $token, ver => $ver, state => 0, accept => \@prop}, $class;
+ my $w = $token->parent;
+ $w->BindClientMessage('XdndStatus',[$site => 'XdndStatus']);
+ $w->BindClientMessage('XdndFinished',[$site => 'XdndFinished']);
+ return $site;
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$e) = @_;
+ my $w = $token->parent;
+ my $data = pack('LLLLL',oct($w->id),0,$e->t,0,0);
+ $w->SendClientMessage('XdndDrop',$site->{id},32,$data);
+}
+
+sub FindSite
+{
+ my ($class,$token,$X,$Y) = @_;
+ my $id = $token->PointToWindow($X,$Y);
+ while ($id)
+ {
+ my @prop;
+ Tk::catch { @prop = $token->property('get','XdndAware', $id) };
+ if (!$@ && shift(@prop) eq 'ATOM')
+ {
+ my $hash = $token->{$class};
+ my $site = $hash->{$id};
+ if (!defined $site)
+ {
+ $site = $class->new($token,$id,@prop);
+ $hash->{$id} = $site;
+ }
+ return $site;
+ }
+ $id = $token->PointToWindow($X,$Y,$id)
+ }
+ return undef;
+}
+
+sub Enter
+{
+ my ($site,$token,$e) = @_;
+ my $w = $token->parent;
+ $token->InstallHandlers('XdndSelection');
+ my $seln = $token->cget('-selection');
+ my @targets = grep(!/^(TARGETS|MULTIPLE|TIMESTAMP)$/,reverse($token->SelectionGet('-selection'=> 'XdndSelection','TARGETS')));
+ # print join(' ',@targets),"\n";
+ my $flags = ($site->{ver} << 24);
+ my @atarg = map($token->InternAtom($_),@targets);
+ my $ntarg = @atarg;
+ if ($ntarg > 3)
+ {
+ $flags |= 1;
+ $w->property('set','XdndTypeList','ATOM',32,\@atarg);
+ splice(@atarg,3);
+ }
+ else
+ {
+ splice(@atarg,$ntarg,(0 x 3 - $ntarg));
+ }
+ unshift(@atarg,oct($w->id),$flags);
+ # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n";
+ my $data = pack('LLLLL',@atarg);
+ $w->SendClientMessage('XdndEnter',$site->{id},32,$data);
+}
+
+sub Leave
+{
+ my ($site,$token,$e) = @_;
+ my $w = $token->parent;
+ my $data = pack('LLLLL',oct($w->id), 0, 0, 0, 0);
+ $w->SendClientMessage('XdndLeave',$site->{id},32,$data);
+}
+
+sub Motion
+{
+ my ($site,$token,$e) = @_;
+ my $X = $e->X;
+ my $Y = $e->Y;
+ my $w = $token->parent;
+ my $action = $token->InternAtom($site->{'action'} || 'XdndActionCopy');
+ my @atarg = (oct($w->id),0,($X << 16) | $Y, $e->t, $action);
+ # print join(' ',map(sprintf("%08X",$_),@atarg)),"\n";
+ my $data = pack('LLLLL',@atarg);
+ $w->SendClientMessage('XdndPosition',$site->{id},32,$data);
+}
+
+sub XdndFinished
+{
+ my ($site) = @_;
+ my $token = $site->{token};
+ # printf "XdndFinished $site\n",
+ $token->Done;
+}
+
+sub XdndStatus
+{
+ my ($site) = @_;
+ my $token = $site->{token};
+ my $w = $token->parent;
+ my $event = $w->XEvent;
+ my ($tid,$flags,$xy,$wh,$action) = unpack('LLLLL',$event->A);
+ $action = $w->GetAtomName($action) if $action;
+ $site->{flags} = $flags;
+ $site->{'X'} = $xy >> 16;
+ $site->{'Y'} = $xy & 0xFFFF;
+ $site->{'width'} = $wh >> 16;
+ $site->{'height'} = $wh & 0xFFFF;
+ #printf "XdndStatus $site targ=%x flags=%08X x=%d y=%d w=%d h=%d a=%s\n",
+ # $tid,$flags,$xy >> 16, $xy & 0xFFFF, $wh >> 16, $wh & 0xFFFF,$action;
+ if ($flags & 1)
+ {
+ $token->AcceptDrop;
+ }
+ else
+ {
+ $token->RejectDrop;
+ }
+}
+
+
+1;
+__END__
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..9661b009f9d
--- /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 = '4.007'; # 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__