diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:51:27 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:51:27 +0000 |
commit | b645030efc22e13c2498a1522083634ab91b2de1 (patch) | |
tree | c75c7a71998200d419af56eb755dac2f5115b585 /Master/tlpkg/tlperl/lib/Tk/IO.pm | |
parent | 44ccd4efc5352f9eb1099ba357708e7b5ff03b83 (diff) |
move tlperl to tlperl.old
git-svn-id: svn://tug.org/texlive/trunk@18209 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/IO.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/IO.pm | 182 |
1 files changed, 0 insertions, 182 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/IO.pm b/Master/tlpkg/tlperl/lib/Tk/IO.pm deleted file mode 100644 index 771e9f7103a..00000000000 --- a/Master/tlpkg/tlperl/lib/Tk/IO.pm +++ /dev/null @@ -1,182 +0,0 @@ -package Tk::IO; -use strict; -use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/IO/IO.pm#4 $ - -require 5.002; -use Tk::Event qw($XS_VERSION); - -use Carp; -use base qw(DynaLoader IO::Handle); - -bootstrap Tk::IO; - -my %fh2obj; -my %obj2fh; - -sub new -{ - my ($package,%args) = @_; - # Do whatever IO::Handle does - my $fh = $package->SUPER::new; - %{*$fh} = (); # The hash is used for configure options - ${*$fh} = ''; # The scalar is used as the 'readable' buffer - @{*$fh} = (); # The array - $fh->configure(%args); - return $fh; -} - -sub pending -{ - my $fh = shift; - return ${*$fh}; -} - -sub cget -{ - my ($fh,$key) = @_; - return ${*$fh}{$key}; -} - -sub configure -{ - my ($fh,%args) = @_; - my $key; - foreach $key (keys %args) - { - my $val = $args{$key}; - $val = Tk::Callback->new($val) if ($key =~ /command$/); - ${*$fh}{$key} = $val; - } -} - -sub killpg -{ - my ($fh,$sig) = @_; - my $pid = $fh->pid; - croak 'No child' unless (defined $pid); - kill($sig,-$pid); -} - -sub kill -{ - my ($fh,$sig) = @_; - my $pid = $fh->pid; - croak 'No child' unless (defined $pid); - kill($sig,$pid) || croak "Cannot kill($sig,$pid):$!"; -} - -sub readable -{ - my $fh = shift; - my $count = sysread($fh,${*$fh},1,length(${*$fh})); - if ($count < 0) - { - if (exists ${*$fh}{-errorcommand}) - { - ${*$fh}{-errorcommand}->Call($!); - } - else - { - warn "Cannot read $fh:$!"; - $fh->close; - } - } - elsif ($count) - { - if (exists ${*$fh}{-linecommand}) - { - my $eol = index(${*$fh},"\n"); - if ($eol >= 0) - { - my $line = substr(${*$fh},0,++$eol); - substr(${*$fh},0,$eol) = ''; - ${*$fh}{-linecommand}->Call($line); - } - } - } - else - { - $fh->close; - } -} - -sub pid -{ - my $fh = shift; - return ${*$fh}{-pid}; -} - -sub command -{ - my $fh = shift; - my $cmd = ${*$fh}{'-exec'}; - return (wantarray) ? @$cmd : $cmd; -} - -sub exec -{ - my $fh = shift; - my $pid = open($fh,'-|'); - if ($pid) - { - ${*$fh} = '' unless (defined ${*$fh}); - ${*$fh}{'-exec'} = [@_]; - ${*$fh}{'-pid'} = $pid; - if (exists ${*$fh}{-linecommand}) - { - my $w = ${*$fh}{-widget}; - $w = 'Tk' unless (defined $w); - $w->fileevent($fh,'readable',[$fh,'readable']); - ${*$fh}{_readable} = $w; - } - else - { - croak Tk::Pretty::Pretty(\%{*$fh}); - } - return $pid; - } - else - { - # make STDERR same as STDOUT here - setpgrp; - exec(@_) || die 'Cannot exec ',join(' ',@_),":$!"; - } -} - -sub wait -{ - my $fh = shift; - my $code; - my $ch = delete ${*$fh}{-childcommand}; - ${*$fh}{-childcommand} = Tk::Callback->new(sub { $code = shift }); - Tk::Event::DoOneEvent(0) until (defined $code); - if (defined $ch) - { - ${*$fh}{-childcommand} = $ch; - $ch->Call($code,$fh) - } - return $code; -} - -sub close -{ - my $fh = shift; - my $code; - if (defined fileno($fh)) - { - my $w = delete ${*$fh}{_readable}; - $w->fileevent($fh,'readable','') if (defined $w); - $code = close($fh); - if (exists ${*$fh}{-childcommand}) - { - ${*$fh}{-childcommand}->Call($?,$fh); - } - } - return $code; -} - -1; -__END__ - - |