home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / After.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-27  |  1.7 KB  |  99 lines
  1. # Copyright (c) 1995-2003 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#7 $
  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.   }
  19. }
  20.  
  21. sub submit
  22. {
  23.  my $obj     = shift;
  24.  my $w       = $obj->[0];
  25.  my $id      = $obj->[1];
  26.  my $t       = $obj->[2];
  27.  my $method  = $obj->[3];
  28.  delete($w->{_After_}{$id}) if (defined $id);
  29.  $id  = $w->Tk::after($t,[$method => $obj]);
  30.  unless (exists $w->{_After_})
  31.   {
  32.    $w->{_After_} = {};
  33.    $w->OnDestroy([\&_cancelAll, $w]);
  34.   }
  35.  $w->{_After_}{$id} = $obj;
  36.  $obj->[1] = $id;
  37.  return $obj;
  38. }
  39.  
  40. sub DESTROY
  41. {
  42.  my $obj = shift;
  43.  @{$obj} = ();
  44. }
  45.  
  46. sub new
  47. {
  48.  my ($class,$w,$t,$method,@cb) = @_;
  49.  my $cb    = (@cb == 1) ? shift(@cb) : [@cb];
  50.  my $obj   = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
  51.  return $obj->submit;
  52. }
  53.  
  54. sub cancel
  55. {
  56.  my $obj = shift;
  57.  my $id  = $obj->[1];
  58.  my $w   = $obj->[0];
  59.  if ($id)
  60.   {
  61.    $w->Tk::after('cancel'=> $id);
  62.    delete $w->{_After_}{$id} if exists $w->{_After_};
  63.    $obj->[1] = undef;
  64.   }
  65.  return $obj;
  66. }
  67.  
  68. sub repeat
  69. {
  70.  my $obj = shift;
  71.  $obj->submit;
  72.  local $Tk::widget = $obj->[0];
  73.  $obj->[4]->Call;
  74. }
  75.  
  76. sub once
  77. {
  78.  my $obj = shift;
  79.  my $w   = $obj->[0];
  80.  my $id  = $obj->[1];
  81.  delete $w->{_After_}{$id};
  82.  local $Tk::widget = $w;
  83.  $obj->[4]->Call;
  84. }
  85.  
  86. sub time {
  87.     my $obj = shift;
  88.     my $delay = shift;
  89.     if (defined $delay) {
  90.     $obj->cancel if $delay == 0;
  91.     $obj->[2] = $delay;
  92.     }
  93.     $obj->[2];
  94. }
  95.  
  96. 1;
  97. __END__
  98.  
  99.