home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / LWP / TkIO.pm < prev    next >
Text File  |  1996-04-07  |  2KB  |  106 lines
  1. package LWP::IO;
  2.  
  3. # $Id: TkIO.pm,v 1.4 1996/04/07 20:39:06 aas Exp $
  4.  
  5. require Tk;
  6. require LWP::Debug;
  7.  
  8. =head1 NAME
  9.  
  10. LWP::TkIO - Tk I/O routines for the LWP library
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.  use Tk;
  15.  require LWP::TkIO;
  16.  require LWP::UserAgent;
  17.  
  18. =head1 DESCRIPTION
  19.  
  20. This module provide replacement functions for the LWP::IO
  21. functions. Require this module if you use Tk and want non exclusive IO
  22. behaviour from LWP.  This does not allow LWP to run simultaneous
  23. requests though.
  24.  
  25. See also L<LWP::IO>.
  26.  
  27. =cut
  28.  
  29.  
  30. sub read
  31. {
  32.     my $fd = shift;
  33.     my $dataRef = \$_[0];
  34.     my $size    =  $_[1];
  35.     my $offset  =  $_[2] || 0;
  36.     my $timeout =  $_[3];
  37.  
  38.     my $doneFlag = 0;
  39.     my $timeoutFlag = 0;
  40.     my $n;
  41.  
  42.     Tk->fileevent($fd, 'readable',
  43.           sub {
  44.               $n = sysread($fd, $$dataRef, $size, $offset);
  45.               LWP::Debug::conns("Read $n bytes: '" .
  46.                     substr($$dataRef, $offset, $n) .
  47.                     "'") if defined $n;
  48.               $doneFlag = 1;
  49.           }
  50.          );
  51.     my $timer = Tk->after($timeout*1000, sub {$timeoutFlag = 1;} );
  52.  
  53.     Tk::DoOneEvent(0) until ($doneFlag || $timeoutFlag);
  54.  
  55.     Tk->after(cancel => $timer);
  56.     Tk->fileevent($fd, 'readable', ''); # no more callbacks
  57.     die "Timeout" if $timeoutFlag;
  58.     return $n;
  59. }
  60.  
  61.  
  62. sub write
  63. {
  64.     my $fd = shift;
  65.     my $dataRef = \$_[0];
  66.     my $timeout =  $_[1];
  67.  
  68.     my $len = length $$dataRef;
  69.  
  70.     return 0 unless $len;
  71.  
  72.     my $offset = 0;
  73.     my $timeoutFlag = 0;
  74.     my $doneFlag = 0;
  75.  
  76.     my $timeoutSub = sub { $timeoutFlag = 1; };
  77.     my $timer;
  78.     $timer = Tk->after($timeout*1000, $timeoutSub ) if $timeout;
  79.  
  80.     Tk->fileevent($fd, 'writable',
  81.           sub {
  82.               my $n = syswrite($fd, $$dataRef, $len-$offset, $offset);
  83.               if (!defined $n) {
  84.               $done = 1;
  85.               } else {
  86.               LWP::Debug::conns("Write $n bytes: '" .
  87.                         substr($$dataRef, $offset, $n) .
  88.                         "'");
  89.               $offset += $n;
  90.               $timer = Tk->after($timeout*1000, $timeoutSub )
  91.                 if $timeout;
  92.               }
  93.           }
  94.          );
  95.  
  96.     Tk::DoOneEvent(0) until ($timeoutFlag || $doneFlag || $offset >= $len);
  97.  
  98.     Tk->fileevent($fd, 'writable', ''); # no more callbacks
  99.     Tk->after(cancel => $timer) if $timeout;
  100.  
  101.     die "Timeout" if $timeoutFlag;
  102.     $offset;
  103. }
  104.  
  105. 1;
  106.