├── MANIFEST ├── Changes ├── t ├── 00-use.t └── 10-basic.t ├── Makefile.PL ├── README └── lib └── POE └── Wheel └── UDP.pm /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | lib/POE/Wheel/UDP.pm 3 | Makefile.PL 4 | MANIFEST 5 | README 6 | t/00-use.t 7 | t/10-basic.t 8 | META.yml Module meta-data (added by MakeMaker) 9 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension POE::Wheel::UDP. 2 | 3 | 0.00_01 Thu May 18 15:35:58 2006 4 | - original version; created by h2xs 1.23 with options 5 | --skip-exporter -ABXn POE::Wheel::UDP 6 | 7 | -------------------------------------------------------------------------------- /t/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More tests => 3; 4 | BEGIN { use_ok('POE::Wheel::UDP') }; 5 | 6 | eval { POE::Wheel::UDP->allocate_wheel_id }; 7 | like( $@, qr/Undefined subroutine/i, "allocate_wheel_id shouldn't inherit" ); 8 | 9 | eval { POE::Wheel::UDP->free_wheel_id }; 10 | like( $@, qr/Undefined subroutine/i, "free_wheel_id shouldn't inherit" ); 11 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008008; 2 | use ExtUtils::MakeMaker; 3 | # See lib/ExtUtils/MakeMaker.pm for details of how to influence 4 | # the contents of the Makefile that is written. 5 | WriteMakefile( 6 | NAME => 'POE::Wheel::UDP', 7 | VERSION_FROM => 'lib/POE/Wheel/UDP.pm', # finds $VERSION 8 | PREREQ_PM => { 9 | 'Carp' => 0, 10 | 'Socket' => 0, 11 | 'Fcntl' => 0, 12 | 'POE' => 0, 13 | 14 | }, # e.g., Module::Name => 1.1 15 | ($] >= 5.005 ? ## Add these new keywords supported since 5.005 16 | (ABSTRACT_FROM => 'lib/POE/Wheel/UDP.pm', # retrieve abstract from module 17 | AUTHOR => 'Jonathan Steinert ') : ()), 18 | ); 19 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | POE-Wheel-UDP version 0.00_01 2 | ============================= 3 | 4 | The README is used to introduce the module and provide instructions on 5 | how to install the module, any machine dependencies it may have (for 6 | example C compilers and installed libraries) and any other information 7 | that should be provided before the module is installed. 8 | 9 | A README file is required for CPAN modules since CPAN extracts the 10 | README file from a module distribution so that people browsing the 11 | archive can use it get an idea of the modules uses. It is usually a 12 | good idea to provide version information here so that people can 13 | decide whether fixes for the module are worth downloading. 14 | 15 | INSTALLATION 16 | 17 | To install this module type the following: 18 | 19 | perl Makefile.PL 20 | make 21 | make test 22 | make install 23 | 24 | DEPENDENCIES 25 | 26 | This module requires these other modules and libraries: 27 | 28 | blah blah blah 29 | 30 | COPYRIGHT AND LICENCE 31 | 32 | Put the correct copyright and licence information here. 33 | 34 | Copyright (C) 2006 by A. U. Thor 35 | 36 | This library is free software; you can redistribute it and/or modify 37 | it under the same terms as Perl itself, either Perl version 5.8.8 or, 38 | at your option, any later version of Perl 5 you may have available. 39 | 40 | 41 | -------------------------------------------------------------------------------- /t/10-basic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Test::More tests => 100; 4 | 5 | use POE; 6 | use POE::Wheel::UDP; 7 | use POE::Filter::Stream; 8 | 9 | POE::Session->create( 10 | package_states => [ 11 | main => [ qw(_start wheel2_in sendone cleanup) ], 12 | ], 13 | ); 14 | 15 | sub _start { 16 | my ($kernel, $heap) = @_[KERNEL, HEAP]; 17 | 18 | my $wheel1 = POE::Wheel::UDP->new( 19 | LocalAddr => '127.0.0.1', 20 | LocalPort => '2456', 21 | PeerAddr => '127.0.0.1', 22 | PeerPort => '2457', 23 | Filter => POE::Filter::Stream->new(), 24 | ); 25 | 26 | my $wheel2 = POE::Wheel::UDP->new( 27 | LocalAddr => '127.0.0.1', 28 | LocalPort => '2457', 29 | PeerAddr => '127.0.0.1', 30 | PeerPort => '2456', 31 | InputEvent => 'wheel2_in', 32 | Filter => POE::Filter::Stream->new(), 33 | ); 34 | 35 | $heap->{wheel1} = $wheel1; 36 | $heap->{wheel2} = $wheel2; 37 | 38 | $kernel->yield( 'sendone', 1 ); 39 | 40 | return; 41 | } 42 | 43 | sub sendone { 44 | my ($kernel, $heap, $num) = @_[KERNEL,HEAP,ARG0]; 45 | if ($num > 100) { 46 | $kernel->delay( cleanup => 1 ); 47 | return; 48 | } 49 | 50 | my $thing = { payload => [ $num ] }; 51 | $heap->{flags}->{$num}++; 52 | $heap->{wheel1}->put( $thing ); 53 | $num++; 54 | $kernel->yield( 'sendone', $num ); 55 | } 56 | 57 | sub wheel2_in { 58 | my ($kernel, $heap, $input) = @_[KERNEL, HEAP, ARG0]; 59 | my $payload = $input->{payload}; 60 | my $flags = $heap->{flags}; 61 | 62 | foreach my $flag (@$payload) { 63 | if( exists( $flags->{$flag} )) { 64 | delete $flags->{$flag}; 65 | pass( "Got $flag" ); 66 | } 67 | else { 68 | fail( "$flag arrived without being keyed" ); 69 | } 70 | } 71 | 72 | if (keys %$flags == 0) { 73 | $kernel->delay( cleanup => 0 ); 74 | } 75 | } 76 | 77 | sub cleanup { 78 | my $heap = $_[HEAP]; 79 | my $flags = $heap->{flags}; 80 | my $wheel1 = delete $heap->{wheel1}; 81 | my $wheel2 = delete $heap->{wheel2}; 82 | 83 | foreach my $key (keys %$flags) { 84 | fail( "$key didn't arrive, ever" ); 85 | } 86 | } 87 | 88 | POE::Kernel->run(); 89 | -------------------------------------------------------------------------------- /lib/POE/Wheel/UDP.pm: -------------------------------------------------------------------------------- 1 | package POE::Wheel::UDP; 2 | 3 | =head1 NAME 4 | 5 | POE::Wheel::UDP - POE Wheel for UDP handling. 6 | 7 | =head1 SYNOPSIS 8 | 9 | use POE; 10 | use POE::Wheel::UDP; 11 | 12 | POE::Session->create( 13 | inline_states => { 14 | _start => sub { 15 | my $wheel = $_[HEAP]->{wheel} = POE::Wheel::UDP->new( 16 | LocalAddr => '10.0.0.1', 17 | LocalPort => 1234, 18 | PeerAddr => '10.0.0.2', 19 | PeerPort => 1235, 20 | InputEvent => 'input', 21 | Filter => POE::Filter::Stream->new, 22 | ); 23 | $wheel->put( 24 | { 25 | payload => [ 'This datagram will go to the default address.' ], 26 | }, 27 | { 28 | payload => [ 'This datagram will go to the explicit address and port I have paired with it.' ], 29 | addr => '10.0.0.3', 30 | port => 1236, 31 | }, 32 | ); 33 | }, 34 | input => sub { 35 | my ($wheel_id, $input) = @_[ARG0, ARG1]; 36 | print "Incoming datagram from $input->{addr}:$input->{port}: '$input->{payload}'\n"; 37 | }, 38 | } 39 | ); 40 | 41 | POE::Kernel->run; 42 | 43 | =head1 DESCRIPTION 44 | 45 | POE Wheel for UDP handling. 46 | 47 | =cut 48 | 49 | use 5.006; # I don't plan to support old perl 50 | use strict; 51 | use warnings; 52 | 53 | use base 'POE::Wheel'; 54 | 55 | use POE; 56 | use Carp; 57 | use Socket qw( 58 | SOL_SOCKET 59 | SO_REUSEADDR 60 | SOCK_DGRAM 61 | PF_INET 62 | inet_aton 63 | inet_ntoa 64 | sockaddr_in 65 | unpack_sockaddr_in 66 | ); 67 | use Fcntl qw( 68 | F_SETFL 69 | O_NONBLOCK 70 | O_RDWR 71 | ); 72 | 73 | our $VERSION = '0.02'; 74 | $VERSION = eval $VERSION; # see L 75 | 76 | sub WARNINGS () { 0 } 77 | 78 | BEGIN { 79 | 80 | my $win32 = $^O =~ m/^MSWin32$/; 81 | eval "sub WIN32 () { $win32 }"; 82 | 83 | my $msg_dontwait = $win32 ? 0 : Socket::MSG_DONTWAIT(); 84 | eval "sub MSG_DONTWAIT () { $msg_dontwait }"; 85 | } 86 | 87 | =head1 Package Methods 88 | 89 | =head2 $wheel = POE::Wheel::UDP->new( OPTIONS ); 90 | 91 | Constructor for a new UDP Wheel object. OPTIONS is a key => value pair list specifying the following options: 92 | 93 | =over 94 | 95 | =item LocalAddr 96 | 97 | =item LocalPort 98 | 99 | (Required Pair) 100 | 101 | Specify the local IP address and port for the created socket. LocalAddr should be in dotted-quad notation, 102 | and LocalPort should be an integer. This module will not resolve names to numbers at all. 103 | 104 | =item PeerAddr 105 | 106 | =item PeerPort 107 | 108 | (Optional Pair) 109 | 110 | Specify the remote IP address and port for the created socket. As above, PeerAddr should be in dotted-quad 111 | notation, and PeerPort should be an integer. These arguments are used to perform a C connect(2) on the socket, 112 | which means that outbound datagrams will be sent to this address by default AND inbound datagrams from sources 113 | other than this peer will be ignored. If you want to just set a default destination for packets, use the 114 | DefaultAddr and DefaultPort items instead. 115 | 116 | =item DefaultAddr 117 | 118 | =item DefaultPort 119 | 120 | (Optional Pair) 121 | 122 | Dotted quad, and integer (respectively) options for the default destination of datagrams originating from this 123 | wheel. This setting will override the PeerAddr and PeerPort on each put() method, but you can override this 124 | by passing arguments directly to the put() method. 125 | 126 | =item InputEvent 127 | 128 | (Optional) 129 | 130 | Specify the event to be invoked via Kernel->yield when a packet arrives on this socket. Currently all incoming 131 | data is truncated to 1500 bytes. If you do not specify an event, the wheel will not ask the kernel to pass 132 | incoming datagrams to it, and therefore this wheel will not hold your session alive. 133 | 134 | =item InputFilter 135 | 136 | (Required if InputEvent defined) 137 | 138 | Assign a POE::Filter object to the input side of this wheel. 139 | 140 | =item OutputFilter 141 | 142 | (Required if you want to call the put method) 143 | 144 | Assign a POE::Filter object to the output side of this wheel. 145 | 146 | =item Filter 147 | 148 | Shorthand for assigning the same filter object to both the InputFilter and OutputFilter arguments. 149 | 150 | =back 151 | 152 | =cut 153 | 154 | sub new { 155 | my $class = shift; 156 | carp( "Uneven set of options passed to ${class}->new." ) unless (@_ % 2 == 0); 157 | my %opts = @_; 158 | 159 | my $self = bless { }, (ref $class || $class); 160 | 161 | my %sockopts; 162 | 163 | foreach (qw(LocalAddr LocalPort PeerAddr PeerPort)) { 164 | $sockopts{$_} = delete( $opts{$_} ) if exists( $opts{$_} ); 165 | } 166 | 167 | $self->_open( %sockopts ); 168 | 169 | my $id = $self->{id} = $self->SUPER::allocate_wheel_id(); 170 | my $read_event = $self->{read_event} = ref($self) . "($id) -> select read"; 171 | my $write_event = $self->{write_event} = ref($self) . "($id) -> select write"; 172 | 173 | if (exists( $opts{DefaultAddr} ) or exists( $opts{DefaultPort} )) { 174 | croak "DefaultAddr is required if DefaultPort is specified." 175 | unless exists( $opts{DefaultAddr} ); 176 | croak "DefaultPort is required if DefaultAddr is specified." 177 | unless exists( $opts{DefaultPort} ); 178 | 179 | my $addr = inet_aton( $opts{DefaultAddr} ) 180 | or croak( "Supplied 'DefaultAddr' value '$opts{DefaultAddr}' caused inet_aton failure: $!" ); 181 | 182 | my $spec = pack_sockaddr_in( $opts{DefaultPort}, $addr ) 183 | or croak( "Supplied 'DefaultPort' value '$opts{DefaultPort}' caused pack_sockaddr_in failure: $!" ); 184 | 185 | $self->{DefaultAddr} = delete $opts{DefaultAddr}; 186 | $self->{DefaultPort} = delete $opts{DefaultPort}; 187 | $self->{default_send} = $spec; 188 | } 189 | 190 | if (exists( $opts{Filter} )) { 191 | my $filter = delete $opts{Filter}; 192 | $opts{InputFilter} ||= $filter; 193 | $opts{OutputFilter} ||= $filter; 194 | } 195 | 196 | if (exists( $opts{InputFilter} )) { 197 | $self->{InputFilter} = delete $opts{InputFilter}; 198 | } 199 | 200 | if (exists( $opts{OutputFilter} )) { 201 | $self->{OutputFilter} = delete $opts{OutputFilter}; 202 | } 203 | 204 | if (exists( $opts{InputEvent} )) { 205 | croak "InputFilter option is required if InputEvent is defined." 206 | unless exists($self->{InputFilter}); 207 | 208 | my $filter = \$self->{InputFilter}; 209 | 210 | my $input_event = $self->{InputEvent} = delete $opts{InputEvent}; 211 | 212 | $poe_kernel->state( $read_event, sub { 213 | my ($kernel, $socket) = @_[KERNEL, ARG0]; 214 | $! = undef; 215 | while( my $addr = recv( $socket, my $input = "", 1500, MSG_DONTWAIT ) ) { 216 | if (defined( $addr )) { 217 | my %input_data; 218 | 219 | if ($addr) { 220 | my ($port, $addr) = unpack_sockaddr_in( $addr ) 221 | or warn( "sockaddr_in failure: $!" ); 222 | $input_data{addr} = inet_ntoa( $addr ); 223 | $input_data{port} = $port; 224 | } 225 | 226 | $input_data{bytes} = length( $input ); 227 | 228 | local $POE::Filter::DATAGRAM = 1; 229 | 230 | $$filter->get_one_start( [ $input ] ); 231 | 232 | my @payload; 233 | while (my $records = $$filter->get_one) { 234 | last unless @$records; 235 | push @payload, @$records; 236 | } 237 | 238 | $poe_kernel->yield( $input_event, { 239 | payload => \@payload, 240 | %input_data, 241 | }, $id ); 242 | } 243 | else { 244 | warn "recv failure: $!"; 245 | next 246 | } 247 | } 248 | } ); 249 | 250 | $poe_kernel->select_read( $self->{sock}, $read_event ); 251 | } 252 | 253 | # Does anyone know if I should watch for writability on the socket at all? it's pretty hard to test 254 | # to see if UDP can ever return EAGAIN because I can't get it to go fast enough to blast past the buffers. 255 | 256 | croak "Extra options passed to new(): " . join( ', ', map { "'$_'" } keys %opts ) 257 | if keys %opts; 258 | 259 | return $self; 260 | } 261 | 262 | sub _open { 263 | my $self = shift; 264 | my %opts = @_; 265 | 266 | my $proto = getprotobyname( "udp" ); 267 | 268 | socket( my $sock, PF_INET, SOCK_DGRAM, $proto ) 269 | or die( "socket() failure: $!" ); 270 | 271 | if (WIN32) { 272 | _win32_nonblock($sock); 273 | } else { 274 | _unix_nonblock($sock); 275 | } 276 | 277 | setsockopt( $sock, SOL_SOCKET, SO_REUSEADDR, 1 ) 278 | or die( "setsockopt SO_REUSEADDR failed: $!" ); 279 | 280 | { 281 | my $addr = inet_aton( $opts{LocalAddr} ) 282 | or die( "inet_aton problem: $!" ); 283 | my $sockaddr = sockaddr_in( $opts{LocalPort}, $addr ) 284 | or die( "sockaddr_in problem: $!" ); 285 | bind( $sock, $sockaddr ) 286 | or die( "bind error: $!" ); 287 | } 288 | 289 | if ($opts{PeerAddr} and $opts{PeerPort}) { 290 | my $addr = inet_aton( $opts{PeerAddr} ) 291 | or die( "inet_aton problem: $!" ); 292 | my $sockaddr = sockaddr_in( $opts{PeerPort}, $addr ) 293 | or die( "sockaddr_in problem: $!" ); 294 | connect( $sock, $sockaddr ) 295 | or die( "connect error: $!" ); 296 | } 297 | 298 | return $self->{sock} = $sock; 299 | } 300 | 301 | =head1 Object Methods 302 | 303 | =head2 $wheel->put( LIST ) 304 | 305 | Returns the total number of bytes sent in this call, which may not match the number of bytes 306 | you passed in for payloads due to send(2) semantics. Takes a list of hashrefs with the 307 | following useful keys in them: 308 | 309 | =over 310 | 311 | =item payload 312 | 313 | An arrayref of records you wish to put through the filter and send in datagrams. The arrayref 314 | is used to allow more than one logical record per datagram. 315 | 316 | =item bytes 317 | 318 | How many bytes were read from this datagram. Currently a maximum of 1500 will be read, and 319 | datagrams which are larger will be truncated. 320 | 321 | =item addr 322 | 323 | =item port 324 | 325 | Specify a destination IP address and port for this specific packet. Optional if you specified 326 | a PeerAddr and PeerPort in the wheel constructor; Required if you did not. 327 | 328 | =back 329 | 330 | =cut 331 | 332 | sub put { 333 | my $self= shift; 334 | 335 | my $sock = $self->{sock}; 336 | my $total_bytes = 0; 337 | 338 | while (my $thing = shift) { 339 | if (!defined( $thing )) { 340 | warn "Undefined argument, ignoring"; 341 | next; 342 | } 343 | 344 | if (ref( $thing ) ne 'HASH') { 345 | warn "Non-hasref argument, ignoring"; 346 | next; 347 | } 348 | 349 | my $payload = $thing->{payload} or die; 350 | 351 | die unless ref($payload) eq 'ARRAY'; 352 | 353 | my $filter = $self->{OutputFilter}; 354 | my $records = $filter->put( $payload ); 355 | 356 | my $bytes; 357 | if (exists( $thing->{addr} ) or exists( $thing->{port} )) { 358 | my $addr = $thing->{addr} or die; 359 | my $port = $thing->{port} or die; 360 | 361 | foreach my $output (@$records) { 362 | $bytes = send( $sock, $output, MSG_DONTWAIT, sockaddr_in( $port,inet_aton( $addr ) ) ); 363 | } 364 | } 365 | elsif (exists( $self->{default_send} )) { 366 | my $default_send = $self->{default_send}; 367 | foreach my $output (@$records) { 368 | $bytes = send( $sock, $output, MSG_DONTWAIT, $default_send ); 369 | } 370 | } 371 | else { 372 | foreach my $output (@$records) { 373 | $bytes = send( $sock, $output, MSG_DONTWAIT ); 374 | } 375 | } 376 | 377 | if (!defined( $bytes )) { 378 | die( "send() failed: $!" ); 379 | # if we ever remove fatal handling of this, do the following: 380 | # push current thing onto buffer. 381 | # last; 382 | } 383 | $total_bytes += $bytes; 384 | } 385 | 386 | # push rest of @_ onto buffer 387 | 388 | return $total_bytes; 389 | } 390 | 391 | sub DESTROY { 392 | my $self = shift; 393 | if ($self->{read_event}) { 394 | $poe_kernel->state( delete $self->{read_event} ); 395 | $poe_kernel->select_read( $self->{sock} ); 396 | } 397 | $self->SUPER::free_wheel_id( delete $self->{id} ); 398 | } 399 | 400 | sub allocate_wheel_id; # try to cancel this method from being inhereted. 401 | sub free_wheel_id; 402 | 403 | sub _unix_nonblock { 404 | my $sock = shift; 405 | 406 | return 1 if IO::Handle::blocking( $sock, 0 ); 407 | warn "IO::Handle::blocking call failed to set nonblock mode: $!" if WARNINGS; 408 | 409 | return 1 if fcntl( $sock, F_SETFL, O_NONBLOCK | O_RDWR ); 410 | warn "fcntl call failed to set nonblock mode: $!" if WARNINGS; 411 | 412 | return 0; 413 | } 414 | 415 | sub _win32_nonblock { 416 | my $sock = shift; 417 | return 0; 418 | } 419 | 420 | 1; 421 | __END__ 422 | 423 | =head1 Events 424 | 425 | =head2 InputEvent 426 | 427 | =over 428 | 429 | =item ARG0 430 | 431 | Contains a hashref with the following keys: 432 | 433 | =over 434 | 435 | =item addr 436 | 437 | =item port 438 | 439 | Specifies the address and port from which we received this datagram. 440 | 441 | =item payload 442 | 443 | An arrayref of records built from the actual datagram going through the filters. 444 | 445 | =back 446 | 447 | =item ARG1 448 | 449 | The wheel id for the wheel that fired this event. 450 | 451 | =back 452 | 453 | =head1 Filter semantics 454 | 455 | Datagram filter design is not guaranteed yet, we need to make sure the design I put in place here is workable. 456 | 457 | =head1 Upcoming features 458 | 459 | =over 460 | 461 | =item * 462 | 463 | IPV6 support. 464 | 465 | =item * 466 | 467 | TTL changing support. 468 | 469 | =back 470 | 471 | =head1 SEE ALSO 472 | 473 | POE 474 | 475 | =head1 AUTHOR 476 | 477 | Jonathan Steinert Ehachi@cpan.orgE 478 | 479 | =head1 COPYRIGHT AND LICENSE 480 | 481 | Copyright (C) 2006 by Jonathan Steinert... or Six Apart... I don't know who owns me when I'm at home. Oh well. 482 | 483 | This library is free software; you can redistribute it and/or modify 484 | it under the same terms as Perl itself, either Perl version 5.8.8 or, 485 | at your option, any later version of Perl 5 you may have available. 486 | 487 | =cut 488 | 489 | # vim: ts=8 noexpandtab filetype=perl 490 | --------------------------------------------------------------------------------