home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / IO.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  4.0 KB  |  226 lines
  1. package Tk::IO;
  2. require 5.002;
  3. require Tk;
  4. use Tk::Pretty;
  5. require DynaLoader;
  6. require Exporter;
  7. require IO::Handle;
  8. use Carp;
  9. @Tk::IO::ISA = qw(DynaLoader IO::Handle Exporter);
  10.  
  11. bootstrap Tk::IO $Tk::VERSION;
  12.  
  13. sub new
  14. {
  15.  my ($package,%args) = @_;
  16.  # Do whatever IO::Handle does
  17.  my $fh  = $package->SUPER::new;
  18.  %{*$fh} = ();  # The hash is used for configure options
  19.  ${*$fh} = "";  # The scalar is used as the 'readable' buffer
  20.  @{*$fh} = ();  # The array 
  21.  $fh->configure(%args);
  22.  return $fh;
  23. }
  24.  
  25. sub pending
  26. {
  27.  my $fh = shift;
  28.  return ${*$fh};
  29. }
  30.  
  31. sub cget
  32. {
  33.  my ($fh,$key) = @_;
  34.  return ${*$fh}{$key};
  35. }
  36.  
  37. sub configure
  38. {
  39.  my ($fh,%args) = @_;
  40.  my $key;
  41.  foreach $key (keys %args)
  42.   {
  43.    my $val = $args{$key};
  44.    $val = Tk::Callback->new($val) if ($key =~ /command$/);
  45.    ${*$fh}{$key} = $val;
  46.   }
  47. }
  48.  
  49. sub kill
  50. {
  51.  my ($fh,$sig) = @_;
  52.  my $pid = $fh->pid;
  53.  croak "No child" unless (defined $pid);
  54.  kill($sig,$pid) || croak "Cannot kill($sig,$pid):$!";
  55. }
  56.  
  57. sub killpg
  58. {
  59.  my ($fh,$sig) = @_;
  60.  my $pid = $fh->pid;
  61.  croak "No child" unless (defined $pid);
  62.  kill($sig,-$pid);
  63. }
  64.  
  65. sub readable
  66. {
  67.  my $fh     = shift;
  68.  my $count  = sysread($fh,${*$fh},1,length(${*$fh}));
  69.  if ($count < 0)
  70.   {
  71.    if (exists ${*$fh}{-errorcommand})
  72.     {
  73.      ${*$fh}{-errorcommand}->Call($!);
  74.     }
  75.    else
  76.     {
  77.      warn "Cannot read $fh:$!";
  78.      $fh->close;
  79.     }
  80.   }
  81.  elsif ($count)
  82.   {
  83.    if (exists ${*$fh}{-linecommand})
  84.     {
  85.      my $eol = index(${*$fh},"\n");
  86.      if ($eol >= 0)
  87.       {
  88.        my $line = substr(${*$fh},0,++$eol);
  89.        substr(${*$fh},0,$eol) = "";
  90.        ${*$fh}{-linecommand}->Call($line);
  91.       }
  92.     }
  93.   }
  94.  else
  95.   {
  96.    $fh->close;
  97.   }
  98. }
  99.  
  100. sub pid
  101. {
  102.  my $fh = shift;
  103.  return ${*$fh}{-pid};
  104. }
  105.  
  106. sub command
  107. {
  108.  my $fh  = shift;
  109.  my $cmd = ${*$fh}{'-exec'};
  110.  return (wantarray) ? @$cmd : $cmd;
  111. }
  112.  
  113. sub exec
  114. {
  115.  my $fh  = shift;
  116.  my $pid = open($fh,"-|");
  117.  if ($pid)
  118.   {
  119.    ${*$fh} = "" unless (defined ${*$fh});
  120.    ${*$fh}{'-exec'} = [@_];
  121.    ${*$fh}{'-pid'}  = $pid;
  122.    if (exists ${*$fh}{-linecommand})
  123.     {
  124.      my $w = ${*$fh}{-widget};
  125.      $w = 'Tk' unless (defined $w);
  126.      $w->fileevent($fh,'readable',[$fh,'readable']);
  127.      ${*$fh}{_readable} = $w;
  128.     }
  129.    else
  130.     {
  131.      croak Tk::Pretty::Pretty(\%{*$fh});
  132.     }
  133.    return $pid;
  134.   }
  135.  else
  136.   {
  137.    # make STDERR same as STDOUT here
  138.    setpgrp;
  139.    exec(@_) || die "Cannot exec ",join(' ',@_),":$!";
  140.   }
  141. }
  142.  
  143. sub wait
  144. {
  145.  my $fh = shift;
  146.  my $code;
  147.  my $ch = delete ${*$fh}{-childcommand};
  148.  ${*$fh}{-childcommand} = Tk::Callback->new(sub { $code = shift });
  149.  Tk->DoOneEvent until (defined $code);
  150.  if (defined $ch)
  151.   {
  152.    ${*$fh}{-childcommand} = $ch;
  153.    $ch->Call($code,$fh) 
  154.   }
  155.  return $code;
  156. }
  157.  
  158. sub close
  159. {
  160.  my $fh = shift;
  161.  if (defined fileno($fh))
  162.   {
  163.    my $w = delete ${*$fh}{_readable};
  164.    $w->fileevent($fh,'readable','') if (defined $w);
  165.    close($fh);
  166.    if (exists ${*$fh}{-childcommand})
  167.     {
  168.      ${*$fh}{-childcommand}->Call($?,$fh);
  169.     }
  170.   }
  171. }
  172.  
  173. sub DESTROY
  174. {  
  175.  shift->close;
  176. }
  177.  
  178. 1;
  179. __END__
  180.  
  181. =head1 NAME
  182.  
  183. Tk::IO - high level interface to Tk's 'fileevent' mechanism
  184.  
  185. =head1 SYNOPSIS
  186.  
  187.   my $fh = Tk::IO->new(-linecommand => callback, -childcommand => callback);
  188.   $fh->exec("command")
  189.   $fh->wait
  190.   $fh->kill
  191.  
  192. =head1 WARNING
  193.  
  194. INTERFACES TO THIS MODULE MAY CHANGE AS PERL'S IO EVOLVES
  195. AND WITH PORT OF TK4.1
  196.  
  197. =head1 DESCRIPTION
  198.  
  199. Tk::IO is now layered on perl's IO::Handle class. Interfaces 
  200. have changed, and are still evolving. 
  201.  
  202. In theory C methods which enable non-blocking IO as in earlier Tk-b*
  203. release(s) are still there. I have not changed them to use perl's 
  204. additional Configure information, or tested them much.
  205.  
  206. Assumption is that B<exec> is 
  207. used to fork a child process and a callback is called each time a 
  208. complete line arrives up the implied pipe.
  209.  
  210. "line" should probably be defined in terms of perl's input record
  211. separator but is not yet.
  212.  
  213. The -childcommand callback is called when end-of-file occurs.
  214.  
  215. $fh->B<wait> can be used to wait for child process while processing
  216. other Tk events.
  217.  
  218. $fh->B<kill> can be used to send signal to child process.
  219.  
  220. =head1 BUGS
  221.  
  222. Still not finished.
  223. Idea is to use "exec" to emulate "system" in a non-blocking manner.
  224.  
  225.  
  226.