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 ();

$VERSION = 0.10;

=item $fh = new_from_fh Coro::Handle $fhandle

Create a new non-blocking io-handle using the given
perl-filehandle. Returns undef if no fhandle is given.

=cut

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

   tie $self, Coro::Handle::FH, $fh;

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

=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 }

package Coro::Handle::FH;

use Fcntl ();
use Errno ();

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

use base 'Tie::Handle';

sub TIEHANDLE {
   my ($class, $fh) = @_;

   fcntl $fh, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
      or die "fcntl(O_NONBLOCK): $!";

   bless {
      fh => $fh,
      rb => "",
      wb => "",
   }, $_[0];

}

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 die "fcntl(O_NONBLOCK): $!";
   }
   $r;
}

sub CLOSE {
   my $self = shift;
   $self->{rb} =
   $self->{wb} = "";
   delete $self->{w};
   delete $self->{rw};
   delete $self->{ww};
   close $self->{fh};
}

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

sub readable {
   ($_[0]->{rw} ||= Coro::Event->io(fd => $_[0]->{fh}, 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;

   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;

   while() {
      my $pos = index $self->{rb}, $/;
      if ($pos >= 0) {
         $pos += length $/;
         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;
      }
   }
}

1;

=head1 BUGS

 - Perl's IO-Handle model is THE bug.
 - READLINE cannot be mixed with other forms of input.

=head1 AUTHOR

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

=cut

Revision:	1.2
Committed:	Tue Jul 24 20:18:12 2001 UTC (22 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.1:	+5 -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
23			$VERSION = 0.10;
24
25			=item $fh = new_from_fh Coro::Handle $fhandle
26
27			Create a new non-blocking io-handle using the given
28			perl-filehandle. Returns undef if no fhandle is given.
29
30			=cut
31
32			sub new_from_fh {
33			my $class = shift;
34			my $fh = shift or return;
35			my $self = do { local *Coro::Handle };
36
37			tie $self, Coro::Handle::FH, $fh;
38
39			my $_fh = select bless \$self, $class; $\| = 1; select $_fh;
40			}
41
42			=item $fh->writable, $fh->readable
43
44			Wait until the filehandle is readable or writable (and return true) or
45			until an error condition happens (and return false).
46
47			=cut
48
49			sub readable { tied(${$_[0]})->readable }
50			sub writable { tied(${$_[0]})->writable }
51
52			package Coro::Handle::FH;
53
54			use Fcntl ();
55			use Errno ();
56
57			use Coro::Event;
58			use Event::Watcher qw(R W E);
59
60			use base 'Tie::Handle';
61
62			sub TIEHANDLE {
63			my ($class, $fh) = @_;
64
65			fcntl $fh, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
66			or die "fcntl(O_NONBLOCK): $!";
67
68			bless {
69			fh => $fh,
70			rb => "",
71			wb => "",
72			}, $_[0];
73
74			}
75
76			sub OPEN {
77			my $self = shift;
78			$self->CLOSE;
79			my $r = @_ == 2 ? open $self->{fh}, $_[0], $_[1]
80			: open $self->{fh}, $_[0], $_[1], $_[2];
81			if ($r) {
82			fcntl $self->{fh}, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK
83			or die "fcntl(O_NONBLOCK): $!";
84			}
85			$r;
86			}
87
88			sub CLOSE {
89			my $self = shift;
90			$self->{rb} =
91			$self->{wb} = "";
92			delete $self->{w};
93			delete $self->{rw};
94			delete $self->{ww};
95			close $self->{fh};
96			}
97
98			sub writable {
99			($_[0]->{ww} \|\|= Coro::Event->io(fd => $_[0]->{fh}, poll => W+E))->next->got & W;
100			}
101
102			sub readable {
103			($_[0]->{rw} \|\|= Coro::Event->io(fd => $_[0]->{fh}, poll => R+E))->next->got & R;
104			}
105
106			sub WRITE {
107			my $self = $_[0];
108			my $len = defined $_[2] ? $_[2] : length $_[1];
109			my $ofs = $_[3];
110			my $res = 0;
111
112	root	1.2	while() {
113	root	1.1	my $r = syswrite $self->{fh}, $_[1], $len, $ofs;
114			if (defined $r) {
115			$len -= $r;
116			$ofs += $r;
117			$res += $r;
118			last unless $len;
119			} elsif ($! != Errno::EAGAIN) {
120			last;
121			}
122	root	1.2	last unless $self->writable;
123	root	1.1	}
124
125			return $res;
126			}
127
128			sub READ {
129			my $self = $_[0];
130			my $len = $_[2];
131			my $ofs = $_[3];
132			my $res = 0;
133
134	root	1.2	while() {
135	root	1.1	my $r = sysread $self->{fh}, $_[1], $len, $ofs;
136			if (defined $r) {
137			$len -= $r;
138			$ofs += $r;
139			$res += $r;
140			last unless $len && $r;
141			} elsif ($! != Errno::EAGAIN) {
142			last;
143			}
144	root	1.2	last unless $self->readable;
145	root	1.1	}
146
147			return $res;
148			}
149
150			sub READLINE {
151			my $self = shift;
152
153			while() {
154			my $pos = index $self->{rb}, $/;
155			if ($pos >= 0) {
156			$pos += length $/;
157			my $res = substr $self->{rb}, 0, $pos;
158			substr ($self->{rb}, 0, $pos) = "";
159			return $res;
160			}
161			my $r = sysread $self->{fh}, $self->{rb}, 8192, length $self->{rb};
162			if (defined $r) {
163			return undef unless $r;
164	root	1.2	} elsif ($! != Errno::EAGAIN \|\| !$self->readable) {
165	root	1.1	return undef;
166			}
167			}
168			}
169
170			1;
171
172			=head1 BUGS
173
174			- Perl's IO-Handle model is THE bug.
175			- READLINE cannot be mixed with other forms of input.
176
177			=head1 AUTHOR
178
179			Marc Lehmann <pcg@goof.com>
180			http://www.goof.com/pcg/marc/
181
182			=cut
183