home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _1deb9ec12768b8ea976bfd6d9d827012 < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.1 KB  |  133 lines
  1. package Tk::Event::IO;
  2. use strict;
  3. use Carp;
  4.  
  5. use vars qw($VERSION @EXPORT_OK);
  6. $VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
  7.  
  8. use base qw(Exporter);
  9. use Symbol ();
  10.  
  11. @EXPORT_OK = qw(READABLE WRITABLE);
  12.  
  13. sub PrintArgs
  14. {
  15.  my $func = (caller(1))[3];
  16.  print "$func(",join(',',@_),")\n";
  17. }
  18.  
  19. sub PRINT
  20. {
  21.  my $obj = shift;
  22.  $obj->wait(WRITABLE);
  23.  my $h = $obj->handle;
  24.  return print $h @_;
  25. }
  26.  
  27. sub PRINTF
  28. {
  29.  my $obj = shift;
  30.  $obj->wait(WRITABLE);
  31.  my $h = $obj->handle;
  32.  return printf $h @_;
  33. }
  34.  
  35. sub WRITE
  36. {
  37.  my $obj = $_[0];
  38.  $obj->wait(WRITABLE);
  39.  return syswrite($obj->handle,$_[1],$_[2]);
  40. }
  41.  
  42. my $depth = 0;
  43. sub READLINE
  44. {
  45.  my $obj = shift;
  46.  $obj->wait(READABLE);
  47.  my $h = $obj->handle;
  48.  my $w = <$h>;
  49.  return $w;
  50. }
  51.  
  52. sub READ
  53. {
  54.  my $obj = $_[0];
  55.  $obj->wait(READABLE);
  56.  my $h = $obj->handle;
  57.  return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0);
  58. }
  59.  
  60. sub GETC
  61. {
  62.  my $obj = $_[0];
  63.  $obj->wait(READABLE);
  64.  my $h = $obj->handle;
  65.  return getc($h);
  66. }
  67.  
  68. sub CLOSE
  69. {
  70.  my $obj = shift;
  71.  $obj->unwatch;
  72.  my $h = $obj->handle;
  73.  return close($h);
  74. }
  75.  
  76. sub EOF
  77. {
  78.  my $obj = shift;
  79.  my $h = $obj->handle;
  80.  return eof($h);
  81. }
  82.  
  83. sub FILENO
  84. {
  85.  my $obj = shift;
  86.  my $h = $obj->handle;
  87.  return fileno($h);
  88. }
  89.  
  90. sub imode
  91. {
  92.  my $mode = shift;
  93.  my $imode = ${{'readable' => READABLE(),
  94.                 'writable' => WRITABLE()}}{$mode};
  95.  croak("Invalid handler type '$mode'") unless (defined $imode);
  96.  return $imode;
  97. }
  98.  
  99. sub fileevent
  100. {
  101.  my ($widget,$file,$mode,$cb) = @_;
  102.  my $imode = imode($mode);
  103.  unless (ref $file)
  104.   {
  105.    no strict 'refs';
  106.    $file = Symbol::qualify($file,(caller)[0]);
  107.    $file = \*{$file};
  108.   }
  109.  my $obj = tied(*$file);
  110.  unless ($obj && $obj->isa('Tk::Event::IO'))
  111.   {
  112.    $obj = tie *$file,'Tk::Event::IO', $file;
  113.   }
  114.  if (@_ == 3)
  115.   {
  116.    # query return the handler
  117.    return $obj->handler($imode);
  118.   }
  119.  else
  120.   {
  121.    # set the handler
  122.    my $h = $obj->handler($imode,$cb);
  123.    undef $obj;  # Prevent warnings about untie with ref to object
  124.    unless ($h)
  125.     {
  126.      untie *$file;
  127.     }
  128.   }
  129. }
  130.  
  131. 1;
  132. __END__
  133.