File Coverage

blib/lib/Net/Whois/Generic.pm
Criterion Covered Total %
statement 141 166 84.9
branch 57 86 66.2
condition 18 29 62.0
subroutine 30 33 90.9
pod 18 18 100.0
total 264 332 79.5


line stmt bran cond sub pod time code
1             package Net::Whois::Generic;
2              
3 8     8   72790 use 5.006;
  8         36  
4 8     8   41 use warnings;
  8         16  
  8         198  
5 8     8   42 use strict;
  8         31  
  8         238  
6 8     8   4530 use IO::Socket::INET;
  8         167373  
  8         52  
7 8     8   8381 use IO::Select;
  8         13511  
  8         401  
8 8     8   4622 use Iterator;
  8         117593  
  8         266  
9 8     8   4705 use Net::Whois::Object;
  8         38  
  8         367  
10 8     8   65 use Data::Dumper;
  8         22  
  8         728  
11              
12             use constant {
13 8         22600 SOON => 30,
14             END_OF_OBJECT_MARK => "\n\n",
15             EOL => "\015\012",
16             QUERY_LIST_OBJECTS => q{-qtypes },
17 8     8   88 };
  8         22  
18              
19             # simplify if all servers happen to accept same options
20             our %RIR = (
21             apnic => { SERVER => 'whois.apnic.net', QUERY_NON_RECURSIVE => q{-r }, QUERY_REFERRAL => q{-R }, QUERY_UNFILTERED => q{-B }, },
22             ripe => { SERVER => 'whois.ripe.net', QUERY_NON_RECURSIVE => q{-r }, QUERY_REFERRAL => q{-R }, QUERY_UNFILTERED => q{-B }, },
23             arin => { SERVER => 'whois.arin.net', QUERY_NON_RECURSIVE => q{-r }, QUERY_REFERRAL => q{-R }, QUERY_UNFILTERED => q{-B }, },
24             lacnic => { SERVER => 'whois.lacnic.net', QUERY_NON_RECURSIVE => q{-r }, QUERY_REFERRAL => q{-R }, QUERY_UNFILTERED => q{-B }, },
25             afrinic => { SERVER => 'whois.afrinic.net', QUERY_NON_RECURSIVE => q{-r }, QUERY_REFERRAL => q{-R }, QUERY_UNFILTERED => q{-B }, },
26             );
27              
28             =head1 NAME
29              
30             Net::Whois::Generic - a pure-Perl implementation of a multi source Whois client.
31              
32             =head1 SYNOPSIS
33              
34             Net::Whois::Generic is my first attempt to unify Whois information from different sources.
35             Historically Net::Whois::RIPE was the first written, then Net::Whois::Object was added to provide
36             a RPSL encapsultation of the data returned from RIPE database, with an API more object oriented.
37              
38             Net::Whois::Generic is a new interface designed to be more generic and to encapsulate data from
39             various sources (RIPE, but also AFRINIC, APNIC...)
40             The current implementation is barely a proof of concept, AFRINIC and APNIC are the only other sources implemented,
41             but I expect to turn it into a generic/robust implementation based on the users feedback.
42              
43             my $c = Net::Whois::Generic->new( disconnected => 1, unfiltered => 1 );
44              
45             my ($org) = $c->query( 'ORG-AFNC1-AFRINIC', { type => 'organisation' } );
46             # $org is a 'Net::Whois::Object::Organisation::AFRINIC' object;
47            
48             my @o = $c->query('101.0.0.0/8');
49             # @o contains various Net::Whois::Object:Inetnum::APNIC, and Net::Whois::Object::Information objects
50              
51             As Net::Whois::Generic started as an improvment of Net::Whois::RIPE, and have a good amount of code in common,
52             for this reason (and some others) it is currently bundled inside the the Net::Whois::RIPE package.
53             This might change in the future although.
54              
55             =head1 METHODS
56              
57             =head2 B
58              
59             Constructor. Returns a new L object with an open connection
60             to the RIPE Database service of choice (defaulting to C).
61              
62             The C<%options> hash migth contain configuration options for the RIPE Database
63             server. Not all options provided by the RIPE Database server are suitable for
64             this implementation, but the idea is to provide everything someone can show a
65             use for. The options currently recognized are:
66              
67             =over 4
68              
69             =item B (IPv4 address or DNS name. Default is C)
70              
71             The hostname or IP address of the service to connect to
72              
73             =item B (integer, default is C<43>)
74              
75             The TCP port of the service to connect to
76              
77             =item B (integer, default is C<5>)
78              
79             The time-out (in seconds) for the TCP connection.
80              
81             =item B (boolean, default is C)
82              
83             When true, prevents the server from using the referral mechanism for domain
84             lookups, so that the RIPE Database server returns an object in the RIPE
85             Database with the exact match with the lookup argument, rather than doing a
86             referral lookup.
87              
88             =item B (boolean, default is C)
89              
90             When set to C, prevents recursion into queried objects for personal
91             information. This prevents lots of unsolicited objects from showing up on
92             queries.
93              
94             =item B (boolean, default is C)
95              
96             When C enables object grouping in server responses. There's little
97             utility to enable this option, as the objects will be parsed and returned on a
98             much reasonable format most of the time. For the brave or more knowledgeable
99             people that want to have they answers in plain text, this can help stablishing
100             a 'good' ordering for the RPSL objects returned by a query ('good' is RIPE
101             NCC's definition of 'good' in this case).
102              
103             =item B (boolean, default is C)
104              
105             When C enables unfiltered object output responses. This produces objects
106             that can be presented back to the RIPE Database for updating.
107              
108             =item B (list of valid RIPE Database object types, default is empty, meaning all types)
109              
110             Restrict the RPSL object types allowed in the response to those in the list.
111             Using this option will cause the L object to query the RIPE
112             Database for the available object types for validating the list. The response
113             will be cached for speed and bandwidth.
114              
115             =item B (boolean, default is C)
116              
117             Prevents the constructor from automatically opening a connection to the service
118             specified (conneting the socket is the default behavior). When set (C),
119             the programmer is responsible for calling C in order to stablish a
120             connection to the RIPE Database service desired.
121              
122             =back
123              
124             =cut
125              
126             {
127             my %default_options = (
128             # hostname => 'whois.ripe.net',
129             port => '43',
130             timeout => 5,
131             referral => 0,
132             recursive => 0,
133             grouping => 1,
134             unfiltered => 0,
135             types => undef,
136             disconnected => 0,
137             );
138              
139             sub new
140             {
141 7     7 1 2200 my $class = shift;
142              
143             # I wish I hadn't to maintain backward compatibility but 2 forms exist...
144 7         19 my %options;
145              
146 7 100       41 if (ref($_[0]) =~ /HASH/i) {
147 3         11 %options = %{ $_[0] };
  3         18  
148             }
149             else {
150 4         14 %options = @_;
151             }
152 7         17 my %known_options;
153 7 100       105 $known_options{$_} = exists $options{$_} ? $options{$_} : $default_options{$_} foreach keys %default_options;
154              
155 7         32 my $self = bless { __options => \%known_options }, $class;
156              
157 7         31 return $self;
158             }
159             }
160              
161             =head2 B
162              
163             Accessor to the hostname. Accepts an optional hostname, always return the
164             current hostname.
165              
166             =cut
167              
168             sub hostname
169             {
170 25     25 1 64 my ($self, $hostname) = @_;
171 25 100       80 $self->{__options}{hostname} = $hostname if defined $hostname;
172 25         123 return $self->{__options}{hostname};
173             }
174              
175             =head2 B
176              
177             Accessor to the port. Accepts an optional port, always return the current
178             port.
179              
180             =cut
181              
182             sub port
183             {
184 11     11 1 37 my ($self, $port) = @_;
185 11 50 33     42 $self->{__options}{port} = $port if defined $port && $port =~ m{^\d+$};
186 11         42 return $self->{__options}{port};
187             }
188              
189             =head2 B
190              
191             Accessor to the timeout configuration option. Accepts an optional timeout,
192             always return the current timeout.
193              
194             =cut
195              
196             sub timeout
197             {
198 86     86 1 276 my ($self, $timeout) = @_;
199 86 50 33     343 $self->{__options}{timeout} = $timeout
200             if defined $timeout && $timeout =~ m{^\d+$};
201 86         630 return $self->{__options}{timeout};
202             }
203              
204             =begin UNDOCUMENTED
205              
206             =head2 B<__boolean_accessor( $self, $attribute [, $value ] )>
207              
208             Private method. Shouldn't be used from other modules.
209              
210             Generic implementation of an accessor for booleans. Receives a reference to the
211             current instance, the attribute name, and a value to be interpreted under
212             Perl's boolean rules. Sets or gets the named attribute with the given value.
213             Always returns the most up-to-date value of the attribute.
214              
215             =end UNDOCUMENTED
216              
217             =cut
218              
219             sub __boolean_accessor
220             {
221 24     24   61 my ($self, $attribute) = (shift, shift);
222 24 50       75 if (scalar @_ == 1) {
223 0         0 my $value = shift;
224 0 0       0 $self->{__options}{$attribute} = $value ? 1 : 0;
225             }
226 24         142 return $self->{__options}{$attribute};
227             }
228              
229             =head2 B
230              
231             Accessor to the referral configuration option. Accepts an optional referral,
232             always return the current referral.
233              
234             =cut
235              
236             sub referral
237             {
238 8     8 1 20 my $self = shift;
239 8         25 return $self->__boolean_accessor('referral', @_);
240             }
241              
242             =head2 B
243              
244             Accessor to the recursive configuration option. Accepts an optional recursive,
245             always return the current recursive.
246              
247             =cut
248              
249             sub recursive
250             {
251 8     8 1 21 my $self = shift;
252 8         26 return $self->__boolean_accessor('recursive', @_);
253             }
254              
255             =head2 B
256              
257             Accessor to the grouping configuration option. Accepts an optional grouping,
258             always return the current grouping.
259              
260             =cut
261              
262             sub grouping
263             {
264 0     0 1 0 my $self = shift;
265 0         0 return $self->__boolean_accessor('grouping', @_);
266             }
267              
268             =head2 B
269              
270             Accessor to the unfiltered configuration option.
271              
272             =cut
273              
274             sub unfiltered
275             {
276 8     8 1 23 my $self = shift;
277 8         35 return $self->__boolean_accessor('unfiltered', @_);
278             }
279              
280             =head2 B
281              
282             Initiates a connection with the current object's configuration.
283              
284             =cut
285              
286             sub connect
287             {
288 11     11 1 31 my $self = shift;
289 11   100     36 my %connection = (
290             Proto => 'tcp',
291             Type => SOCK_STREAM,
292             PeerAddr => $self->hostname || 'whois.ripe.net',
293             PeerPort => $self->port,
294             Timeout => $self->timeout,
295             Domain => AF_INET,
296             Multihomed => 1,
297             );
298              
299             # Create a new IO::Socket object
300 11         140 my $socket = $self->{__state}{socket} = IO::Socket::INET->new(%connection);
301 11 50       665663 die q{Can't connect to "} . $self->hostname . ':' . $self->port . qq{". Reason: [$@].\n}
302             unless defined $socket;
303              
304             # Register $socket with the IO::Select object
305 11 100       79 if (my $ios = $self->ios) {
306 5 50       44 $ios->add($socket) unless $ios->exists($socket);
307             }
308             else {
309 6         53 $self->{__state}{ioselect} = IO::Select->new($socket);
310             }
311             }
312              
313             =head2 B
314              
315             Accessor to the L object coordinating the I/O to the L
316             object used by this module to communicate with the RIPE Database Server. You
317             shouldn't use this object, but the L and L<"query( $query_string )">
318             methods instead.
319              
320             =cut
321              
322 88     88 1 459 sub ios { return $_[0]->{__state}{ioselect} }
323              
324             =head2 B
325              
326             Read-only accessor to the L object used by this module.
327              
328             =cut
329              
330 89     89 1 3992 sub socket { return $_[0]->{__state}{socket} }
331              
332             =head2 B
333              
334             Sends a message to the RIPE Database server instance to which we're connected
335             to. Dies if it cannot write, or if there's no open connection to the server.
336              
337             Return C if the message could be written to the socket, C
338             otherwise.
339              
340             =cut
341              
342             sub send
343             {
344 0     0 1 0 my ($self, $message) = @_;
345 0 0       0 die q{Not connected} unless $self->is_connected;
346 0 0       0 if ($self->ios->can_write(SOON + $self->timeout)) {
347 0         0 $self->socket->print($message, EOL);
348 0         0 $self->socket->flush;
349 0         0 return 1;
350             }
351 0         0 return 0;
352             }
353              
354             =head2 B
355              
356             Reconnects to the server in case we lost connection.
357              
358             =cut
359              
360             sub reconnect
361             {
362 1     1 1 4 my $self = shift;
363 1 50       4 $self->disconnect if $self->is_connected;
364 1         6 $self->connect;
365             }
366              
367             =head2 B
368              
369             Disconnects this client from the server. This renders the client useless until
370             you call L again. This method is called by L as part of
371             an object's clean-up process.
372              
373             =cut
374              
375             sub disconnect
376             {
377 9     9 1 1831 my $self = shift;
378 9 100       46 if ($self->is_connected) {
379 7         253 my $socket = $self->{__state}{socket};
380 7         81 $socket->close;
381             $self->{__state}{ioselect}->remove($socket)
382 7 50       1267 if $self->{__state}{ioselect};
383 7         1503 delete $self->{__state}{socket};
384             }
385             }
386              
387             =head2 B
388              
389             Returns C if this instance is connected to the RIPE Database service
390             configured.
391              
392             =cut
393              
394             sub is_connected
395             {
396 13     13 1 2560 my $self = shift;
397 13         45 my $socket = $self->socket;
398 13 100 66     443 return UNIVERSAL::isa($socket, 'IO::Socket')
399             && $socket->connected ? 1 : 0;
400             }
401              
402             =head2 B
403              
404             Net::Whois::Generic object destructor. Called by the Perl interpreter upon
405             destruction of an instance.
406              
407             =cut
408              
409             sub DESTROY
410             {
411 7     7   1123 my $self = shift;
412 7         29 $self->disconnect;
413             }
414              
415             =head2 B<_find_rir( $query_string )>
416              
417             Guess the associated RIR based on the query.
418              
419             =cut
420              
421             sub _find_rir
422             {
423 8     8   42 my ($self, $query) = @_;
424              
425 8         17 my $rir;
426              
427 8 100 100     229 if ( ($query =~ /^(41|102|105|154|196|197)\.\d+\.\d+\.\d+/)
    50 66        
    100 33        
      33        
      66        
      100        
428             or ($query =~ /AFRINIC/i)
429             or ($query =~ /^2c00::/i))
430             {
431 2         6 $rir = 'afrinic';
432             }
433             elsif ( ( $query =~ /^(23|34|50|64|64|65|66|67|68|69|70|71|72|73|74|75|76|96|97|98|9|100|104|107|108|135|136|142|147|162|166|172|173|174|184|192|198|199|204|205|206|207|208|209|216)/
434             or ($query =~ /^(2001:0400|2001:1800|2001:4800:|2600|2610:0000):/i)
435             or $query =~ /ARIN/
436             )
437             )
438             {
439 0         0 $rir = 'arin';
440              
441             }
442             elsif ( ( $query =~ /^(10|14|27|36|39|42|49|58|59|60|61|101|103|106|110|111|112|113|114|115|116|117|118|119|120|121|122|123|124|125|126|169\.208|175|180|182|183|202|203|210|211|218|219|220|221|222|223)\.\d+\.\d+/
443             or ($query =~ /^(2001:0200|2001:0C00|2001:0E00|2001:4400|2001:8000|2001:A000|2001:B000|2400:0000|2001:0DC0|2001:0DE8|2001:0DF0|2001:07FA|2001:0DE0|2001:0DB8):/i)
444             or $query =~ /APNIC/
445             )
446             )
447             {
448 2         7 $rir = 'apnic';
449              
450             }
451             else {
452 4         15 $rir = 'ripe';
453             }
454              
455 8         29 return $rir;
456             }
457              
458             =head2 B
459              
460             Adapt a query to set various parameter (whois server, query options...) based on the query.
461             Takes an optional parameter $rir, to force a specific RIR to be used.
462              
463             =cut
464              
465             sub adapt_query
466             {
467 8     8 1 30 my ($self, $query, $rir) = @_;
468 8         19 my $fullquery;
469              
470             # determine RIR unless $rir;
471 8 50       157 $rir = $self->_find_rir($query) unless $rir;
472              
473 8 100       36 if (!$self->hostname) {
474 6 100       32 if ($rir eq 'ripe') {
    100          
    50          
    50          
    50          
475 4         22 $self->hostname($RIR{ripe}{SERVER});
476             }
477             elsif ($rir eq 'afrinic') {
478 1         2 $fullquery = '-V Md5.0 ' . $query;
479 1         3 $self->hostname($RIR{afrinic}{SERVER});
480             }
481             elsif ($rir eq 'arin') {
482 0         0 $self->hostname($RIR{arin}{SERVER});
483             }
484             elsif ($rir eq 'lacnic') {
485 0         0 $self->hostname($RIR{lacnic}{SERVER});
486             }
487             elsif ($rir eq 'apnic') {
488 1         4 $self->hostname($RIR{apnic}{SERVER});
489             }
490             }
491              
492 8         22 my $parameters = "";
493 8 100       29 $parameters .= q{ } . $RIR{$rir}{QUERY_UNFILTERED} if $self->unfiltered;
494 8 50       53 $parameters .= q{ } . $RIR{$rir}{QUERY_NON_RECURSIVE} unless $self->recursive;
495 8 50       36 $parameters .= q{ } . $RIR{$rir}{QUERY_REFERRAL} if $self->referral;
496 8         39 $fullquery = $parameters . $query;
497              
498 8         27 return $fullquery;
499             }
500              
501             =head2 B
502              
503             ******************************** EXPERIMENTAL ************************************
504             This method is a work in progress, the API and behaviour are subject to change
505             **********************************************************************************
506              
507             Query the the appropriate RIR database and return Net::Whois::Objects
508              
509             This method accepts 2 optional parameters
510              
511             'type' which is a regex used to filter the query result:
512             Only the object whose type matches the 'type' parameter are returned
513              
514             'attribute' which is a regex used to filter the query result:
515             Only the value of the attributes matching the 'attribute' parameter are
516             returned
517              
518             Note that if 'attribute' is specified strings are returned, instead of
519             Net::Whois::Objects
520              
521             Net::Whois:Generic->query() deprecates Net::Whois::Object->query() since release 2.005 of Net::Whois::RIPE
522              
523             =cut
524              
525             sub query
526             {
527 8     8 1 66372 my ($self, $query, $options) = @_;
528              
529 8         44 my $attribute;
530             my $type;
531 8         0 my $response;
532              
533 8         43 for my $opt (keys %$options) {
534 6 100       70 if ($opt =~ /^attribute$/i) {
    50          
535 2         10 $attribute = $options->{$opt};
536             }
537             elsif ($opt =~ /^type$/i) {
538 4         15 $type = $options->{$opt};
539             }
540             }
541              
542 8 100       40 if (!ref $self) {
543              
544             # $self is the class
545 3         18 $self = $self->new($options);
546             }
547              
548 8         38 $query = $self->adapt_query($query);
549 8         37 my $iterator = $self->__query($query);
550              
551 8         549 my @objects = Net::Whois::Object->new($iterator);
552              
553 8         36 ($response) = grep { ref($_) =~ /response/i } @objects;
  47         152  
554              
555 8 50       30 if ($response) {
556 0         0 $self->_process_response($response);
557              
558             }
559              
560 8 100       26 if ($type) {
561 4         14 @objects = grep { ref($_) =~ /$type/i } @objects;
  20         327  
562             }
563              
564 8 100       36 if ($attribute) {
565 223         596 return grep {defined} map {
566 2         6 my $r;
  9         15  
567 9         14 eval { $r = $_->$attribute };
  9         81  
568 9 50       63 $@ ? undef : ref($r) eq 'ARRAY' ? @$r : $r
    100          
569             } @objects;
570             }
571             else {
572 6         19 return grep {defined} @objects;
  22         101  
573             }
574             }
575              
576             # Allows me to pass in queries without having all the automatic options added
577             # up to it.
578             sub __query
579             {
580 9     9   30 my ($self, $query) = @_;
581              
582 9         55 $self->connect;
583              
584             # die "Not connected" unless $self->is_connected;
585              
586 9 50       970 if ($self->ios->can_write(SOON + $self->timeout)) {
587 9         743 $self->socket->print($query, EOL);
588              
589             return Iterator->new(
590             sub {
591 66     66   1368 local $/ = END_OF_OBJECT_MARK;
592 66 50       239 if ($self->ios->can_read(SOON + $self->timeout)) {
593 66         334976 my $block = $self->socket->getline;
594 66 100       356466 return $block if defined $block;
595             }
596 8         47 Iterator::is_done;
597             }
598 9         1949 );
599             }
600             }
601              
602             =head2 B
603              
604             Return a list of known object types from the RIPE Database.
605              
606             RIPE currently returns 21 types (Limerik have been removed):
607             as-block as-set aut-num domain filter-set inet6num inetnum inet-rtr irt
608             key-cert mntner organisation peering-set person poem poetic-form role route
609             route6 route-set rtr-set
610              
611             Due to some strange mis-behaviour in the protocol (or documentation?) the RIPE
612             Database server won't allow a keep-alive token with this query, meaning the
613             connection will be terminated after this query.
614              
615             =cut
616              
617             sub object_types
618             {
619 1     1 1 744 my $self = shift;
620 1         4 my $iterator = $self->__query(QUERY_LIST_OBJECTS);
621 1         70 while (!$iterator->is_exhausted) {
622 2         30 my $value = $iterator->value;
623 2 100       100 return split /\s+/, $value if $value !~ /^%\s/;
624             }
625 0           return;
626             }
627              
628             =head2 B<_process_response( $response )>
629              
630             Process a response (error code, error message...)
631              
632             =cut
633              
634             sub _process_response
635             {
636 0     0     my $self = shift;
637 0           my $response = shift;
638 0           my $code;
639             my $msg;
640              
641 0           eval { $response->comment };
  0            
642 0 0         die "Dump : " . Dumper $response if $@;
643              
644 0 0         if ($response->response =~ /ERROR.*:.*?(\d+)/) {
645 0           $code = $1;
646 0           $msg = join '', $response->comment();
647             }
648             }
649              
650             =head1 AUTHOR
651              
652             Arnaud "Arhuman" Assad, C<< >>
653              
654             =head1 CAVEATS
655              
656             =over 4
657              
658             =item B
659              
660             Update of objects from database other than RIPE is not currently implemented...
661              
662             =item B
663              
664             Currently the only sources implemented are RIPE, AFRINIC, and APNIC.
665              
666             =item B
667              
668             The Net::Whois::Generic interface is highly experimental.
669             There are probably bugs, without any doubt missing documentation and
670             examples but please don't hesitate to contact me to suggest corrections
671             and improvments.
672              
673             =back
674              
675             =head1 BUGS
676              
677             Please report any bugs or feature requests to C
678             rt.cpan.org>, or through the web interface at
679             L. I will be
680             notified, and then you'll automatically be notified of progress on your bug as
681             I make changes.
682              
683             =head1 SEE ALSO
684              
685             There are several tools similar to L, I'll list some of them below and some reasons why Net::Whois::Generic exists anyway:
686              
687             L - A universal WHOIS extractor: update not possible, no RPSL parser
688              
689             L - ARIN whois client: update not possible, only subset of ARIN objects handled
690              
691             L - Module for parsing whois information: no query handling, parser can (must?) be added
692              
693             L - RIPE whois client: the basis for L but only handle RIPE.
694            
695             =head1 SUPPORT
696              
697             You can find documentation for this module with the perldoc command.
698              
699             perldoc Net::Whois::Generic
700              
701             You can also look for information at:
702              
703             =over 4
704              
705             =item * RT: CPAN's request tracker
706              
707             L
708              
709             =item * AnnoCPAN: Annotated CPAN documentation
710              
711             L
712              
713             =item * CPAN Ratings
714              
715             L
716              
717             =item * Search CPAN
718              
719             L
720              
721             =back
722              
723              
724             =head1 ACKNOWLEDGEMENTS
725              
726             Thanks to Jaguar Networks which grants me time to work on this module.
727              
728             =head1 COPYRIGHT & LICENSE
729              
730             Copyright 2013 Arnaud "Arhuman" Assad, all rights reserved.
731              
732             This program is free software; you can redistribute it and/or modify it
733             under the same terms as Perl itself.
734              
735             =cut
736              
737             1;