home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _84032d9bebb401a0690319ab7df4e06b < prev    next >
Encoding:
Text File  |  2004-06-01  |  1018 b   |  51 lines
  1. package Tk::DragDrop::Win32Site;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
  5.  
  6. use Tk qw($XS_VERSION);
  7. require DynaLoader;
  8. require Tk::DropSite;
  9.  
  10. use base qw(Tk::DropSite DynaLoader);
  11.  
  12. bootstrap Tk::DragDrop::Win32Site;
  13.  
  14. use strict;
  15.  
  16. Tk::DropSite->Type('Win32');
  17.  
  18. sub WM_DROPFILES () {563}
  19.  
  20. sub InitSite
  21. {
  22.  my ($class,$site) = @_;
  23.  my $w = $site->widget;
  24.  $w->BindClientMessage(WM_DROPFILES,[\&Win32Drop,$site]);
  25.  DragAcceptFiles($w,1);
  26. }
  27.  
  28. sub Win32Drop
  29. {
  30.  # print join(',',@_),"\n";
  31.  my ($w,$site,$msg,$wParam,$lParam) = @_;
  32.  my ($x,$y,@files) = DropInfo($wParam);
  33.  my $cb = $site->{'-dropcommand'};
  34.  $site->Apply(-entercommand => $x, $y, 1);
  35.  if ($cb)
  36.   {
  37.    foreach my $file (@files)
  38.     {
  39.      # print "$file @ $x,$y\n";
  40.      $w->clipboardClear;
  41.      $w->clipboardAppend('--',$file);
  42.      $cb->Call('CLIPBOARD',Win32Drop => ['STRING'],$x,$y);
  43.     }
  44.   }
  45.  $site->Apply(-entercommand => $x, $y, 0);
  46.  return 0;
  47. }
  48.  
  49. 1;
  50. __END__
  51.