summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/DropSite.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/DropSite.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/DropSite.pm257
1 files changed, 257 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/DropSite.pm b/Master/tlpkg/tlperl/lib/Tk/DropSite.pm
new file mode 100644
index 00000000000..3519c108384
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/DropSite.pm
@@ -0,0 +1,257 @@
+package Tk::DropSite;
+require Tk::DragDrop::Common;
+require Tk::DragDrop::Rect;
+
+use vars qw($VERSION);
+$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Tk::DragDrop::Common Tk::DragDrop::Rect);
+
+Construct Tk::Widget 'DropSite';
+
+use strict;
+use vars qw(%type @types);
+
+Tk::DragDrop->Tk::DragDrop::Common::Type('Local');
+
+my @toplevels;
+
+BEGIN
+{
+ # Are these really methods of Tk::DragDrop::Rect ?
+ no strict 'refs';
+ foreach my $name (qw(x y X Y width height widget))
+ {
+ my $key = $name;
+ *{"$key"} = sub { shift->{$key} };
+ }
+}
+
+# Dropping side API - really only here for Local drops
+# inheritance is a mess right now.
+
+sub NewDrag
+{
+ my ($class,$token) = @_;
+ # No need to clear cached sites we see live data
+}
+
+sub SiteList
+{
+ # this should be inheritable - so that receive side of XDND can re-use it.
+ my ($class,$widget) = @_;
+ my $t;
+ my @list;
+ foreach $t (@toplevels)
+ {
+ my $sites = $t->{'DropSites'};
+ if ($sites)
+ {
+ $sites = $sites->{'Local'};
+ push(@list,@{$sites}) if ($sites);
+ }
+ }
+ return @list;
+}
+
+sub Apply
+{
+ my $site = shift;
+ my $name = shift;
+ my $cb = $site->{$name};
+ if ($cb)
+ {
+ my $X = shift;
+ my $Y = shift;
+ $cb->Call(@_,$X - $site->X, $Y - $site->Y);
+ }
+}
+
+sub Drop
+{
+ my ($site,$token,$seln,$event) = @_;
+ my $X = $event->X;
+ my $Y = $event->Y;
+ my @targ = $token->SelectionGet(-selection => $seln,'TARGETS');
+ $site->Apply(-dropcommand => $X, $Y, $seln,'LocalDrop',\@targ);
+ $site->Apply(-entercommand => $X, $Y, 0);
+ $token->Done;
+}
+
+sub Enter
+{
+ my ($site,$token,$event) = @_;
+ $token->AcceptDrop;
+ $site->Apply(-entercommand => $event->X, $event->Y, 1);
+}
+
+sub Leave
+{
+ my ($site,$token,$event) = @_;
+ $token->RejectDrop;
+ $site->Apply(-entercommand => $event->X, $event->Y, 0);
+}
+
+sub Motion
+{
+ my ($site,$token,$event) = @_;
+ $site->Apply(-motioncommand => $event->X, $event->Y);
+}
+
+# This is receive side API.
+
+sub NoteSites
+{
+ my ($class,$t,$sites) = @_;
+ unless (grep($_ == $t,@toplevels))
+ {
+ $Tk::DragDrop::types{'Local'} = $class if (@$sites);
+ push(@toplevels,$t);
+ $t->OnDestroy(sub { @toplevels = grep($_ != $t,@toplevels) });
+ }
+}
+
+sub UpdateDropSites
+{
+ my ($t) = @_;
+ $t->{'DropUpdate'} = 0;
+ foreach my $type (@types)
+ {
+ my $sites = $t->{'DropSites'}->{$type};
+ if ($sites && @$sites)
+ {
+ my $class = $type{$type};
+ $class->NoteSites($t,$sites);
+ }
+ }
+}
+
+sub QueueDropSiteUpdate
+{
+ my $obj = shift;
+ my $class = ref($obj);
+ my $t = $obj->widget->toplevel;
+ unless ($t->{'DropUpdate'})
+ {
+ $t->{'DropUpdate'} = 1;
+ $t->afterIdle(sub { UpdateDropSites($t) });
+ }
+}
+
+sub delete
+{
+ my ($obj) = @_;
+ my $w = $obj->widget;
+ $w->bindtags([grep($_ ne $obj,$w->bindtags)]);
+ my $t = $w->toplevel;
+ foreach my $type (@{$obj->{'-droptypes'}})
+ {
+ my $a = $t->{'DropSites'}->{$type};
+ @$a = grep($_ ne $obj,@$a);
+ }
+ $obj->QueueDropSiteUpdate;
+}
+
+sub DropSiteUpdate
+{
+ # Note size of widget and arrange to update properties etc.
+ my $obj = shift;
+ my $w = $obj->widget;
+ $obj->{'x'} = $w->X;
+ $obj->{'y'} = $w->Y;
+ $obj->{'X'} = $w->rootx;
+ $obj->{'Y'} = $w->rooty;
+ $obj->{'width'} = $w->Width;
+ $obj->{'height'} = $w->Height;
+ $obj->QueueDropSiteUpdate;
+}
+
+sub TopSiteUpdate
+{
+ my ($t) = @_;
+ foreach my $type (@types)
+ {
+ my $sites = $t->{'DropSites'}->{$type};
+ if ($sites && @$sites)
+ {
+ my $site;
+ foreach $site (@$sites)
+ {
+ $site->DropSiteUpdate;
+ }
+ }
+ }
+}
+
+sub Callback
+{
+ my $obj = shift;
+ my $key = shift;
+ my $cb = $obj->{$key};
+ $cb->Call(@_) if (defined $cb);
+}
+
+sub InitSite
+{
+ my ($class,$site) = @_;
+ # Tk::DragDrop->Type('Local');
+}
+
+sub new
+{
+ my ($class,$w,%args) = @_;
+ my $t = $w->toplevel;
+ $args{'widget'} = $w;
+ if (exists $args{'-droptypes'})
+ {
+ # Convert single type to array-of-one
+ $args{'-droptypes'} = [$args{'-droptypes'}] unless (ref $args{'-droptypes'});
+ }
+ else
+ {
+ # Default to all known types.
+ $args{'-droptypes'} = \@types;
+ }
+ my ($key,$val);
+ while (($key,$val) = each %args)
+ {
+ if ($key =~ /command$/)
+ {
+ $val = Tk::Callback->new($val);
+ $args{$key} = $val;
+ }
+ }
+ my $obj = bless \%args,$class;
+ unless (exists $t->{'DropSites'})
+ {
+ $t->{'DropSites'} = {};
+ $t->{'DropUpdate'} = 0;
+ }
+ my $type;
+ foreach $type (@{$args{'-droptypes'}})
+ {
+ Tk::DropSite->import($type) unless (exists $type{$type});
+ my $class = $type{$type};
+ $class->InitSite($obj);
+ # Should this be indexed by type or class ?
+ unless (exists $t->{'DropSites'}->{$type})
+ {
+ $t->{'DropSites'}->{$type} = [];
+ }
+ push(@{$t->{'DropSites'}->{$type}},$obj);
+ }
+ $w->OnDestroy([$obj,'delete']);
+ $obj->DropSiteUpdate;
+ $w->bindtags([$w->bindtags,$obj]);
+ $w->Tk::bind($obj,'<Map>',[$obj,'DropSiteUpdate']);
+ $w->Tk::bind($obj,'<Unmap>',[$obj,'DropSiteUpdate']);
+ $w->Tk::bind($obj,'<Configure>',[$obj,'DropSiteUpdate']);
+ $t->Tk::bind($class,'<Configure>',[\&TopSiteUpdate,$t]);
+ unless (grep($_ eq $class,$t->bindtags))
+ {
+ $t->bindtags([$t->bindtags,$class]);
+ }
+ return $obj;
+}
+
+1;