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.pm59
-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, 0 insertions, 933 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm b/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm
deleted file mode 100644
index 2f7a33d4fb4..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm
+++ /dev/null
@@ -1,59 +0,0 @@
-package Tk::DragDrop::Common;
-
-use strict;
-use Carp;
-
-use vars qw($VERSION);
-$VERSION = '4.004'; # $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
deleted file mode 100644
index 0f5028ae64c..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm
+++ /dev/null
@@ -1,61 +0,0 @@
-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
deleted file mode 100644
index 04cfa8772f2..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm
+++ /dev/null
@@ -1,110 +0,0 @@
-package Tk::DragDrop::Rect;
-use strict;
-use Carp;
-
-# Proxy class which represents sites to the dropping side
-
-use vars qw($VERSION);
-$VERSION = 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
deleted file mode 100644
index 66325466e68..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm
+++ /dev/null
@@ -1,34 +0,0 @@
-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
deleted file mode 100644
index 422a08196ea..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm
+++ /dev/null
@@ -1,200 +0,0 @@
-package Tk::DragDrop::SunDrop;
-require Tk::DragDrop::Rect;
-
-use vars qw($VERSION);
-$VERSION = 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
deleted file mode 100644
index ab3f4f9793b..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm
+++ /dev/null
@@ -1,107 +0,0 @@
-package Tk::DragDrop::SunSite;
-require Tk::DropSite;
-
-use vars qw($VERSION);
-$VERSION = 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
deleted file mode 100644
index 08a4656ecce..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm
+++ /dev/null
@@ -1,8 +0,0 @@
-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
deleted file mode 100644
index f45d06bc92b..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm
+++ /dev/null
@@ -1,50 +0,0 @@
-package Tk::DragDrop::Win32Site;
-
-use vars qw($VERSION);
-$VERSION = 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
deleted file mode 100644
index 7376c8d69c5..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm
+++ /dev/null
@@ -1,145 +0,0 @@
-package Tk::DragDrop::XDNDDrop;
-use strict;
-use vars qw($VERSION);
-$VERSION = 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
deleted file mode 100644
index 4ac75d63c40..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm
+++ /dev/null
@@ -1,159 +0,0 @@
-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__