/
Ping.pm
executable file
·350 lines (226 loc) · 7.86 KB
/
Ping.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
package Test::Ping;
use strict;
use warnings;
use Test::Ping::Ties::BIND;
use Test::Ping::Ties::PORT;
use Test::Ping::Ties::PROTO;
use Test::Ping::Ties::HIRES;
use Test::Ping::Ties::TIMEOUT;
use Test::Ping::Ties::SOURCE_VERIFY;
use Test::Ping::Ties::SERVICE_CHECK;
my $CLASS = __PACKAGE__;
my $OBJPATH = __PACKAGE__->builder->{'_net-ping_object'};
my $method_ignore = '__NONE';
our $VERSION = '0.18';
our @EXPORT = qw(
ping_ok
ping_not_ok
create_ping_object_ok
create_ping_object_not_ok
);
# Net::Ping variables
our $PORT;
our $BIND;
our $PROTO;
our $HIRES;
our $TIMEOUT;
our $SOURCE_VERIFY;
our $SERVICE_CHECK;
BEGIN {
use base 'Test::Builder::Module';
use Net::Ping;
__PACKAGE__->builder->{'_net-ping_object'} = Net::Ping->new($PROTO);
tie $PORT, 'Test::Ping::Ties::PORT';
tie $BIND, 'Test::Ping::Ties::BIND';
tie $PROTO, 'Test::Ping::Ties::PROTO';
tie $HIRES, 'Test::Ping::Ties::HIRES';
tie $TIMEOUT, 'Test::Ping::Ties::TIMEOUT';
tie $SOURCE_VERIFY, 'Test::Ping::Ties::SOURCE_VERIFY';
tie $SERVICE_CHECK, 'Test::Ping::Ties::SERVICE_CHECK';
}
sub ping_ok {
my ( $host, $name ) = @_;
my $tb = $CLASS->builder;
my $pinger = $OBJPATH;
my ( $ret, $duration ) = $pinger->ping( $host, $TIMEOUT );
$tb->ok( $ret, $name );
return ( $ret, $duration );
}
sub ping_not_ok {
my ( $host, $name ) = @_;
my $tb = $CLASS->builder;
my $pinger = $OBJPATH;
my $alive = $pinger->ping( $host, $TIMEOUT );
$tb->ok( !$alive, $name );
return 1;
}
sub create_ping_object_ok {
my @args = @_;
my $name = pop @args || q{};
my $tb = $CLASS->builder;
my $success = eval { $OBJPATH = Net::Ping->new(@args); 1; };
$tb->ok( $success && ref $OBJPATH eq 'Net::Ping', $name );
}
sub create_ping_object_not_ok {
my @args = @_;
my $name = pop @args || q{};
my $tb = $CLASS->builder;
my $error;
eval { Net::Ping->new(@args); 1; }
or $error = $@;
$tb->ok( $error, $name );
}
sub _has_var_ok {
my ( $var_name, $var_value, $name ) = @_;
my $tb = $CLASS->builder;
$tb->is_eq( $OBJPATH->{$var_name}, $var_value, $name ); ## no critic
return 1;
}
sub _ping_object {
my $obj = $_[1] || $_[0] || q{};
if ( ref $obj eq 'Net::Ping' ) {
$OBJPATH = $obj;
}
return $OBJPATH;
}
END { $OBJPATH->close(); }
1;
__END__
=head1 NAME
Test::Ping - Testing pings using Net::Ping
=head1 VERSION
Version 0.18
=head1 SYNOPSIS
This module helps test pings using Net::Ping
use Test::More tests => 2;
use Test::Ping;
my $good_host = '127.0.0.1';
my $bad_host = '1.1.1.1;
ping_ok( $good_host, "able to ping $good_host" );
ping_not_ok( $bad_host, "can't ping $bad_host" );
...
=head1 DESCRIPTION
Using this module you do not have to work with an object, but can instead use
actual procedural testing functions, which is cleaner and more straight forward
for testing purposes. This module keeps track of the object for you, starting
and closing it and provides a nifty way of testing for pings.
=head1 SUBROUTINES/METHODS
=head2 ping_ok( $host, $test )
Checks if a host replies to ping correctly.
This returns the return value and duration, just like L<Net::Ping>'s C<ping()>
method.
=head2 ping_not_ok( $host, $test )
Does the exact opposite of C<ping_ok()>.
=head2 create_ping_object_ok( @args, $test )
This tries to create a ping object and reports a fail or success. The args that
should be sent are whatever args used with L<Net::Ping>.
=head2 create_ping_object_not_ok( @args, $test )
Tried to create a ping object and attempts to fail. The exactly opposite of the
C<create_ping_object_not_ok()>
=head1 EXPORT
C<ping_ok>
C<ping_not_ok>
C<create_ping_object_ok>
C<create_ping_object_not_ok>
=head1 SUPPORTED VARIABLES
Variables in L<Test::Ping> are tied scalars. Some variables change the values
in the object hash while others run methods. This follows the behavior of
L<Net::Ping>. Below you will find each support variable and what it changes.
=head2 BIND
Runs the C<bind> method.
=head2 PROTO
Changes the C<proto> hash value.
=head2 TIMEOUT
Changes the C<timeout> hash value.
=head2 PORT
Changes the C<port_num> hash value.
=head2 HIRES
Changes the package variable C<$hires>. By default, it is enabled.
=head2 SOURCE_VERIFY
Changes the package variable C<$source_verify>.
=head2 SERVICE_CHECK
Changes the C<econnrefused> hash value.
=head1 INTERNAL METHODS
=head2 _has_var_ok( $var_name, $var_value, $description )
Gets a variable name to test, what to test against and the name of the test.
Runs an actual test using L<Test::Builder>.
This is used to debug the actual module, if you wanna make sure it works.
use Test::More tests => 1;
use Test::Ping;
# Test::Ping calls the protocol variable 'PROTO',
# but Net::Ping calls it internally (in the hash) 'proto'
# (this is documented above under PROTO)
# this is checking against Net::Ping specifically
$Test::Ping::PROTO = 'icmp';
Test::Ping::_has_var_ok(
'proto',
'icmp',
'Net::Ping has correct protocol variable',
);
=head2 _ping_object
When debugging behavior, fetching an internal object from a procedural module
can be a bit difficult (especially when it has base inheritance with another
one).
This method allows you (or me) to fetch the actual L<Net::Ping> object from
C<Test::Ping>. It eases testing and assurance.
This is used by the Tie functions to set the variables for the object for you.
use Test::Ping;
use Data::Dumper;
print 'Object internals: ' . Dumper( Test::Ping->_ping_object() );
Or you could also change the Net::Ping object to one of your own:
use Test::Ping;
use Net::Ping;
Test::Ping->_ping_object( Net::Ping->new(@opts) );
And doing it with tests:
use Test::More tests => 2;
use Test::Ping;
create_ping_object_ok( 'tcp', 2, 'Creating our own Net::Ping object' );
ping_ok( $target, "Yay! We can reach $target" );
However, you should be warned. I test for a L<Net::Ping> object so trying to
pass other objects will fail. If anyone needs this changed or any reason,
contact me and I'll consider it.
=head1 DEPENDENCIES
This module uses L<Net::Ping>, L<Tie::Scalar> and L<Carp>.
L<Test::Timer> is used in the test suite.
=head1 AUTHOR
Sawyer X, C<< <xsawyerx at cpan.org> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-test-ping at rt.cpan.org>,
or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Ping>.
There is also a GitHub issue tracker at
L<http://github.com/xsawyerx/test-ping/issues> which I'll probably check just as
much.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc Test::Ping
If you have Git, this is the clone path:
git@github.com:xsawyerx/test-ping.git
You can also look for information at:
=over 4
=item * GitHub Website:
L<http://github.com/xsawyerx/test-ping/tree/master>
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Ping>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/Test-Ping>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/Test-Ping>
=item * Search CPAN
L<http://search.cpan.org/dist/Test-Ping/>
=back
=head1 ACKNOWLEDGEMENTS
Steve Bertrand (STEVEB) provided many fixes and improvements. Big thank
you for all the work done.
Thanks to everyone who works and contributed to C<Net::Ping>. This module
depends solely on it.
=head1 COPYRIGHT & LICENSE
Copyright 2009-2010 Sawyer X, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the terms of either:
=over 4
=item * the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any
later version, or
=item * the Artistic License version 2.0.
=back