Coro/Event/Handle.pm

=head1 NAME

Coro::Handle - non-blocking io with a blocking interface.

=head1 SYNOPSIS

 use Coro::Handle;

=head1 DESCRIPTION

This module implements io-handles in a coroutine-compatible way, that is,
other coroutines can run while reads or writes block on the handle. It
does NOT inherit from IO::Handle but uses tied objects.

=over 4

=cut

package Coro::Handle;

use Errno ();
use base 'Exporter';

$VERSION = 0.45;

@EXPORT = qw(unblock);

=item $fh = new_from_fh Coro::Handle $fhandle [, arg => value...]

Create a new non-blocking io-handle using the given
perl-filehandle. Returns undef if no fhandle is given. The only other
supported argument is "timeout", which sets a timeout for each operation.

=cut

sub new_from_fh {
   my $class = shift;
   my $fh = shift or return;
   my $self = do { local *Coro::Handle };

   my ($package, $filename, $line) = caller;
   $filename =~ s/^.*[\/\\]//;

   tie $self, Coro::Handle::FH, fh => $fh, desc => "$filename:$line", @_;

   my $_fh = select bless \$self, $class; $| = 1; select $_fh;
}

=item $fh = unblock $fh

This is a convinience function that just calls C<new_from_fh> on the given
filehandle. Use it to replace a normal perl filehandle by a non-blocking
equivalent.

=cut

sub unblock($) {
   new_from_fh Coro::Handle $_[0];
}

sub read        { read     $_[0], $_[1], $_[2], $_[3] }
sub sysread     { sysread  $_[0], $_[1], $_[2], $_[3] }
sub syswrite    { syswrite $_[0], $_[1], $_[2], $_[3] }

=item $fh->writable, $fh->readable

Wait until the filehandle is readable or writable (and return true) or
until an error condition happens (and return false).

=cut

sub readable    { tied(${$_[0]})->readable }
sub writable    { tied(${$_[0]})->writable }

=item $fh->readline([$terminator])

Like the builtin of the same name, but allows you to specify the input
record separator in a coroutine-safe manner (i.e. not using a global
variable).

=cut

sub readline    { tied(${+shift})->READLINE(@_) }

=item $fh->autoflush([...])

Always returns true, arguments are being ignored (exists for compatibility
only). Might change in the future.

=cut

sub autoflush   { !0 }

=item $fh->fileno, $fh->close

Work like their function equivalents.

=cut

sub fileno { tied(${$_[0]})->FILENO }
sub close  { tied(${$_[0]})->CLOSE  }

=item $fh->timeout([...])

The optional agrument sets the new timeout (in seconds) for this
handle. Returns the current (new) value.

C<0> is a valid timeout, use C<undef> to disable the timeout.

=cut

sub timeout {
   my $self = tied(${$_[0]});
   if (@_) {
      $self->{timeout} = $_[0];
      $self->{rw}->timeout($_[0]) if $self->{rw};
      $self->{ww}->timeout($_[0]) if $self->{ww};
   }
   $self->{timeout};
}

=item $fh->fh

Returns the "real" (non-blocking) filehandle. Use this if you want to
do operations on the file handle you cannot do using the Coro::Handle
interface.

=cut

sub fh {
   tied(${$_[0]})->{fh};
}

package Coro::Handle::FH;

use Fcntl ();
use Errno ();
use Carp 'croak';

use Coro::Event;
use Event::Watcher qw(R W E);

use base 'Tie::Handle';

sub TIEHANDLE {
   my $class = shift;

   my $self = bless {
      rb => "",
      wb => "",
      @_,
   }, $class;

   fcntl $self->{fh}, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
      or croak "fcntl(O_NONBLOCK): $!";

   $self;
}

sub OPEN {
   my $self = shift;
   $self->CLOSE;
   my $r = @_ == 2 ? open $self->{fh}, $_[0], $_[1]
                   : open $self->{fh}, $_[0], $_[1], $_[2];
   if ($r) {
      fcntl $self->{fh}, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
         or croak "fcntl(O_NONBLOCK): $!";
   }
   $r;
}

