diff options
Diffstat (limited to 'Master/tlpkg/tlperl.old/lib/Tk/DragDrop')
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Common.pm | 59 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/LocalDrop.pm | 61 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Rect.pm | 110 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunConst.pm | 34 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunDrop.pm | 200 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunSite.pm | 107 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Drop.pm | 8 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Site.pm | 50 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDDrop.pm | 145 | ||||
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDSite.pm | 159 |
10 files changed, 933 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Common.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Common.pm new file mode 100644 index 00000000000..2f7a33d4fb4 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Common.pm @@ -0,0 +1,59 @@ +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.old/lib/Tk/DragDrop/LocalDrop.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/LocalDrop.pm new file mode 100644 index 00000000000..0f5028ae64c --- /dev/null +++ b/Master/tlpkg/tlperl.old/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.old/lib/Tk/DragDrop/Rect.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Rect.pm new file mode 100644 index 00000000000..04cfa8772f2 --- /dev/null +++ b/Master/tlpkg/tlperl.old/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 = 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.old/lib/Tk/DragDrop/SunConst.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunConst.pm new file mode 100644 index 00000000000..66325466e68 --- /dev/null +++ b/Master/tlpkg/tlperl.old/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.old/lib/Tk/DragDrop/SunDrop.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunDrop.pm new file mode 100644 index 00000000000..422a08196ea --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunDrop.pm @@ -0,0 +1,200 @@ +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.old/lib/Tk/DragDrop/SunSite.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunSite.pm new file mode 100644 index 00000000000..ab3f4f9793b --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/SunSite.pm @@ -0,0 +1,107 @@ +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.old/lib/Tk/DragDrop/Win32Drop.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Drop.pm new file mode 100644 index 00000000000..08a4656ecce --- /dev/null +++ b/Master/tlpkg/tlperl.old/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.old/lib/Tk/DragDrop/Win32Site.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Site.pm new file mode 100644 index 00000000000..f45d06bc92b --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/Win32Site.pm @@ -0,0 +1,50 @@ +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.old/lib/Tk/DragDrop/XDNDDrop.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDDrop.pm new file mode 100644 index 00000000000..7376c8d69c5 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDDrop.pm @@ -0,0 +1,145 @@ +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.old/lib/Tk/DragDrop/XDNDSite.pm b/Master/tlpkg/tlperl.old/lib/Tk/DragDrop/XDNDSite.pm new file mode 100644 index 00000000000..4ac75d63c40 --- /dev/null +++ b/Master/tlpkg/tlperl.old/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__ |