Coro/Coro/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.13;

@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(${+shift})->FILENO }
sub close  { tied(${+shift})->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(${+shift});
   if (@_) {
      $self->{timeout} = $_[0];
      $self->{rw}->timeout($_[0]) if $self->{rw};
      $self->{ww}->timeout($_[0]) if $self->{ww};
   }
   $self->{timeout};
}

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->got & W;
}

sub readable {
   ($_[0]->{rw} ||= Coro::Event->io(
      fd      => $_[0]->{fh},
      desc    => "$_[0]->{desc} RW",
      timeout => $_[0]->{timeout},
      poll    => R+E,
   ))->next->got & 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.10
Committed:	Fri Aug 10 21:03:40 2001 UTC (22 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.9:	+7 -7 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	root	1.5	use base 'Exporter';
23	root	1.1
24	root	1.5	$VERSION = 0.13;
25
26			@EXPORT = qw(unblock);
27	root	1.1
28	root	1.6	=item $fh = new_from_fh Coro::Handle $fhandle [, arg => value...]
29	root	1.1
30			Create a new non-blocking io-handle using the given
31	root	1.6	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	root	1.1
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	root	1.6	my ($package, $filename, $line) = caller;
42			$filename =~ s/^.*[\/\\]//;
43
44			tie $self, Coro::Handle::FH, fh => $fh, desc => "$filename:$line", @_;
45	root	1.1
46			my $_fh = select bless \$self, $class; $\| = 1; select $_fh;
47			}
48
49	root	1.5	=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	root	1.1	=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	root	1.4	=item $fh->readline([$terminator])
76
77			Like the builtin of the same name, but allows you to specify the input
78	root	1.7	record separator in a coroutine-safe manner (i.e. not using a global
79	root	1.4	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	root	1.8	only). Might change in the future.
89	root	1.4
90			=cut
91
92			sub autoflush { !0 }
93
94	root	1.10	=item $fh->fileno, $fh->close
95	root	1.8
96	root	1.10	Work like their function equivalents.
97	root	1.8
98			=cut
99
100	root	1.10	sub fileno { tied(${+shift})->FILENO }
101			sub close { tied(${+shift})->CLOSE }
102	root	1.8
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			my $self = tied(${+shift});
114			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			}
121
122	root	1.1	package Coro::Handle::FH;
123
124			use Fcntl ();
125			use Errno ();
126	root	1.10	use Carp 'croak';
127	root	1.1
128			use Coro::Event;
129			use Event::Watcher qw(R W E);
130
131			use base 'Tie::Handle';
132
133			sub TIEHANDLE {
134	root	1.6	my $class = shift;
135	root	1.1
136	root	1.6	my $self = bless {
137	root	1.1	rb => "",
138			wb => "",
139	root	1.6	@_,
140			}, $class;
141	root	1.1
142	root	1.6	fcntl $self->{fh}, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
143	root	1.10	or croak "fcntl(O_NONBLOCK): $!";
144	root	1.6
145			$self;
146	root	1.1	}
147
148			sub OPEN {
149			my $self = shift;
150			$self->CLOSE;
151			my $r = @_ == 2 ? open $self->{fh}, $_[0], $_[1]
152			: open $self->{fh}, $_[0], $_[1], $_[2];
153			if ($r) {
154			fcntl $self->{fh}, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
155	root	1.10	or croak "fcntl(O_NONBLOCK): $!";
156	root	1.1	}
157			$r;
158			}
159
160			sub CLOSE {
161			my $self = shift;
162			$self->{rb} =
163			$self->{wb} = "";
164	root	1.9	(delete $self->{rw})->cancel if exists $self->{rw};
165			(delete $self->{ww})->cancel if exists $self->{ww};
166	root	1.1	close $self->{fh};
167	root	1.8	}
168
169			sub FILENO {
170			fileno $_[0]->{fh};
171	root	1.1	}
172
173			sub writable {
174	root	1.6	($_[0]->{ww} \|\|= Coro::Event->io(
175			fd => $_[0]->{fh},
176			desc => "$_[0]->{desc} WW",
177			timeout => $_[0]->{timeout},
178			poll => W+E,
179			))->next->got & W;
180	root	1.1	}
181
182			sub readable {
183	root	1.6	($_[0]->{rw} \|\|= Coro::Event->io(
184			fd => $_[0]->{fh},
185			desc => "$_[0]->{desc} RW",
186			timeout => $_[0]->{timeout},
187			poll => R+E,
188			))->next->got & R;
189	root	1.1	}
190
191			sub WRITE {
192			my $self = $_[0];
193			my $len = defined $_[2] ? $_[2] : length $_[1];
194			my $ofs = $_[3];
195			my $res = 0;
196
197	root	1.2	while() {
198	root	1.1	my $r = syswrite $self->{fh}, $_[1], $len, $ofs;
199			if (defined $r) {
200			$len -= $r;
201			$ofs += $r;
202			$res += $r;
203			last unless $len;
204			} elsif ($! != Errno::EAGAIN) {
205			last;
206			}
207	root	1.2	last unless $self->writable;
208	root	1.1	}
209
210			return $res;
211			}
212
213			sub READ {
214			my $self = $_[0];
215			my $len = $_[2];
216			my $ofs = $_[3];
217			my $res = 0;
218
219	root	1.7	# first deplete the read buffer
220			if (exists $self->{rb}) {
221			my $l = length $self->{rb};
222			if ($l <= $len) {
223			substr($_[1], $ofs) = delete $self->{rb};
224			$len -= $l;
225			$res += $l;
226			return $res unless $len;
227			} else {
228			substr($_[1], $ofs) = substr($self->{rb}, 0, $len);
229			substr($self->{rb}, 0, $len) = "";
230			return $len;
231			}
232			}
233
234	root	1.2	while() {
235	root	1.1	my $r = sysread $self->{fh}, $_[1], $len, $ofs;
236			if (defined $r) {
237			$len -= $r;
238			$ofs += $r;
239			$res += $r;
240			last unless $len && $r;
241			} elsif ($! != Errno::EAGAIN) {
242			last;
243			}
244	root	1.2	last unless $self->readable;
245	root	1.1	}
246
247			return $res;
248			}
249
250			sub READLINE {
251			my $self = shift;
252	root	1.4	my $irs = @_ ? shift : $/;
253	root	1.1
254			while() {
255	root	1.4	my $pos = index $self->{rb}, $irs;
256	root	1.1	if ($pos >= 0) {
257	root	1.7	$pos += length $irs;
258	root	1.1	my $res = substr $self->{rb}, 0, $pos;
259			substr ($self->{rb}, 0, $pos) = "";
260			return $res;
261			}
262			my $r = sysread $self->{fh}, $self->{rb}, 8192, length $self->{rb};
263			if (defined $r) {
264			return undef unless $r;
265	root	1.2	} elsif ($! != Errno::EAGAIN \|\| !$self->readable) {
266	root	1.1	return undef;
267			}
268			}
269	root	1.6	}
270
271			sub DESTROY {
272			&CLOSE;
273	root	1.1	}
274
275			1;
276
277			=head1 BUGS
278
279			- Perl's IO-Handle model is THE bug.
280
281			=head1 AUTHOR
282
283			Marc Lehmann <pcg@goof.com>
284			http://www.goof.com/pcg/marc/
285
286			=cut
287