diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/DropSite.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/DropSite.pm | 257 |
1 files changed, 0 insertions, 257 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/DropSite.pm b/Master/tlpkg/tlperl/lib/Tk/DropSite.pm deleted file mode 100644 index 3519c108384..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/DropSite.pm +++ /dev/null @@ -1,257 +0,0 @@ -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; |