summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/DragDrop/Win32Site.pm
blob: f45d06bc92b7ad4cf28dafc4bfcdb654d3e3cae6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
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__