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