sub CLOSE {
   my $self = shift;
   $self->{rb} =
   $self->{wb} = "";
   (delete $self->{rw})->cancel if exists $self->{rw};
   (delete $self->{ww})->cancel if exists $self->{ww};
   close $self->{fh};
}

sub FILENO {
   fileno $_[0]->{fh};
}

sub writable {
   ($_[0]->{ww} ||= Coro::Event->io(
      fd      => $_[0]->{fh},
      desc    => "$_[0]->{desc} WW",
      timeout => $_[0]->{timeout},
      poll    => W+E,
   ))->next->{Coro::Event}[5] & W;
}

sub readable {
   ($_[0]->{rw} ||= Coro::Event->io(
      fd      => $_[0]->{fh},
      desc    => "$_[0]->{desc} RW",
      timeout => $_[0]->{timeout},
      poll    => R+E,
   ))->next->{Coro::Event}[5] & R;
}

sub WRITE {
   my $self = $_[0];
   my $len = defined $_[2] ? $_[2] : length $_[1];
   my $ofs = $_[3];
   my $res = 0;

   while() {
      my $r = syswrite $self->{fh}, $_[1], $len, $ofs;
      if (defined $r) {
         $len -= $r;
         $ofs += $r;
         $res += $r;
         last unless $len;
      } elsif ($! != Errno::EAGAIN) {
         last;
      }
      last unless $self->writable;
   }

   return $res;
}

sub READ {
   my $self = $_[0];
   my $len = $_[2];
   my $ofs = $_[3];
   my $res = 0;

   # first deplete the read buffer
   if (exists $self->{rb}) {
      my $l = length $self->{rb};
      if ($l <= $len) {
         substr($_[1], $ofs) = delete $self->{rb};
         $len -= $l;
         $res += $l;
         return $res unless $len;
      } else {
         substr($_[1], $ofs) = substr($self->{rb}, 0, $len);
         substr($self->{rb}, 0, $len) = "";
         return $len;
      }
   }

   while() {
      my $r = sysread $self->{fh}, $_[1], $len, $ofs;
      if (defined $r) {
         $len -= $r;
         $ofs += $r;
         $res += $r;
         last unless $len && $r;
      } elsif ($! != Errno::EAGAIN) {
         last;
      }
      last unless $self->readable;
   }

   return $res;
}

sub READLINE {
   my $self = shift;
   my $irs = @_ ? shift : $/;

   while() {
      my $pos = index $self->{rb}, $irs;
      if ($pos >= 0) {
         $pos += length $irs;
         my $res = substr $self->{rb}, 0, $pos;
         substr ($self->{rb}, 0, $pos) = "";
         return $res;
      }
      my $r = sysread $self->{fh}, $self->{rb}, 8192, length $self->{rb};
      if (defined $r) {
         return undef unless $r;
      } elsif ($! != Errno::EAGAIN || !$self->readable) {
         return undef;
      }
   }
}

sub DESTROY {
   &CLOSE;
}

1;

=head1 BUGS

 - Perl's IO-Handle model is THE bug.

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://www.goof.com/pcg/marc/

=cut

