home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / After.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  2.1 KB  |  117 lines
  1. # Copyright (c) 1995-1997 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. sub _cancelAll
  8. {
  9.  my $h = shift;
  10.  my $obj;
  11.  foreach $obj (values %$h)
  12.   {
  13.    # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName;
  14.    $obj->cancel;
  15.   }
  16. }
  17.  
  18. sub submit
  19. {
  20.  my $obj     = shift;
  21.  my $w       = $obj->[0];
  22.  my $id      = $obj->[1];
  23.  my $t       = $obj->[2];
  24.  my $method  = $obj->[3];
  25.  delete($w->{_After_}{$id}) if (defined $id);
  26.  $id  = $w->Tk::after($t,[$method => $obj]);
  27.  unless (exists $w->{_After_})
  28.   {
  29.    $w->{_After_} = {};
  30.    $w->OnDestroy(sub { _cancelAll($w->{_After_}) });
  31.   }
  32.  $w->{_After_}{$id} = $obj;
  33.  $obj->[1] = $id;
  34.  return $obj;
  35. }
  36.  
  37. sub DESTROY
  38. {
  39.  my $obj     = shift;
  40.  @{$obj} = ();
  41. }
  42.  
  43. sub new
  44. {
  45.  my ($class,$w,$t,$method,@cb) = @_;
  46.  my $cb    = (@cb == 1) ? shift(@cb) : [@cb];
  47.  my $obj   = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class;
  48.  return $obj->submit;
  49. }
  50.  
  51. sub cancel
  52. {
  53.  my $obj = shift;
  54.  my $id  = $obj->[1];
  55.  my $w   = $obj->[0];
  56.  if ($id)
  57.   {
  58.    $w->Tk::after('cancel'=> $id); 
  59.    delete $w->{_After_}{$id};
  60.    $obj->[1] = undef;
  61.   }
  62.  return $obj;
  63. }
  64.  
  65. sub repeat
  66. {
  67.  my $obj = shift;
  68.  $obj->submit;
  69.  local $Tk::widget = $obj->[0];
  70.  $obj->[4]->Call;
  71. }
  72.  
  73. sub once
  74. {
  75.  my $obj = shift;
  76.  my $w   = $obj->[0];
  77.  my $id  = $obj->[1];
  78.  delete $w->{_After_}{$id};
  79.  local $Tk::widget = $w;
  80.  $obj->[4]->Call;
  81. }
  82.  
  83. 1;
  84. __END__
  85.  
  86. =head1 NAME
  87.  
  88. Tk::After - support class for Tk::Widget::after
  89.  
  90. =head1 SYNOPSIS
  91.  
  92.   $id = $widget->after(time,callback);
  93.   $id = $widget->afterIdle(callback);
  94.   $widget->afterCancel($id);
  95.  
  96.   $id = $widget->repeat(period,callback);
  97.  
  98. Internally this class is used to implement above.
  99.  
  100.   $id = Tk::After->new($widget,$time,'method',callback);
  101.   $id->cancel;
  102.  
  103. =head1 DESCRIPTION
  104.  
  105. This class is a wrapper used by Tk::Widget::after to auto-cancel
  106. after calls when a widget is destroyed.
  107.  
  108. I<callback> is a normal perl/Tk callback. Method is either I<'once'> 
  109. or I<'repeat'>
  110.  
  111. This is first attempt at the code and interface is likely to change.
  112. So for the time being at least use $widget->after(...) interface.
  113.  
  114.  
  115.  
  116.  
  117.