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