diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/DragDrop')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/Common.pm | 59 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/LocalDrop.pm | 61 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/Rect.pm | 110 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/SunConst.pm | 34 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/SunDrop.pm | 200 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/SunSite.pm | 107 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Drop.pm | 8 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm | 50 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDDrop.pm | 145 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DragDrop/XDNDSite.pm | 159 |
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__ |