home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.8.3.809-MSWin32-x86.msi / _38186e907ef425a7983b33d105fcc39b < prev    next >
Encoding:
Text File  |  2004-02-02  |  7.4 KB  |  332 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 = '3.029'; # $Id: //depot/Tk8/DragDrop/DragDrop.pm#29 $
  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 = 1; # ($^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->saveunder(1);
  50.    $token->ConfigSpecs(-text => ['SELF','text','Text',$parent->class]);
  51.   }
  52.  else
  53.   {
  54.    my $lab = $token->Label->pack(-expand => 1, -fill => 'both');
  55.    bless $lab,ref($token);
  56.    $lab->bindtags([ref($token), $lab, $token, 'all']);
  57.    $token->ConfigSpecs(-text => [$lab,'text','Text',$parent->class],
  58.                        DEFAULT => [$lab]);
  59.   }
  60.  $token->withdraw;
  61.  $token->overrideredirect(1);
  62.  $token->ConfigSpecs(-sitetypes       => ['METHOD','siteTypes','SiteTypes',undef],
  63.                      -startcommand    => ['CALLBACK',undef,undef,undef],
  64.                      -endcommand      => ['CALLBACK',undef,undef,undef],
  65.                      -predropcommand  => ['CALLBACK',undef,undef,undef],
  66.                      -postdropcommand => ['CALLBACK',undef,undef,undef],
  67.                      -delta           => ['PASSIVE','delta','Delta',10],
  68.                      -cursor          => ['SELF','cursor','Cursor','hand2'],
  69.                      -handlers        => ['SETMETHOD','handlers','Handlers',[[[$token,'SendText']]]],
  70.                      -selection       => ['SETMETHOD','selection','Selection','XdndSelection'],
  71.                      -event           => ['SETMETHOD','event','Event','<B1-Motion>']
  72.                     );
  73.  $token->{InstallHandlers} = 0;
  74.  $args->{-borderwidth} = 3;
  75.  $args->{-relief} = 'flat';
  76.  $args->{-takefocus} = 1;
  77. }
  78.  
  79. sub sitetypes
  80. {
  81.  my ($w,$val) = @_;
  82.  confess "Not a widget $w" unless (ref $w);
  83.  my $var = \$w->{Configure}{'-sitetypes'};
  84.  if (@_ > 1)
  85.   {
  86.    if (defined $val)
  87.     {
  88.      $val = [$val] unless (ref $val);
  89.      my $type;
  90.      foreach $type (@$val)
  91.       {
  92.        Tk::DragDrop->import($type);
  93.       }
  94.     }
  95.    $$var = $val;
  96.   }
  97.  return (defined $$var) ? $$var : \@types;
  98. }
  99.  
  100. sub SendText
  101. {
  102.  my ($w,$offset,$max) = @_;
  103.  my $s = substr($w->cget('-text'),$offset);
  104.  $s = substr($s,0,$max) if (length($s) > $max);
  105.  return $s;
  106. }
  107.  
  108. sub handlers
  109. {
  110.  my ($token,$opt,$value) = @_;
  111.  $token->{InstallHandlers} = (defined($value) && @$value);
  112.  $token->{'handlers'}  = $value;
  113. }
  114.  
  115. sub selection
  116. {
  117.  my ($token,$opt,$value) = @_;
  118.  my $handlers = $token->{'handlers'};
  119.  $token->{InstallHandlers} = (defined($handlers) && @$handlers);
  120. }
  121.  
  122. sub event
  123. {
  124.  my ($w,$opt,$value) = @_;
  125.  # delete old bindings
  126.  $w->parent->Tk::bind($value,[$w,'StartDrag']);
  127. }
  128.  
  129. #
  130.  
  131. sub FindSite
  132. {
  133.  my ($token,$X,$Y,$e) = @_;
  134.  my $site;
  135.  my $types = $token->sitetypes;
  136.  if (defined $types && @$types)
  137.   {
  138.    foreach my $type (@$types)
  139.     {
  140.      my $class = $type{$type};
  141.      last if (defined($class) && ($site = $class->FindSite($token,$X,$Y)));
  142.     }
  143.   }
  144.  else
  145.   {
  146.    warn 'No sitetypes';
  147.   }
  148.  my $new = $site || 'undef';
  149.  my $over = $token->{'Over'};
  150.  if ($over)
  151.   {
  152.    if (!$over->Match($site))
  153.     {
  154.      $over->Leave($token,$e);
  155.      delete $token->{'Over'};
  156.     }
  157.   }
  158.  if ($site)
  159.   {
  160.    unless ($token->{'Over'})
  161.     {
  162.      $site->Enter($token,$e);
  163.      $token->{'Over'} = $site;
  164.     }
  165.    $site->Motion($token,$e) if (defined $site)
  166.   }
  167.  return $site;
  168. }
  169.  
  170. sub Mapped
  171. {
  172.  my ($token) = @_;
  173.  my $e = $token->parent->XEvent;
  174.  $token = $token->toplevel;
  175.  $token->grabGlobal;
  176.  $token->focus;
  177.  if (defined $e)
  178.   {
  179.    my $X = $e->X;
  180.    my $Y = $e->Y;
  181.    $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
  182.    $token->NewDrag;
  183.    $token->FindSite($X,$Y,$e);
  184.   }
  185. }
  186.  
  187. sub NewDrag
  188. {
  189.  my ($token) = @_;
  190.  my $types = $token->sitetypes;
  191.  if (defined $types && @$types)
  192.   {
  193.    my $type;
  194.    foreach $type (@$types)
  195.     {
  196.      my $class = $type{$type};
  197.      if (defined $class)
  198.       {
  199.        $class->NewDrag($token);
  200.       }
  201.     }
  202.   }
  203. }
  204.  
  205. sub Drag
  206. {
  207.  my $token = shift;
  208.  my $e = $token->XEvent;
  209.  my $X  = $e->X;
  210.  my $Y  = $e->Y;
  211.  $token = $token->toplevel;
  212.  $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
  213.  $token->FindSite($X,$Y,$e);
  214. }
  215.  
  216. sub Done
  217. {
  218.  my $token = shift;
  219.  my $e     = $token->XEvent;
  220.  $token    = $token->toplevel;
  221.  my $over  = delete $token->{'Over'};
  222.  $over->Leave($token,$e) if (defined $over);
  223.  my $w     = $token->parent;
  224.  eval {local $SIG{__DIE__}; $token->grabRelease };
  225.  $token->withdraw;
  226.  delete $w->{'Dragging'};
  227.  $w->update;
  228. }
  229.  
  230. sub AcceptDrop
  231. {
  232.  my ($token) = @_;
  233.  $token->configure(-relief => 'sunken');
  234.  $token->{'Accepted'} = 1;
  235. }
  236.  
  237. sub RejectDrop
  238. {
  239.  my ($token) = @_;
  240.  $token->configure(-relief => 'flat');
  241.  $token->{'Accepted'} = 0;
  242. }
  243.  
  244. sub HandleLoose
  245. {
  246.  my ($w,$seln) = @_;
  247.  return '';
  248. }
  249.  
  250. sub InstallHandlers
  251. {
  252.  my ($token,$seln) = @_;
  253.  my $w = $token->parent;
  254.  $token->configure('-selection' => $seln) if $seln;
  255.  $seln = $token->cget('-selection');
  256.  if ($token->{InstallHandlers})
  257.   {
  258.    foreach my $h (@{$token->cget('-handlers')})
  259.     {
  260.      $w->SelectionHandle('-selection' => $seln,@$h);
  261.     }
  262.    $token->{InstallHandlers} = 0;
  263.   }
  264.  if (!$w->IS($w->SelectionOwner('-selection'=>$seln)))
  265.   {
  266.    $w->SelectionOwn('-selection' => $seln, -command => [\&HandleLoose,$w,$seln]);
  267.   }
  268. }
  269.  
  270. sub Drop
  271. {
  272.  my $ewin  = shift;
  273.  my $e     = $ewin->XEvent;
  274.  my $token = $ewin->toplevel;
  275.  my $site  = $token->FindSite($e->X,$e->Y,$e);
  276.  Tk::catch { $token->grabRelease };
  277.  if (defined $site)
  278.   {
  279.    my $seln = $token->cget('-selection');
  280.    unless ($token->Callback(-predropcommand => $seln, $site))
  281.     {
  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.     }
  288.   }
  289.  else
  290.   {
  291.    $token->Done;
  292.   }
  293.  $token->Callback('-endcommand');
  294. }
  295.  
  296. sub StartDrag
  297. {
  298.  my $token = shift;
  299.  my $w     = $token->parent;
  300.  unless ($w->{'Dragging'})
  301.   {
  302.    my $e = $w->XEvent;
  303.    my $X = $e->X;
  304.    my $Y = $e->Y;
  305.    my $was = $token->{'XY'};
  306.    if ($was)
  307.     {
  308.      my $dx = $was->[0] - $X;
  309.      my $dy = $was->[1] - $Y;
  310.      if (sqrt($dx*$dx+$dy*$dy) > $token->cget('-delta'))
  311.       {
  312.        unless ($token->Callback('-startcommand',$token,$e))
  313.         {
  314.          delete $token->{'XY'};
  315.          $w->{'Dragging'} = $token;
  316.          $token->MoveToplevelWindow($X+OFFSET,$Y+OFFSET);
  317.          $token->raise;
  318.          $token->deiconify;
  319.          $token->FindSite($X,$Y,$e);
  320.         }
  321.       }
  322.     }
  323.    else
  324.     {
  325.      $token->{'XY'} = [$X,$Y];
  326.     }
  327.   }
  328. }
  329.  
  330.  
  331. 1;
  332.