home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _38186e907ef425a7983b33d105fcc39b < prev    next >
Encoding:
Text File  |  2004-06-01  |  7.5 KB  |  333 lines
  1. package Tk::DragDrop;
  2. require Tk::DragDrop::Common;
  3. require Tk::Toplevel;
  4. require Tk::Label;
  5.  
  6. use vars qw($VERSION);
  7. $VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
  8.  
  9. use base  qw(Tk::DragDrop::Common Tk::Toplevel);
  10.  
  11. # This is a little tricky, ISA says 'Toplevel' but we
  12. # define a Tk_cmd to actually build a 'Label', then
  13. # use wmRelease in Populate to make it a toplevel.
  14.  
  15. my $useWmRelease = Tk::Wm->can('release'); # ($^O ne 'MSWin32');
  16.  
  17. sub Tk_cmd { ($useWmRelease) ? \&Tk::label : \&Tk::toplevel }
  18.  
  19. Construct Tk::Widget 'DragDrop';
  20.  
  21. use strict;
  22. use vars qw(%type @types);
  23. use Carp;
  24.  
  25.  
  26. # There is a snag with having a token window and moving to
  27. # exactly where cursor is - the cursor is "inside" the token
  28. # window - hence it is not "inside" the dropsite window
  29. # so we offset X,Y by OFFSET pixels.
  30. sub OFFSET () {3}
  31.  
  32. sub ClassInit
  33. {
  34.  my ($class,$mw) = @_;
  35.  $mw->bind($class,'<Map>','Mapped');
  36.  $mw->bind($class,'<Any-KeyPress>','Done');
  37.  $mw->bind($class,'<Any-ButtonRelease>','Drop');
  38.  $mw->bind($class,'<Any-Motion>','Drag');
  39.  return $class;
  40. }
  41.  
  42. sub Populate
  43. {
  44.  my ($token,$args) = @_;
  45.  my $parent = $token->parent;
  46.  if ($useWmRelease)
  47.   {
  48.    $token->wmRelease;
  49.    $token->ConfigSpecs(-text => ['SELF','text','Text',$parent->class]);
  50.   }
  51.  else
  52.   {
  53.    my $lab = $token->Label->pack(-expand => 1, -fill => 'both');
  54.    bless $lab,ref($token);
  55.    $lab->bindtags([ref($token), $lab, $token, 'all']);
  56.    $token->ConfigSpecs(-text => [$lab,'text','Text',$parent->class],
  57.                        DEFAULT => [$lab]);
  58.   }
  59.  $token->withdraw;
  60.  $token->overrideredirect(1);
  61.  $token->ConfigSpecs(-sitetypes       => ['METHOD','siteTypes','SiteTypes',undef],
  62.                      -startcommand    => ['CALLBACK',undef,undef,undef],
  63.                      -endcommand      => ['CALLBACK',undef,undef,undef],
  64.                      -predropcommand  => ['CALLBACK',undef,undef,undef],
  65.                      -postdropcommand => ['CALLBACK',undef,undef,undef],
  66.                      -delta           => ['PASSIVE','delta','Delta',10],
  67.                      -cursor          => ['SELF','cursor','Cursor','hand2'],
  68.                      -handlers        => ['SETMETHOD','handlers','Handlers',[[[$token,'SendText']]]],
  69.                      -selection       => ['SETMETHOD','selection','Selection','XdndSelection'],
  70.                      -event           => ['SETMETHOD','event','Event','<B1-Motion>']
  71.                     );
  72.  $token->{InstallHandlers} = 0;
  73.  $args->{-borderwidth} = 3;
  74.  $args->{-relief} = 'flat';
  75.  $args->{-takefocus} = 1;
  76. }
  77.  
  78. sub sitetypes
  79. {
  80.  my ($w,$val) = @_;
  81.  confess "Not a widget $w" unless (ref $w);
  82.  my $var = \$w->{Configure}{'-sitetypes'};
  83.  if (@_ > 1)
  84.   {
  85.    if (defined $val)
  86.     {
  87.      $val = [$val] unless (ref $val);
  88.      my $type;
  89.      foreach $type (@$val)
  90.       {
  91.        Tk::DragDrop->import($type);
  92.       }
  93.     }
  94.    $$var = $val;
  95.   }
  96.  return (defined $$var) ? $$var : \@types;
  97. }
  98.  
  99. sub SendText
  100. {
  101.  my ($w,$offset,$max) = @_;
  102.  my $s = substr($w->cget('-text'),$offset);
  103.  $s = substr($s,0,$max) if (length($s) > $max);
  104.  return $s;
  105. }
  106.  
  107. sub handlers
  108. {
  109.  my ($token,$opt,$value) = @_;
  110.  $token->{InstallHandlers} = (defined($value) && @$value);
  111.  $token->{'handlers'}  = $value;
  112. }
  113.  
  114. sub selection
  115. {
  116.  my ($token,$opt,$value) = @_;
  117.  my $handlers = $token->{'handlers'};
  118.  $token->{InstallHandlers} = (defined($handlers) && @$handlers);
  119. }
  120.  
  121. sub event
  122. {
  123.  my ($w,$opt,$value) = @_;
  124.  # delete old bindings
  125.  $w->parent->Tk::bind($value,[$w,'StartDrag']);
  126. }
  127.  
  128. #
  129.  
  130. sub FindSite
  131. {
  132.  my ($token,$X,$Y,$e) = @_;
  133.  my $site;
  134.  my $types = $token->sitetypes;
  135.  if (defined $types && @$types)
  136.   {
  137.    foreach my $type (@$types)
  138.     {
  139.      my $class = $type{$type};
  140.      last if (defined($class) && ($site = $class->FindSite($token,$X,$Y)));
  141.     }
  142.   }
  143.  else
  144.   {
  145.    warn 'No sitetypes';
  146.   }
  147.  my $new = $site || 'undef';
  148.  my $over = $token->{'Over'};
  149.  if ($over)
  150.   {
  151.    if (!$over->Match($site))
  152.     {
  153.      $over->Leave($token,$e);
  154.      delete $token->{'Over'};
  155.     }
  156.   }
  157.  if ($site)
  158.   {
  159.    unless ($token->{'Over'})
  160.     {
  161.      $site->Enter($token,$e);
  162.      $token->{'Over'} = $site;
  163.     }
  164.    $site->Motion($token,$e) if (defined $site)
  165.   }
  166.  return $site;
  167. }
  168.  
  169. sub Mapped
  170. {
  171.  my ($token) = @_;
  172.  my $e = $token->parent->XEvent;
  173.  $token = $token->toplevel;
  174.  $token->grabGlobal;
  175.  $token->focus;
  176.  if (defined $e)
  177.   {
  178.    my $X = $e->X;
  179.    my $Y = $e->Y;
  180.    $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
  181.    $token->NewDrag;
  182.    $token->FindSite($X,$Y,$e);
  183.   }
  184. }
  185.  
  186. sub NewDrag
  187. {
  188.  my ($token) = @_;
  189.  my $types = $token->sitetypes;
  190.  if (defined $types && @$types)
  191.   {
  192.    my $type;
  193.    foreach $type (@$types)
  194.     {
  195.      my $class = $type{$type};
  196.      if (defined $class)
  197.       {
  198.        $class->NewDrag($token);
  199.       }
  200.     }
  201.   }
  202. }
  203.  
  204. sub Drag
  205. {
  206.  my $token = shift;
  207.  my $e = $token->XEvent;
  208.  my $X  = $e->X;
  209.  my $Y  = $e->Y;
  210.  $token = $token->toplevel;
  211.  $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
  212.  $token->FindSite($X,$Y,$e);
  213. }
  214.  
  215. sub Done
  216. {
  217.  my $token = shift;
  218.  my $e     = $token->XEvent;
  219.  $token    = $token->toplevel;
  220.  my $over  = delete $token->{'Over'};
  221.  $over->Leave($token,$e) if (defined $over);
  222.  my $w     = $token->parent;
  223.  eval {local $SIG{__DIE__}; $token->grabRelease };
  224.  $token->withdraw;
  225.  delete $w->{'Dragging'};
  226.  $w->update;
  227. }
  228.  
  229. sub AcceptDrop
  230. {
  231.  my ($token) = @_;
  232.  $token->configure(-relief => 'sunken');
  233.  $token->{'Accepted'} = 1;
  234. }
  235.  
  236. sub RejectDrop
  237. {
  238.  my ($token) = @_;
  239.  $token->configure(-relief => 'flat');
  240.  $token->{'Accepted'} = 0;
  241. }
  242.  
  243. sub HandleLoose
  244. {
  245.  my ($w,$seln) = @_;
  246.  return '';
  247. }
  248.  
  249. sub InstallHandlers
  250. {
  251.  my ($token,$seln) = @_;
  252.  my $w = $token->parent;
  253.  $token->configure('-selection' => $seln) if $seln;
  254.  $seln = $token->cget('-selection');
  255.  if ($token->{InstallHandlers})
  256.   {
  257.    foreach my $h (@{$token->cget('-handlers')})
  258.     {
  259.      $w->SelectionHandle('-selection' => $seln,@$h);
  260.     }
  261.    $token->{InstallHandlers} = 0;
  262.   }
  263.  if (!$w->IS($w->SelectionOwner('-selection'=>$seln)))
  264.   {
  265.    $w->SelectionOwn('-selection' => $seln, -command => [\&HandleLoose,$w,$seln]);
  266.   }
  267. }
  268.  
  269. sub Drop
  270. {
  271.  my $ewin  = shift;
  272.  my $e     = $ewin->XEvent;
  273.  my $token = $ewin->toplevel;
  274.  my $site  = $token->FindSite($e->X,$e->Y,$e);
  275.  Tk::catch { $token->grabRelease };
  276.  if (defined $site)
  277.   {
  278.    my $seln = $token->cget('-selection');
  279.    unless ($token->Callback(-predropcommand => $seln, $site))
  280.     {
  281. # XXX This is ugly if the user restarts a drag within the 2000 ms:
  282. #     my $id = $token->after(2000,[$token,'Done']);
  283.      my $w = $token->parent;
  284.      $token->InstallHandlers;
  285.      $site->Drop($token,$seln,$e);
  286.      $token->Callback(-postdropcommand => $seln);
  287.      $token->Done;
  288.     }
  289.   }
  290.  else
  291.   {
  292.    $token->Done;
  293.   }
  294.  $token->Callback('-endcommand');
  295. }
  296.  
  297. sub StartDrag
  298. {
  299.  my $token = shift;
  300.  my $w     = $token->parent;
  301.  unless ($w->{'Dragging'})
  302.   {
  303.    my $e = $w->XEvent;
  304.    my $X = $e->X;
  305.    my $Y = $e->Y;
  306.    my $was = $token->{'XY'};
  307.    if ($was)
  308.     {
  309.      my $dx = $was->[0] - $X;
  310.      my $dy = $was->[1] - $Y;
  311.      if (sqrt($dx*$dx+$dy*$dy) > $token->cget('-delta'))
  312.       {
  313.        unless ($token->Callback('-startcommand',$token,$e))
  314.         {
  315.          delete $token->{'XY'};
  316.          $w->{'Dragging'} = $token;
  317.          $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
  318.          $token->raise;
  319.          $token->deiconify;
  320.          $token->FindSite($X,$Y,$e);
  321.         }
  322.       }
  323.     }
  324.    else
  325.     {
  326.      $token->{'XY'} = [$X,$Y];
  327.     }
  328.   }
  329. }
  330.  
  331.  
  332. 1;
  333.