1 |
|
---|
2 | # IO::Poll.pm
|
---|
3 | #
|
---|
4 | # Copyright (c) 1997-8 Graham Barr <[email protected]>. All rights reserved.
|
---|
5 | # This program is free software; you can redistribute it and/or
|
---|
6 | # modify it under the same terms as Perl itself.
|
---|
7 |
|
---|
8 | package IO::Poll;
|
---|
9 |
|
---|
10 | use strict;
|
---|
11 | use IO::Handle;
|
---|
12 | use Exporter ();
|
---|
13 | our(@ISA, @EXPORT_OK, @EXPORT, $VERSION);
|
---|
14 |
|
---|
15 | @ISA = qw(Exporter);
|
---|
16 | $VERSION = "0.07";
|
---|
17 |
|
---|
18 | @EXPORT = qw( POLLIN
|
---|
19 | POLLOUT
|
---|
20 | POLLERR
|
---|
21 | POLLHUP
|
---|
22 | POLLNVAL
|
---|
23 | );
|
---|
24 |
|
---|
25 | @EXPORT_OK = qw(
|
---|
26 | POLLPRI
|
---|
27 | POLLRDNORM
|
---|
28 | POLLWRNORM
|
---|
29 | POLLRDBAND
|
---|
30 | POLLWRBAND
|
---|
31 | POLLNORM
|
---|
32 | );
|
---|
33 |
|
---|
34 | # [0] maps fd's to requested masks
|
---|
35 | # [1] maps fd's to returned masks
|
---|
36 | # [2] maps fd's to handles
|
---|
37 | sub new {
|
---|
38 | my $class = shift;
|
---|
39 |
|
---|
40 | my $self = bless [{},{},{}], $class;
|
---|
41 |
|
---|
42 | $self;
|
---|
43 | }
|
---|
44 |
|
---|
45 | sub mask {
|
---|
46 | my $self = shift;
|
---|
47 | my $io = shift;
|
---|
48 | my $fd = fileno($io);
|
---|
49 | return unless defined $fd;
|
---|
50 | if (@_) {
|
---|
51 | my $mask = shift;
|
---|
52 | if($mask) {
|
---|
53 | $self->[0]{$fd}{$io} = $mask; # the error events are always returned
|
---|
54 | $self->[1]{$fd} = 0; # output mask
|
---|
55 | $self->[2]{$io} = $io; # remember handle
|
---|
56 | } else {
|
---|
57 | delete $self->[0]{$fd}{$io};
|
---|
58 | unless(%{$self->[0]{$fd}}) {
|
---|
59 | # We no longer have any handles for this FD
|
---|
60 | delete $self->[1]{$fd};
|
---|
61 | delete $self->[0]{$fd};
|
---|
62 | }
|
---|
63 | delete $self->[2]{$io};
|
---|
64 | }
|
---|
65 | }
|
---|
66 |
|
---|
67 | return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io};
|
---|
68 | return $self->[0]{$fd}{$io};
|
---|
69 | }
|
---|
70 |
|
---|
71 |
|
---|
72 | sub poll {
|
---|
73 | my($self,$timeout) = @_;
|
---|
74 |
|
---|
75 | $self->[1] = {};
|
---|
76 |
|
---|
77 | my($fd,$mask,$iom);
|
---|
78 | my @poll = ();
|
---|
79 |
|
---|
80 | while(($fd,$iom) = each %{$self->[0]}) {
|
---|
81 | $mask = 0;
|
---|
82 | $mask |= $_ for values(%$iom);
|
---|
83 | push(@poll,$fd => $mask);
|
---|
84 | }
|
---|
85 |
|
---|
86 | my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0;
|
---|
87 |
|
---|
88 | return $ret
|
---|
89 | unless $ret > 0;
|
---|
90 |
|
---|
91 | while(@poll) {
|
---|
92 | my($fd,$got) = splice(@poll,0,2);
|
---|
93 | $self->[1]{$fd} = $got if $got;
|
---|
94 | }
|
---|
95 |
|
---|
96 | return $ret;
|
---|
97 | }
|
---|
98 |
|
---|
99 | sub events {
|
---|
100 | my $self = shift;
|
---|
101 | my $io = shift;
|
---|
102 | my $fd = fileno($io);
|
---|
103 | exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io}
|
---|
104 | ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL)
|
---|
105 | : 0;
|
---|
106 | }
|
---|
107 |
|
---|
108 | sub remove {
|
---|
109 | my $self = shift;
|
---|
110 | my $io = shift;
|
---|
111 | $self->mask($io,0);
|
---|
112 | }
|
---|
113 |
|
---|
114 | sub handles {
|
---|
115 | my $self = shift;
|
---|
116 | return values %{$self->[2]} unless @_;
|
---|
117 |
|
---|
118 | my $events = shift || 0;
|
---|
119 | my($fd,$ev,$io,$mask);
|
---|
120 | my @handles = ();
|
---|
121 |
|
---|
122 | while(($fd,$ev) = each %{$self->[1]}) {
|
---|
123 | while (($io,$mask) = each %{$self->[0]{$fd}}) {
|
---|
124 | $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these
|
---|
125 | push @handles,$self->[2]{$io} if ($ev & $mask) & $events;
|
---|
126 | }
|
---|
127 | }
|
---|
128 | return @handles;
|
---|
129 | }
|
---|
130 |
|
---|
131 | 1;
|
---|
132 |
|
---|
133 | __END__
|
---|
134 |
|
---|
135 | =head1 NAME
|
---|
136 |
|
---|
137 | IO::Poll - Object interface to system poll call
|
---|
138 |
|
---|
139 | =head1 SYNOPSIS
|
---|
140 |
|
---|
141 | use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP);
|
---|
142 |
|
---|
143 | $poll = new IO::Poll;
|
---|
144 |
|
---|
145 | $poll->mask($input_handle => POLLIN);
|
---|
146 | $poll->mask($output_handle => POLLOUT);
|
---|
147 |
|
---|
148 | $poll->poll($timeout);
|
---|
149 |
|
---|
150 | $ev = $poll->events($input);
|
---|
151 |
|
---|
152 | =head1 DESCRIPTION
|
---|
153 |
|
---|
154 | C<IO::Poll> is a simple interface to the system level poll routine.
|
---|
155 |
|
---|
156 | =head1 METHODS
|
---|
157 |
|
---|
158 | =over 4
|
---|
159 |
|
---|
160 | =item mask ( IO [, EVENT_MASK ] )
|
---|
161 |
|
---|
162 | If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the
|
---|
163 | list of file descriptors and the next call to poll will check for
|
---|
164 | any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be
|
---|
165 | removed from the list of file descriptors.
|
---|
166 |
|
---|
167 | If EVENT_MASK is not given then the return value will be the current
|
---|
168 | event mask value for IO.
|
---|
169 |
|
---|
170 | =item poll ( [ TIMEOUT ] )
|
---|
171 |
|
---|
172 | Call the system level poll routine. If TIMEOUT is not specified then the
|
---|
173 | call will block. Returns the number of handles which had events
|
---|
174 | happen, or -1 on error.
|
---|
175 |
|
---|
176 | =item events ( IO )
|
---|
177 |
|
---|
178 | Returns the event mask which represents the events that happened on IO
|
---|
179 | during the last call to C<poll>.
|
---|
180 |
|
---|
181 | =item remove ( IO )
|
---|
182 |
|
---|
183 | Remove IO from the list of file descriptors for the next poll.
|
---|
184 |
|
---|
185 | =item handles( [ EVENT_MASK ] )
|
---|
186 |
|
---|
187 | Returns a list of handles. If EVENT_MASK is not given then a list of all
|
---|
188 | handles known will be returned. If EVENT_MASK is given then a list
|
---|
189 | of handles will be returned which had one of the events specified by
|
---|
190 | EVENT_MASK happen during the last call ti C<poll>
|
---|
191 |
|
---|
192 | =back
|
---|
193 |
|
---|
194 | =head1 SEE ALSO
|
---|
195 |
|
---|
196 | L<poll(2)>, L<IO::Handle>, L<IO::Select>
|
---|
197 |
|
---|
198 | =head1 AUTHOR
|
---|
199 |
|
---|
200 | Graham Barr. Currently maintained by the Perl Porters. Please report all
|
---|
201 | bugs to <[email protected]>.
|
---|
202 |
|
---|
203 | =head1 COPYRIGHT
|
---|
204 |
|
---|
205 | Copyright (c) 1997-8 Graham Barr <[email protected]>. All rights reserved.
|
---|
206 | This program is free software; you can redistribute it and/or
|
---|
207 | modify it under the same terms as Perl itself.
|
---|
208 |
|
---|
209 | =cut
|
---|