home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _ad4cae82408f5dd8a46971d69b66197c < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.0 KB  |  105 lines
  1. # Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::After;
  5. use Carp;
  6.  
  7. use vars qw($VERSION);
  8. $VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/After.pm#11 $
  9.  
  10. sub _cancelAll
  11. {
  12.  my $w = shift;
  13.  my $h = delete $w->{_After_};
  14.  foreach my $obj (values %$h)
  15.   {
  16.    # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName;
  17.    $obj->cancel;
  18.    bless $obj,"Tk::After::Cancelled";
  19.   }
  20. }
  21.  
  22. sub Tk::After::Cancelled::once { }
  23. sub Tk::After::Cancelled::repeat { }
  24.  
  25. sub submit
  26. {
  27.  my $obj     = shift;
  28.  my $w       = $obj->[0];
  29.  my $id      = $obj->[1];
  30.  my $t       = $obj->[2];
  31.  my $method  = $obj->[3];
  32.  delete($w->{_After_}{$id}) if (defined $id);
  33.  $id  = $w->Tk::after($t,[$method => $obj]);
  34.  unless (exists $w->{_After_})
  35.   {
  36.    $w->{_After_} = {};
  37.    $w->OnDestroy([\&_cancelAll, $w]);
  38.   }
  39.  $w->{_After_}{$id} = $obj;
  40.  $obj->[1] = $id;
  41.  return $obj;
  42. }
  43.  
  44. sub DESTROY
  45. {
  46.  my $obj = shift;
  47.  $obj->cancel;
  48.  undef $obj->[0];
  49.  undef $obj->[4];
  50. }
  51.  
  52. sub new
  53. {
  54.  my ($class,$w,$t,$method,@cb) = @_;
  55.  my $cb    = (@cb == 1) ? shift(@cb) : [@cb];
  56.  my $obj   = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
  57.  return $obj->submit;
  58. }
  59.  
  60. sub cancel
  61. {
  62.  my $obj = shift;
  63.  my $id  = $obj->[1];
  64.  my $w   = $obj->[0];
  65.  if ($id)
  66.   {
  67.    $w->Tk::after('cancel'=> $id) if Tk::Exists($w);
  68.    delete $w->{_After_}{$id} if exists $w->{_After_};
  69.    $obj->[1] = undef;
  70.   }
  71.  return $obj;
  72. }
  73.  
  74. sub repeat
  75. {
  76.  my $obj = shift;
  77.  $obj->submit;
  78.  local $Tk::widget = $obj->[0];
  79.  $obj->[4]->Call;
  80. }
  81.  
  82. sub once
  83. {
  84.  my $obj = shift;
  85.  my $w   = $obj->[0];
  86.  my $id  = $obj->[1];
  87.  delete $w->{_After_}{$id};
  88.  local $Tk::widget = $w;
  89.  $obj->[4]->Call;
  90. }
  91.  
  92. sub time {
  93.     my $obj = shift;
  94.     my $delay = shift;
  95.     if (defined $delay) {
  96.     $obj->cancel if $delay == 0;
  97.     $obj->[2] = $delay;
  98.     }
  99.     $obj->[2];
  100. }
  101.  
  102. 1;
  103. __END__
  104.  
  105.