1b8851fccSafresh1#!perl 2b8851fccSafresh1 3b8851fccSafresh1use 5.008001; 4b8851fccSafresh1 5b8851fccSafresh1use strict; 6b8851fccSafresh1use warnings; 7b39c5158Smillert 8*eac174f2Safresh1use Test::More; 9*eac174f2Safresh1 10b39c5158SmillertBEGIN { 11b8851fccSafresh1 if (!eval { require Socket }) { 12*eac174f2Safresh1 plan skip_all => "no Socket"; 13b39c5158Smillert } 14*eac174f2Safresh1 elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { 15*eac174f2Safresh1 plan skip_all => "EBCDIC but no Convert::EBCDIC"; 16b39c5158Smillert } 17*eac174f2Safresh1 else { 18*eac174f2Safresh1 plan tests => 12; 19*eac174f2Safresh1 } 20*eac174f2Safresh1 21b39c5158Smillert $INC{'IO/Socket.pm'} = 1; 22b39c5158Smillert $INC{'IO/Select.pm'} = 1; 23b39c5158Smillert $INC{'IO/Socket/INET.pm'} = 1; 24b39c5158Smillert} 25b39c5158Smillert 26b39c5158Smillert# cannot use(), otherwise it will use IO::Socket and IO::Select 27b39c5158Smillerteval{ require Net::Time; }; 28b39c5158Smillertok( !$@, 'should be able to require() Net::Time safely' ); 29b39c5158Smillertok( exists $INC{'Net/Time.pm'}, 'should be able to use Net::Time' ); 30b39c5158Smillert 31b39c5158Smillert# force the socket to fail 32b39c5158Smillertmake_fail('IO::Socket::INET', 'new'); 33b39c5158Smillertmy $badsock = Net::Time::_socket('foo', 1, 'bar', 'baz'); 34b39c5158Smillertis( $badsock, undef, '_socket() should fail if Socket creation fails' ); 35b39c5158Smillert 36b39c5158Smillert# if socket is created with protocol UDP (default), it will send a newline 37b39c5158Smillertmy $sock = Net::Time::_socket('foo', 2, 'bar'); 38b39c5158Smillertok( $sock->isa('IO::Socket::INET'), 'should be an IO::Socket::INET object' ); 39b39c5158Smillertis( $sock->{sent}, "\n", 'should send \n with UDP protocol set' ); 40b39c5158Smillertis( $sock->{timeout}, 120, 'timeout should default to 120' ); 41b39c5158Smillert 42b39c5158Smillert# now try it with a custom timeout and a different protocol 43b39c5158Smillert$sock = Net::Time::_socket('foo', 3, 'bar', 'tcp', 11); 44b39c5158Smillertok( $sock->isa('IO::Socket::INET'), 'should be an IO::Socket::INET object' ); 45b39c5158Smillertis( $sock->{sent}, undef, '_socket() should send nothing unless UDP protocol' ); 46b39c5158Smillertis( $sock->{PeerAddr}, 'bar', '_socket() should set PeerAddr in socket' ); 47b39c5158Smillertis( $sock->{timeout}, 11, '_socket() should respect custom timeout value' ); 48b39c5158Smillert 49b39c5158Smillert# inet_daytime 50b39c5158Smillert# check for correct args (daytime, 13) 51b39c5158SmillertIO::Socket::INET::set_message('z'); 52b39c5158Smillertis( Net::Time::inet_daytime('bob'), 'z', 'inet_daytime() should receive data' ); 53b39c5158Smillert 54b39c5158Smillert# magic numbers defined in Net::Time 55b39c5158Smillertmy $offset = $^O eq 'MacOS' ? 56b39c5158Smillert (4 * 31536000) : (70 * 31536000 + 17 * 86400); 57b39c5158Smillert 58b39c5158Smillert# check for correct args (time, 13) 59b39c5158Smillert# pretend it is only six seconds since the offset, create a fake message 60b39c5158Smillert# inet_time 61b39c5158SmillertIO::Socket::INET::set_message(pack("N", $offset + 6)); 62b39c5158Smillertis( Net::Time::inet_time('foo'), 6, 63b39c5158Smillert 'inet_time() should calculate time since offset for time()' ); 64b39c5158Smillert 65b39c5158Smillert 66b39c5158Smillertmy %fail; 67b39c5158Smillert 68b39c5158Smillertsub make_fail { 69b39c5158Smillert my ($pack, $func, $num) = @_; 70b39c5158Smillert $num = 1 unless defined $num; 71b39c5158Smillert 72b39c5158Smillert $fail{$pack}{$func} = $num; 73b39c5158Smillert} 74b39c5158Smillert 75b39c5158Smillertpackage IO::Socket::INET; 76b39c5158Smillert 77b39c5158Smillert$fail{'IO::Socket::INET'} = { 78b39c5158Smillert new => 0, 79b39c5158Smillert 'send' => 0, 80b39c5158Smillert}; 81b39c5158Smillert 82b39c5158Smillertsub new { 83b39c5158Smillert my $class = shift; 84b39c5158Smillert return if $fail{$class}{new} and $fail{$class}{new}--; 85b39c5158Smillert bless( { @_ }, $class ); 86b39c5158Smillert} 87b39c5158Smillert 88b39c5158Smillertsub send { 89b39c5158Smillert my $self = shift; 90b39c5158Smillert my $class = ref($self); 91b39c5158Smillert return if $fail{$class}{'send'} and $fail{$class}{'send'}--; 92b39c5158Smillert $self->{sent} .= shift; 93b39c5158Smillert} 94b39c5158Smillert 95b39c5158Smillertmy $msg; 96b39c5158Smillertsub set_message { 97b39c5158Smillert if (ref($_[0])) { 98b39c5158Smillert $_[0]->{msg} = $_[1]; 99b39c5158Smillert } else { 100b39c5158Smillert $msg = shift; 101b39c5158Smillert } 102b39c5158Smillert} 103b39c5158Smillert 104b39c5158Smillertsub do_recv { 105b39c5158Smillert my ($len, $msg) = @_[1,2]; 106b39c5158Smillert $_[0] .= substr($msg, 0, $len); 107b39c5158Smillert} 108b39c5158Smillert 109b39c5158Smillertsub recv { 110b39c5158Smillert my ($self, $buf, $length, $flags) = @_; 111b39c5158Smillert my $message = exists $self->{msg} ? 112b39c5158Smillert $self->{msg} : $msg; 113b39c5158Smillert 114b39c5158Smillert if (defined($message)) { 115b39c5158Smillert do_recv($_[1], $length, $message); 116b39c5158Smillert } 117b39c5158Smillert 1; 118b39c5158Smillert} 119b39c5158Smillert 120b39c5158Smillertpackage IO::Select; 121b39c5158Smillert 122b39c5158Smillertsub new { 123b39c5158Smillert my $class = shift; 124b39c5158Smillert return if defined $fail{$class}{new} and $fail{$class}{new}--; 125b39c5158Smillert bless({sock => shift}, $class); 126b39c5158Smillert} 127b39c5158Smillert 128b39c5158Smillertsub can_read { 129b39c5158Smillert my ($self, $timeout) = @_; 130b39c5158Smillert my $class = ref($self); 131b39c5158Smillert return if defined $fail{$class}{can_read} and $fail{class}{can_read}--; 132b39c5158Smillert $self->{sock}{timeout} = $timeout; 133b39c5158Smillert 1; 134b39c5158Smillert} 135b39c5158Smillert 136b39c5158Smillert1; 137