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