Revision:	1.4
Committed:	Sun Sep 2 00:54:00 2001 UTC (22 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.3:	+15 -3 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Coro::Handle - non-blocking io with a blocking interface.
4
5			=head1 SYNOPSIS
6
7			use Coro::Handle;
8
9			=head1 DESCRIPTION
10
11			This module implements io-handles in a coroutine-compatible way, that is,
12			other coroutines can run while reads or writes block on the handle. It
13			does NOT inherit from IO::Handle but uses tied objects.
14
15			=over 4
16
17			=cut
18
19			package Coro::Handle;
20
21			use Errno ();
22			use base 'Exporter';
23
24			$VERSION = 0.45;
25
26			@EXPORT = qw(unblock);
27
28			=item $fh = new_from_fh Coro::Handle $fhandle [, arg => value...]
29
30			Create a new non-blocking io-handle using the given
31			perl-filehandle. Returns undef if no fhandle is given. The only other
32			supported argument is "timeout", which sets a timeout for each operation.
33
34			=cut
35
36			sub new_from_fh {
37			my $class = shift;
38			my $fh = shift or return;
39			my $self = do { local *Coro::Handle };
40
41			my ($package, $filename, $line) = caller;
42			$filename =~ s/^.*[\/\\]//;
43
44			tie $self, Coro::Handle::FH, fh => $fh, desc => "$filename:$line", @_;
45
46			my $_fh = select bless \$self, $class; $\| = 1; select $_fh;
47			}
48
49			=item $fh = unblock $fh
50
51			This is a convinience function that just calls C<new_from_fh> on the given
52			filehandle. Use it to replace a normal perl filehandle by a non-blocking
53			equivalent.
54
55			=cut
56
57			sub unblock($) {
58			new_from_fh Coro::Handle $_[0];
59			}
60
61			sub read { read $_[0], $_[1], $_[2], $_[3] }
62			sub sysread { sysread $_[0], $_[1], $_[2], $_[3] }
63			sub syswrite { syswrite $_[0], $_[1], $_[2], $_[3] }
64
65			=item $fh->writable, $fh->readable
66
67			Wait until the filehandle is readable or writable (and return true) or
68			until an error condition happens (and return false).
69
70			=cut
71
72			sub readable { tied(${$_[0]})->readable }
73			sub writable { tied(${$_[0]})->writable }
74
75			=item $fh->readline([$terminator])
76
77			Like the builtin of the same name, but allows you to specify the input
78			record separator in a coroutine-safe manner (i.e. not using a global
79			variable).
80
81			=cut
82
83			sub readline { tied(${+shift})->READLINE(@_) }
84
85			=item $fh->autoflush([...])
86
87			Always returns true, arguments are being ignored (exists for compatibility
88			only). Might change in the future.
89
90			=cut
91
92			sub autoflush { !0 }
93
94			=item $fh->fileno, $fh->close
95
96			Work like their function equivalents.
97
98			=cut
99
100	root	1.4	sub fileno { tied(${$_[0]})->FILENO }
101			sub close { tied(${$_[0]})->CLOSE }
102	root	1.1
103			=item $fh->timeout([...])
104
105			The optional agrument sets the new timeout (in seconds) for this
106			handle. Returns the current (new) value.
107
108			C<0> is a valid timeout, use C<undef> to disable the timeout.
109
110			=cut
111
112			sub timeout {
113	root	1.4	my $self = tied(${$_[0]});
114	root	1.1	if (@_) {
115			$self->{timeout} = $_[0];
116			$self->{rw}->timeout($_[0]) if $self->{rw};
117			$self->{ww}->timeout($_[0]) if $self->{ww};
118			}
119			$self->{timeout};
120	root	1.4	}
121
122			=item $fh->fh
123
124			Returns the "real" (non-blocking) filehandle. Use this if you want to
125			do operations on the file handle you cannot do using the Coro::Handle
126			interface.
127
128			=cut
129
130			sub fh {
131			tied(${$_[0]})->{fh};
132	root	1.1	}
133
134			package Coro::Handle::FH;
135
136			use Fcntl ();
137			use Errno ();
138			use Carp 'croak';
139
140			use Coro::Event;
141			use Event::Watcher qw(R W E);
142
143			use base 'Tie::Handle';
144
145			sub TIEHANDLE {
146			my $class = shift;
147
148			my $self = bless {
149			rb => "",
150			wb => "",
151			@_,
152			}, $class;
153
154			fcntl $self->{fh}, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
155			or croak "fcntl(O_NONBLOCK): $!";
156
157			$self;
158			}
159
160			sub OPEN {
161			my $self = shift;
162			$self->CLOSE;
163			my $r = @_ == 2 ? open $self->{fh}, $_[0], $_[1]
164			: open $self->{fh}, $_[0], $_[1], $_[2];
165			if ($r) {
166			fcntl $self->{fh}, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
167			or croak "fcntl(O_NONBLOCK): $!";
168			}
169			$r;
170			}
171
172			sub CLOSE {
173			my $self = shift;
174			$self->{rb} =
175			$self->{wb} = "";
176			(delete $self->{rw})->cancel if exists $self->{rw};
177			(delete $self->{ww})->cancel if exists $self->{ww};
178			close $self->{fh};
179			}
180
181			sub FILENO {
182			fileno $_[0]->{fh};
183			}
184
185			sub writable {
186			($_[0]->{ww} \|\|= Coro::Event->io(
187			fd => $_[0]->{fh},
188			desc => "$_[0]->{desc} WW",
189			timeout => $_[0]->{timeout},
190			poll => W+E,
191	root	1.3	))->next->{Coro::Event}[5] & W;
192	root	1.1	}
193
194			sub readable {
195			($_[0]->{rw} \|\|= Coro::Event->io(
196			fd => $_[0]->{fh},
197			desc => "$_[0]->{desc} RW",
198			timeout => $_[0]->{timeout},
199			poll => R+E,
200	root	1.3	))->next->{Coro::Event}[5] & R;
201	root	1.1	}
202
203			sub WRITE {
204			my $self = $_[0];
205			my $len = defined $_[2] ? $_[2] : length $_[1];
206			my $ofs = $_[3];
207			my $res = 0;
208
209			while() {
210			my $r = syswrite $self->{fh}, $_[1], $len, $ofs;
211			if (defined $r) {
212			$len -= $r;
213			$ofs += $r;
214			$res += $r;
215			last unless $len;
216			} elsif ($! != Errno::EAGAIN) {
217			last;
218			}
219			last unless $self->writable;
220			}
221
222			return $res;
223			}
224
225			sub READ {
226			my $self = $_[0];
227			my $len = $_[2];
228			my $ofs = $_[3];
229			my $res = 0;
230
231			# first deplete the read buffer
232			if (exists $self->{rb}) {
233			my $l = length $self->{rb};
234			if ($l <= $len) {
235			substr($_[1], $ofs) = delete $self->{rb};
236			$len -= $l;
237			$res += $l;
238			return $res unless $len;
239			} else {
240			substr($_[1], $ofs) = substr($self->{rb}, 0, $len);
241			substr($self->{rb}, 0, $len) = "";
242			return $len;
243			}
244			}
245
246			while() {
247			my $r = sysread $self->{fh}, $_[1], $len, $ofs;
248			if (defined $r) {
249			$len -= $r;
250			$ofs += $r;
251			$res += $r;
252			last unless $len && $r;
253			} elsif ($! != Errno::EAGAIN) {
254			last;
255			}
256			last unless $self->readable;
257			}
258
259			return $res;
260			}
261
262			sub READLINE {
263			my $self = shift;
264			my $irs = @_ ? shift : $/;
265
266			while() {
267			my $pos = index $self->{rb}, $irs;
268			if ($pos >= 0) {
269			$pos += length $irs;
270			my $res = substr $self->{rb}, 0, $pos;
271			substr ($self->{rb}, 0, $pos) = "";
272			return $res;
273			}
274			my $r = sysread $self->{fh}, $self->{rb}, 8192, length $self->{rb};
275			if (defined $r) {
276			return undef unless $r;
277			} elsif ($! != Errno::EAGAIN \|\| !$self->readable) {
278			return undef;
279			}
280			}
281			}
282
283			sub DESTROY {
284			&CLOSE;
285			}
286
287			1;
288
289			=head1 BUGS
290
291			- Perl's IO-Handle model is THE bug.
292
293			=head1 AUTHOR
294
295			Marc Lehmann <pcg@goof.com>
296			http://www.goof.com/pcg/marc/
297
298			=cut
299