home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _64ad7d815015c044468c4a7df52c6a81 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.1 KB  |  183 lines
  1. package Tk::IO;
  2. use strict;
  3. use vars qw($VERSION);
  4. $VERSION = '4.004'; # $Id: //depot/Tkutf8/IO/IO.pm#4 $
  5.  
  6. require 5.002;
  7. use Tk::Event qw($XS_VERSION);
  8.  
  9. use Carp;
  10. use base  qw(DynaLoader IO::Handle);
  11.  
  12. bootstrap Tk::IO;
  13.  
  14. my %fh2obj;
  15. my %obj2fh;
  16.  
  17. sub new
  18. {
  19.  my ($package,%args) = @_;
  20.  # Do whatever IO::Handle does
  21.  my $fh  = $package->SUPER::new;
  22.  %{*$fh} = ();  # The hash is used for configure options
  23.  ${*$fh} = '';  # The scalar is used as the 'readable' buffer
  24.  @{*$fh} = ();  # The array
  25.  $fh->configure(%args);
  26.  return $fh;
  27. }
  28.  
  29. sub pending
  30. {
  31.  my $fh = shift;
  32.  return ${*$fh};
  33. }
  34.  
  35. sub cget
  36. {
  37.  my ($fh,$key) = @_;
  38.  return ${*$fh}{$key};
  39. }
  40.  
  41. sub configure
  42. {
  43.  my ($fh,%args) = @_;
  44.  my $key;
  45.  foreach $key (keys %args)
  46.   {
  47.    my $val = $args{$key};
  48.    $val = Tk::Callback->new($val) if ($key =~ /command$/);
  49.    ${*$fh}{$key} = $val;
  50.   }
  51. }
  52.  
  53. sub killpg
  54. {
  55.  my ($fh,$sig) = @_;
  56.  my $pid = $fh->pid;
  57.  croak 'No child' unless (defined $pid);
  58.  kill($sig,-$pid);
  59. }
  60.  
  61. sub kill
  62. {
  63.  my ($fh,$sig) = @_;
  64.  my $pid = $fh->pid;
  65.  croak 'No child' unless (defined $pid);
  66.  kill($sig,$pid) || croak "Cannot kill($sig,$pid):$!";
  67. }
  68.  
  69. sub readable
  70. {
  71.  my $fh     = shift;
  72.  my $count  = sysread($fh,${*$fh},1,length(${*$fh}));
  73.  if ($count < 0)
  74.   {
  75.    if (exists ${*$fh}{-errorcommand})
  76.     {
  77.      ${*$fh}{-errorcommand}->Call($!);
  78.     }
  79.    else
  80.     {
  81.      warn "Cannot read $fh:$!";
  82.      $fh->close;
  83.     }
  84.   }
  85.  elsif ($count)
  86.   {
  87.    if (exists ${*$fh}{-linecommand})
  88.     {
  89.      my $eol = index(${*$fh},"\n");
  90.      if ($eol >= 0)
  91.       {
  92.        my $line = substr(${*$fh},0,++$eol);
  93.        substr(${*$fh},0,$eol) = '';
  94.        ${*$fh}{-linecommand}->Call($line);
  95.       }
  96.     }
  97.   }
  98.  else
  99.   {
  100.    $fh->close;
  101.   }
  102. }
  103.  
  104. sub pid
  105. {
  106.  my $fh = shift;
  107.  return ${*$fh}{-pid};
  108. }
  109.  
  110. sub command
  111. {
  112.  my $fh  = shift;
  113.  my $cmd = ${*$fh}{'-exec'};
  114.  return (wantarray) ? @$cmd : $cmd;
  115. }
  116.  
  117. sub exec
  118. {
  119.  my $fh  = shift;
  120.  my $pid = open($fh,'-|');
  121.  if ($pid)
  122.   {
  123.    ${*$fh} = '' unless (defined ${*$fh});
  124.    ${*$fh}{'-exec'} = [@_];
  125.    ${*$fh}{'-pid'}  = $pid;
  126.    if (exists ${*$fh}{-linecommand})
  127.     {
  128.      my $w = ${*$fh}{-widget};
  129.      $w = 'Tk' unless (defined $w);
  130.      $w->fileevent($fh,'readable',[$fh,'readable']);
  131.      ${*$fh}{_readable} = $w;
  132.     }
  133.    else
  134.     {
  135.      croak Tk::Pretty::Pretty(\%{*$fh});
  136.     }
  137.    return $pid;
  138.   }
  139.  else
  140.   {
  141.    # make STDERR same as STDOUT here
  142.    setpgrp;
  143.    exec(@_) || die 'Cannot exec ',join(' ',@_),":$!";
  144.   }
  145. }
  146.  
  147. sub wait
  148. {
  149.  my $fh = shift;
  150.  my $code;
  151.  my $ch = delete ${*$fh}{-childcommand};
  152.  ${*$fh}{-childcommand} = Tk::Callback->new(sub { $code = shift });
  153.  Tk::Event::DoOneEvent(0) until (defined $code);
  154.  if (defined $ch)
  155.   {
  156.    ${*$fh}{-childcommand} = $ch;
  157.    $ch->Call($code,$fh)
  158.   }
  159.  return $code;
  160. }
  161.  
  162. sub close
  163. {
  164.  my $fh = shift;
  165.  my $code;
  166.  if (defined fileno($fh))
  167.   {
  168.    my $w = delete ${*$fh}{_readable};
  169.    $w->fileevent($fh,'readable','') if (defined $w);
  170.    $code = close($fh);
  171.    if (exists ${*$fh}{-childcommand})
  172.     {
  173.      ${*$fh}{-childcommand}->Call($?,$fh);
  174.     }
  175.   }
  176.  return $code;
  177. }
  178.  
  179. 1;
  180. __END__
  181.  
  182.  
  183.