Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::IO; |
2 | use strict; | |
3 | use vars qw($VERSION); | |
4 | $VERSION = '3.038'; # $Id: //depot/Tk8/IO/IO.pm#38 $ | |
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 |