File Coverage

blib/lib/Net/Whois/Object.pm
Criterion Covered Total %
statement 229 316 72.4
branch 104 158 65.8
condition 28 52 53.8
subroutine 23 30 76.6
pod 12 12 100.0
total 396 568 69.7


line stmt bran cond sub pod time code
1             package Net::Whois::Object;
2 33     33   133017 use strict;
  33         78  
  33         924  
3 33     33   169 use warnings;
  33         59  
  33         781  
4              
5 33     33   172 use Carp;
  33         67  
  33         2000  
6 33     33   14396 use IPC::Open2 qw/open2/;
  33         110657  
  33         2070  
7 33     33   249 use List::Util qw/max/;
  33         69  
  33         3405  
8 33     33   18608 use Data::Dumper;
  33         207029  
  33         3352  
9              
10             our $LWP;
11              
12             BEGIN {
13 33     33   153 $LWP = do {
14 33         61 eval { require LWP::UserAgent; };
  33         21622  
15 33 50       1567665 ($@) ? 0 : 1;
16             };
17             }
18              
19             =head1 NAME
20              
21             Net::Whois::Object - Object encapsulating RPSL data returned by Whois queries
22              
23             =head1 SYNOPSIS
24              
25             use Net::Whois::RIPE;
26              
27             my @objects = Net::Whois::Generic->query('AS30781');
28              
29             # Or you can use the previous way
30              
31             my $whois = Net::Whois::RIPE->new( %options );
32             $iterator = $whois->query('AS30781');
33              
34             push @objects, Net::Whois::Object->new($iterator);
35              
36             for my $object (@objects) {
37             # process Net::Whois::Object::xxx objects...
38             # Type of object is available via class() method
39             }
40              
41             =head1 USAGE
42              
43             =head2 Get the data
44              
45             # Get the Class we want to modify
46             my $whois = Net::Whois::RIPE->new( %options );
47             $iterator = $whois->query('POLK-RIPE');
48              
49             =head2 Filter objects
50              
51             Before you had to filter objects using the class() method.
52              
53             # Then to only get the Person object (and ignore Information objects)
54             my ($person) = grep {$_->class() eq 'Person'} Net::Whois::Object->new($iterator);
55              
56             But now the query() from Net::Whois::Generic method allows you to filter more easily
57              
58             my ($person) = Net::Whois::Generic->query('POLK-RIPE', { type => 'person' });
59              
60             You can even use the query() filtering capabilities a little further
61              
62             my @emails = Net::Whois::Generic->query('POLK-RIPE', { type => 'person', attribute => 'e_mail' });
63              
64             Please note, that as soon as you use the attribute filter, the values returned
65             are strings and no more Net::Whois::Objects.
66              
67             =head2 Modify the data
68              
69             # Add a phone number
70             $person->phone(' +33 4 88 00 65 15');
71              
72             Some attributes can have multiple values (remarks, mnt-by...) first implementation allowed only to
73             add one value
74              
75             # Add one maintener
76             $person->mnt_by('CPNY-MNT');
77            
78             New implementation (post 2.00020) allow to do:
79              
80             $person->mnt_by({mode => 'append', value => 'CPNY-MNT'});
81              
82             Which is a verbose way to do exactly as the default mode above, but also
83              
84             # Append multiple values at once
85             $person->mnt_by({mode => 'append', value => ['CPNY-MNT2','CPNY-MNT3']});
86              
87             Or even
88              
89             # Replace CPNY-MNT2 by REPL-MNT
90             $person->mnt_by({mode => 'replace', value => {old => 'CPNY-MNT2', new => 'REPL-MNT'}});
91              
92             From release 2.002 you can also use the 'delete' mode to remove a specific attribute value
93              
94             $person->mnt_by({mode => 'delete', value => {old => 'REPL-MNT'}});
95            
96             # Or if you want to remove all remarks (the regex '.' meaning any char, will match all remarks values)
97             $person->remarks({mode => 'delete', value => {old => '.'}});
98              
99              
100             =head2 Dump the current state of the data
101              
102             The dump() method, enable to print the object under the classic
103             text form, made of 'attribute: value' lines.
104              
105             # Dump the modified data
106             my $to_be_mailed = $person->dump();
107              
108             dump() handle the 'align' parameter passed though a hash ref.
109              
110             my $to_be_mailed = $person->dump( { align => 15 });
111              
112             =head2 Update the RIPE database
113              
114             The RIPE database update is currently under heavy development.
115              
116             B<*The update code is still to be considered as experimental.*>
117              
118             We plan to offer several ways to update the RIPE database
119              
120             =head3 Update through the web interface
121              
122             RIPE provides several web interfaces
123              
124             =head4 SyncUpdates (*Experimental*)
125              
126             Although not the latest one, this simple interface is the first to be wrapped
127             by this module.
128              
129             B
130              
131             =head4 Create
132              
133             Once the object has been modified, locally, you can create it in the database
134             calling the syncupdates_create() method.
135              
136             The parameters are passed through a hash ref, and can be the maintener
137             authentication credentials ('password' or 'pgpkey') and the 'align' parameter
138              
139             $object->person('John Doe');
140             ...
141             my $primary_key = $object->syncupdates_create( { password => $password } );
142             # or
143             my $primary_key = $object->syncupdates_create( { pgpkey => $keyID, align => 8 } );
144              
145             The pgp key must be an eight digit hexadecimal key ID known to the local
146             C executable.
147              
148             If the C key is present in the hash reference passed to
149             syncupdates_create, you can also pass in the C key to chose a program
150             to execute for signing (C by default), and C, which must be an
151             array reference of additional options to pass to the signing binary.
152              
153             The primary key of the object created is returned.
154             The attribute used as primary key can be obtained through
155             C<$object->attribute('primary')>
156              
157             =head4 Update
158              
159             An object existing in the RIPE database, can be retrieved, modified locally
160             and then updated through the syncupdates_update() method.
161              
162             Parameters are passed through a hash ref, and can be the maintener
163             authentication credentials ('password' or 'pgpkey') and the 'align' parameter
164             See L for more information on the authentication methods.
165              
166             $object->person('John Doe');
167             ...
168             $object->syncupdates_update( { password => $password } );
169              
170             =head4 Delete
171              
172             An object existing in the RIPE database, can be retrieved, and deleted in
173             the databased through the syncupdates_delete() method.
174             Parameters are passed through a hash ref, and can be the maintener
175             authentication credentials ('password' or 'pgpkey') and the 'reason' parameter
176             See L for more information on the authentication methods.
177              
178             $object->syncupdates_delete( { pgpkey => $keyID } );
179              
180             An additional parameter can be used as a reason for the deletion.
181              
182             $object->syncupdates_delete( { pgpkey => $keyID, reason => 'Obsoleted by XXX' } );
183              
184             If no reason is provided, a default one ('Not needed anymore') is used.
185            
186             =head3 Update through email.
187              
188             Not implemented yet.
189              
190             =head1 SUBROUTINES/METHODS
191              
192             =head2 B
193              
194             The constructor is a factory returning the appropriate Net::Whois::Objects
195             based on the first attribute of the block.
196             You can pass an array of lines or an iterator returned by Net::Whois::RIPE
197             as argument.
198              
199             The two following ways of using the constructor are possible
200              
201             my $whois = Net::Whois::RIPE->new( %options );
202             $iterator = $whois->query('AS30781');
203              
204             # Using the iterator way
205             push @objects, Net::Whois::Object->new($iterator);
206              
207             or
208              
209             # Using the previous (more circonvoluted) @lines way
210              
211             while ( ! $iterator->is_exhausted() ) {
212             my @lines = map { "$_\n"} split '\n', $iterator->value();
213             push @objects, Net::Whois::Object->new(@lines,"\n");
214             }
215              
216             =cut
217              
218             sub new {
219 36     36 1 5097 my ( $class, @lines ) = @_;
220              
221             # If an iterator is passed as argument convert it to lines.
222 36 100       221 if ( ref $lines[0] eq 'Iterator' ) {
223 8         23 my $iterator = shift @lines;
224 8         44 while ( !$iterator->is_exhausted() ) {
225 55         401 push @lines, map {"$_\n"} split '\n', $iterator->value();
  4614         9295  
226 55         6595 push @lines, $/;
227             }
228             }
229              
230 36         152 my ( $attribute, $block, $object, @results, $value );
231              
232 36         151 for my $line (@lines) {
233 5186 50       7428 next if !defined($line);
234              
235 5186 100       14507 if ( $line =~ /^%(\S+)/ ) {
    100          
    100          
    100          
    50          
236              
237 1 50       4 $block = 'response' unless $block;
238              
239             # Response line
240 1         2 $attribute = 'response';
241 1         3 $value = $1;
242              
243             } elsif ( $line =~ /^(\S+):\s*(.*)/ ) {
244              
245             # Attribute line
246 5022         7834 $attribute = $1;
247 5022         6620 $value = $2;
248              
249             } elsif ( $line =~ /^%\s+(.*)/ ) {
250              
251 70 100       157 $block = 'comment' unless $block;
252              
253             # Comment line
254 70         110 $attribute = 'comment';
255 70         166 $value = $1;
256              
257             } elsif ( $line =~ /^[^%]\s*(.+)/ ) {
258              
259             # Continuation line
260 1         2 $value = $1;
261              
262             } elsif ( $line =~ /^$/ ) {
263              
264             # Blank line
265 92 100       208 if ($object) {
266 80         284 $object = _object_factory( $object->{block}, $object->{value}, $object );
267 80         175 push @results, $object;
268 80         138 $attribute = undef;
269 80         115 $block = undef;
270 80         125 $object = undef;
271             }
272 92         216 next;
273              
274             }
275              
276             # Normalize attribute to Perl's sub name standards
277 5094 50       9057 $attribute =~ s/-/_/g if $attribute;
278              
279             # First attribute determine the block
280 5094 100       7219 $block = $attribute unless $block;
281              
282 5094 100       6499 if ( !$object ) {
283 80         350 $object = { block => $block, value => $value, attributes => [] };
284              
285             # $object = _object_factory( $block, $value ) unless $object;
286             # } elsif ( $object->can($attribute) ) {
287             # $object->$attribute($value);
288 80 100       233 if ( $block eq 'comment' ) {
289              
290             # push @{$object->{attributes}},[ 'comment', $value ];
291 40         80 next;
292             }
293             }
294              
295             # } else {
296 5054         5320 push @{ $object->{attributes} }, [ $attribute, $value ];
  5054         10334  
297              
298             # } else {
299             # warn "Objects of type " . ref($object) . " do not support attribute '$attribute', but it was supplied with value '$value'\n";
300             # }
301              
302             }
303              
304             # TODO: fix the trailing undef
305 36         108 return grep {defined} @results;
  80         590  
306             }
307              
308             =head2 B
309              
310             Return a clone from a Net::Whois::RIPE object
311              
312             Current allowed option is remove => [attribute1, ..., attributen] where the specified
313             attribute AREN'T copied to the clone object (for example to ignore the 'changed' values)
314              
315             =cut
316              
317             sub clone {
318 3     3 1 1969 my ( $self, $rh_options ) = @_;
319              
320 3         4 my $clone;
321             my %filtered;
322              
323 3         13 for my $option ( keys %$rh_options ) {
324 2 50       11 if ( $option =~ /remove/i ) {
325 2         4 for my $att ( @{ $rh_options->{$option} } ) {
  2         6  
326 6         15 $filtered{ lc $att } = 1;
327             }
328             } else {
329 0         0 croak "Unknown option $option used while cloning a ", ref $self;
330             }
331             }
332              
333 3         5 my @lines;
334 3         10 my @tofilter = split /\n/, $self->dump;
335              
336 3         9 for my $line (@tofilter) {
337 39 100 66     177 if ( $line =~ /^(.+?):/ and $filtered{ lc $1 } ) {
338 18         25 next;
339             }
340 21         41 push @lines, $line;
341              
342             }
343              
344 3         6 eval { ($clone) = Net::Whois::Object->new( @lines, $/ ); };
  3         10  
345 3 50       9 croak $@ if $@;
346              
347 3         15 return $clone;
348             }
349              
350             =head2 B
351              
352             Accessor to the attributes of the object.
353             C<$type> can be
354              
355             'primary' Primary/Lookup key
356             'mandatory' Required for update creation
357             'optional' Optionnal for update/creation
358             'multiple' Can have multiple values
359             'single' Have only one value
360             'all' You can't specify attributes for this special type
361             which provides all the attributes which have a type
362              
363             If no C<$type> is specified, 'all' is assumed.
364             Returns a list of attributes of the required type.
365              
366             =cut
367              
368             sub attributes {
369 502     502 1 80207 my ( $self, $type, $ra_attributes ) = @_;
370 502 100 100     2802 if ( not defined $type or $type =~ /all/i ) {
371 58         276 return ( $self->attributes('mandatory'), $self->attributes('optional') );
372             }
373 444 50       2559 croak "Invalid attribute's type ($type)" unless $type =~ m/(all|primary|mandatory|optional|single|multiple)/i;
374 444 100       973 if ($ra_attributes) {
375 185         244 for my $a ( @{$ra_attributes} ) {
  185         358  
376 1211         2019 $self->_TYPE()->{$type}{$a} = 1;
377             }
378             }
379 444 100 100     1616 if ( $type eq 'single' || $type eq 'multiple' ) {
380 121         217 my $symbol_table = do {
381 33     33   327 no strict 'refs';
  33         80  
  33         4395  
382 121         179 \%{ $self . '::' };
  121         633  
383             };
384              
385 121         220 for my $a ( @{$ra_attributes} ) {
  121         257  
386 588 100       1208 unless ( exists $symbol_table->{$a} ) {
387 581 100   5767   1874 my $accessor = $type eq 'single' ? sub { _single_attribute_setget( $_[0], $a, $_[1] ) } : sub { _multiple_attribute_setget( $_[0], $a, $_[1] ) };
  472         5387  
  6246         14258  
388 33     33   252 no strict 'refs';
  33         82  
  33         93444  
389 581         836 *{"${self}::$a"} = $accessor;
  581         2492  
390             }
391             }
392             }
393 444         700 return sort keys %{ $self->_TYPE()->{$type} };
  444         1243  
394             }
395              
396             =head2 B
397              
398             This method return the RIPE class associated to the current object.
399              
400             =cut
401              
402             sub class {
403 91     91 1 4305 my ( $self, $value ) = @_;
404              
405 91         306 return $self->_single_attribute_setget( 'class', $value );
406             }
407              
408             =head2 B
409              
410             This method return true if C<$attribute> is of type C<$type>
411              
412             =cut
413              
414             sub attribute_is {
415 3705     3705 1 378340 my ( $self, $attribute, $type ) = @_;
416              
417 3705 100       6997 return defined $self->_TYPE()->{$type}{$attribute} ? 1 : 0;
418             }
419              
420             =head2 B
421              
422             Accessor to the filtered_attributes attribute (attributes to be hidden)
423             Accepts an optional attribute to be added to the filtered_attributes array,
424             always return the current filtered_attributes array.
425              
426             =cut
427              
428             sub filtered_attributes {
429 0     0 1 0 my ( $self, $filtered_attributes ) = @_;
430 0 0       0 push @{ $self->{filtered_attributes} }, $filtered_attributes if defined $filtered_attributes;
  0         0  
431 0         0 return @{ $self->{filtered_attributes} };
  0         0  
432             }
433              
434             =head2 B
435              
436             Accessor to the displayed_attributes attribute which should be displayed.
437             Accepts an optional attribute to be added to the displayed_attributes array,
438             always return the current displayed_attributes array.
439              
440             =cut
441              
442             sub displayed_attributes {
443 0     0 1 0 my ( $self, $displayed_attributes ) = @_;
444 0 0       0 push @{ $self->{displayed_attributes} }, $displayed_attributes if defined $displayed_attributes;
  0         0  
445 0         0 return @{ $self->{displayed_attributes} };
  0         0  
446             }
447              
448             =head2 B
449              
450             Simple naive way to display a text form of the class.
451             Try to be as close as possible as the submited text.
452              
453             Currently the only option available is 'align' which accept a C<$column> number as
454             parameter so that all C<< $self->dump >> produces values that are aligned
455             vertically on column C<$column>.
456              
457             =cut
458              
459             sub dump {
460 34     34 1 6625 my ( $self, $options ) = @_;
461              
462 34         147 my %current_index;
463             my $result;
464 34         0 my $align_to;
465              
466 34         134 for my $opt ( keys %$options ) {
467 2 50       15 if ( $opt =~ /^align$/i ) {
468 2         6 $align_to = $options->{$opt};
469              
470             } else {
471              
472 0         0 croak "Unknown option $opt for dump()";
473             }
474             }
475              
476 34   66     307 $align_to ||= 5 + max map length, $self->attributes('all');
477              
478 34         98 for my $line ( @{ $self->{order} } ) {
  34         117  
479 728         1056 my $attribute = $line;
480 728         1395 $attribute =~ s/_/-/g;
481              
482 728         1634 my $val = $self->$line();
483              
484 728 100       1662 if ( ref $val eq 'ARRAY' ) {
485              
486             # If multi value get the lines in order
487 627         1283 $val = $val->[ $current_index{$line}++ ];
488             }
489              
490 728 100       1216 $val = '' unless $val;
491              
492 728         1248 my $alignment = ' ' x ( $align_to - length($attribute) - 1 );
493 728         1379 my $output = "$attribute:$alignment$val\n";
494              
495             # Process the comment
496 728         1154 $output =~ s/comment:\s*/\% /;
497              
498 728         1485 $result .= $output;
499             }
500              
501 34         325 return $result;
502             }
503              
504             =head2 B
505              
506             Update the RIPE database through the web syncupdates interface.
507             Use the password passed as parameter to authenticate.
508              
509             =cut
510              
511             sub syncupdates_update {
512 0     0 1 0 my ( $self, $options ) = @_;
513              
514 0         0 my $dump_options;
515              
516 0         0 for my $opt ( keys %$options ) {
517 0 0       0 if ( $opt =~ /^align$/i ) {
518 0         0 $dump_options = { align => $options->{$opt} };
519             }
520             }
521              
522 0         0 my ($key) = $self->attributes('primary');
523 0         0 my $value = $self->_single_attribute_setget($key);
524              
525 0         0 my $html = $self->_syncupdates_submit( $self->dump($dump_options), $options );
526              
527 0 0       0 if ( $html =~ /Modify SUCCEEDED:.*$value/m ) {
528 0         0 return $value;
529             } else {
530 0         0 croak "Update not confirmed ($html)";
531             }
532             }
533              
534             =head2 B
535              
536             Delete the object in the RIPE database through the web syncupdates interface.
537             Use the password passed as parameter to authenticate.
538             The optional parmeter reason is used to explain why the object is deleted.
539              
540             =cut
541              
542             sub syncupdates_delete {
543 0     0 1 0 my ( $self, $options ) = @_;
544              
545 0         0 my ($key) = $self->attributes('primary');
546 0         0 my $value = $self->_single_attribute_setget($key);
547              
548 0         0 my $text = $self->dump();
549 0 0       0 $options->{reason} = 'Not needed anymore' unless $options->{reason};
550 0         0 $text .= "delete: " . $options->{reason} . "\n";
551              
552 0         0 my $html = $self->_syncupdates_submit( $text, $options );
553              
554 0 0       0 if ( $html =~ /Delete SUCCEEDED:.*$value/m ) {
555 0         0 return $value;
556             } else {
557 0         0 croak "Deletion not confirmed ($html)";
558             }
559             }
560              
561             =head2 B
562              
563             Create an object in the the RIPE database through the web syncupdates interface.
564             See L for more information on the authentication methods.
565              
566             The available options are 'pgpkey', 'password' and 'align'
567              
568             Return the primary key of the object created.
569              
570             =cut
571              
572             sub syncupdates_create {
573 0     0 1 0 my ( $self, $options ) = @_;
574              
575 0         0 my $dump_options;
576              
577 0         0 for my $opt ( keys %$options ) {
578 0 0       0 if ( $opt =~ /^align$/i ) {
579 0         0 $dump_options = { align => $options->{$opt} };
580             }
581             }
582              
583 0         0 my $res = $self->_syncupdates_submit( $self->dump($dump_options), $options );
584              
585 0 0 0     0 if ( $res =~ /^Number of objects processed with errors:\s+(\d+)/m
      0        
      0        
586             && $1 == 0
587             && ( $res =~ /\*\*\*Info:\s+Authorisation for\s+\[[^\]]+]\s+(.+)\s*$/m
588             || $res =~ /(?:Create SUCCEEDED|No operation): \[[^\]]+\]\s+(\S+)/m )
589             )
590             {
591 0         0 my $value = $1;
592 0         0 my ($key) = $self->attributes('primary');
593              
594             # some primary keys can contain spaces, in which case $value
595             # is not correct. So only use it for objects where the primary
596             # key can be generated by the RIPE DB, and where it never contains
597             # spaces. According to
598             # http://www.ripe.net/ripe/mail/archives/db-help/2013-January/000411.html
599             # this is the case for person, organization, role and key-cert
600 0         0 my %obj_types_with_autogen_key = ( KeyCert => 1,
601             Organisation => 1,
602             Person => 1,
603             Role => 1,
604             );
605 0 0 0     0 if ( $self->class && $obj_types_with_autogen_key{ $self->class } ) {
606 0         0 $self->_single_attribute_setget( $key, $value );
607 0         0 return $value;
608             } else {
609 0         0 return $self->$key();
610             }
611             } else {
612 0         0 croak "Error while creating object through syncupdates API: $res";
613             }
614             }
615              
616             =head2 B
617              
618             This method is deprecated since release 2.005 of Net::Whois::RIPE
619              
620             Please use Net::Whois::Generic->query() instead.
621              
622             =cut
623              
624             sub query {
625              
626 1     1 1 119 croak "This method is deprecated since release 2.005 of Net::Whois::RIPE\nPlease use Net::Whois::Generic->query() instead\n";
627              
628             }
629              
630             =begin UNDOCUMENTED
631              
632             =head2 B<_object_factory( $type => $value, $attributes_hashref )>
633              
634             Private method. Shouldn't be used from other modules.
635              
636             Simple factory, creating Net::Whois::Objet::XXXX from
637             the type passed as parameter.
638              
639             =cut
640              
641             sub _object_factory {
642 80     80   155 my $type = shift;
643 80         131 my $value = shift;
644 80         132 my $object = shift;
645 80         142 my $rir;
646              
647             my $object_returned;
648              
649 80         1244 my %class = ( as_block => 'AsBlock',
650             as_set => 'AsSet',
651             aut_num => 'AutNum',
652             comment => 'Information',
653             domain => 'Domain',
654             filter_set => 'FilterSet',
655             inet6num => 'Inet6Num',
656             inetnum => 'InetNum',
657             inet_rtr => 'InetRtr',
658             irt => 'Irt',
659             key_cert => 'KeyCert',
660             limerick => 'Limerick',
661             mntner => 'Mntner',
662             organisation => 'Organisation',
663             peering_set => 'PeeringSet',
664             person => 'Person',
665             poem => 'Poem',
666             poetic_form => 'PoeticForm',
667             response => 'Response',
668             role => 'Role',
669             route6 => 'Route6',
670             route => 'Route',
671             route_set => 'RouteSet',
672             rtr_set => 'RtrSet',
673             );
674              
675 80 50 33     466 die "Unrecognized Object (first attribute: $type = $value)\n" . Dumper($object) unless defined $type and $class{$type};
676              
677 80         223 my $class = "Net::Whois::Object::" . $class{$type};
678              
679 80         164 for my $a ( @{ $object->{attributes} } ) {
  80         254  
680 5054 100       7667 if ( $a->[0] =~ /source/ ) {
681 38         96 $rir = $a->[1];
682 38         164 $rir =~ s/^(\S+)\s*#.*/$1/;
683 38         106 $rir = uc $rir;
684 38 100       282 $rir = undef if $rir =~ /^(RIPE|TEST)$/; # For historical/compatibility reason RIPE objects aren't derived
685             }
686             }
687              
688 80 100       274 $class .= "::$rir" if $rir;
689              
690 80 50       5300 eval "require $class" or die "Can't require $class ($!)";
691              
692             # my $object = $class->new( $type => $value );
693 80         505 $object_returned = $class->new( class => $class{$type} );
694              
695             # First attribute is always single valued, except for comments
696 80 100       242 if ( $type eq 'comment' ) {
697 40         100 $object_returned->_multiple_attribute_setget( $type => $value );
698             } else {
699 40         119 $object_returned->_single_attribute_setget( $type => $value );
700             }
701              
702 80 50       230 if ( $object->{attributes} ) {
703 80         131 for my $a ( @{ $object->{attributes} } ) {
  80         205  
704 5054         5885 my $method = $a->[0];
705 5054 50       5524 if( my $ref = eval { $object_returned->can( $method ) } ) {
  5054         10204  
706 5054         6919 $object_returned->$ref( $a->[1] );
707             } else {
708 0         0 carp "Unknown method '$method' for object $class (Did the Database schema changed ?)"
709             }
710             }
711             }
712              
713             # return $class->new( $type => $value );
714 80         1228 return $object_returned;
715              
716             }
717              
718             =head2 B<_single_attribute_setget( $attribute )>
719              
720             Generic setter/getter for singlevalue attribute.
721              
722             =cut
723              
724             sub _single_attribute_setget {
725 627     627   1494 my ( $self, $attribute, $value ) = @_;
726 627         966 my $mode = 'replace';
727              
728 627 100       1321 if ( ref $value eq 'HASH' ) {
729 1         5 my %options = %$value;
730              
731 1 50       5 if ( $options{mode} ) {
732 1         2 $mode = $options{mode};
733             }
734              
735 1 50       4 if ( $options{value} ) {
736 1         2 $value = $options{value};
737             } else {
738 0         0 croak "Unable to determine attribute $attribute value";
739             }
740              
741             }
742              
743 627 100       1140 if ( defined $value ) {
744              
745 356 100       752 if ( $mode eq 'replace' ) {
    50          
746              
747             # Store attribute order for dump, unless this attribute as already been set
748 355 100 100     1334 push @{ $self->{order} }, $attribute unless $self->{$attribute} or $attribute eq 'class';
  157         434  
749              
750 355         770 $self->{$attribute} = $value;
751             } elsif ( $mode eq 'delete' ) {
752 1 50 33     8 if ( ref $value ne 'HASH' or !$value->{old} ) {
753 0         0 croak " {old=>...} expected as value for $attribute update in delete mode";
754             } else {
755 1         4 $self->_delete_attribute( $attribute, $value->{old} );
756             }
757             }
758             }
759 627         2001 return $self->{$attribute};
760             }
761              
762             =head2 B<_multiple_attribute_setget( $attribute )>
763              
764             Generic setter/getter for multivalue attribute.
765              
766             =cut
767              
768             sub _multiple_attribute_setget {
769 6296     6296   9690 my ( $self, $attribute, $value ) = @_;
770 6296         7292 my $mode = 'append';
771              
772 6296 100       10205 if ( ref $value eq 'HASH' ) {
773 10         36 my %options = %$value;
774              
775 10 100       28 if ( $options{mode} ) {
776 8         13 $mode = $options{mode};
777             }
778              
779 10 50       22 if ( $options{value} ) {
780 10         21 $value = $options{value};
781             } else {
782 0         0 croak "Unable to determine attribute $attribute value";
783             }
784              
785             }
786              
787 6296 100       9038 if ( defined $value ) {
788              
789 5194 100       6829 if ( $mode eq 'append' ) {
    100          
    100          
790 5186 100       7651 if ( ref $value eq 'ARRAY' ) {
    50          
791 2         3 push @{ $self->{$attribute} }, @$value;
  2         6  
792 2         3 push @{ $self->{order} }, map {$attribute} @$value;
  2         6  
  4         9  
793             } elsif ( !ref $value ) {
794 5184         5485 push @{ $self->{$attribute} }, $value;
  5184         8430  
795 5184         5755 push @{ $self->{order} }, $attribute;
  5184         8424  
796             } else {
797 0         0 croak "Trying to append weird data to $attribute: ", $value;
798             }
799             } elsif ( $mode eq 'replace' ) {
800 3 100 66     23 if ( ref $value ne 'HASH' or !$value->{old} or !$value->{new} ) {
      100        
801 2         153 croak " {old=>..., new=>} expected as value for $attribute update in replace mode";
802             } else {
803 1         2 my $old = $value->{old};
804 1         2 for ( @{ $self->{$attribute} } ) {
  1         4  
805 4 100       28 $_ = $value->{new} if $_ =~ /$old/;
806             }
807             }
808             } elsif ( $mode eq 'delete' ) {
809 4 100 66     19 if ( ref $value ne 'HASH' or !$value->{old} ) {
810 1         86 croak " {old=>...} expected as value for $attribute update in delete mode";
811             } else {
812              
813             # $self->{$attribute} = [grep {!/$old/} @{$self->{$attribute}}];
814 3         13 $self->_delete_attribute( $attribute, $value->{old} );
815             }
816             } else {
817 1         173 croak "Unknown mode $mode for attribute $attribute";
818             }
819             }
820              
821 6292 50       10021 croak "$attribute $self" unless ref $self;
822 6292         12179 return $self->{$attribute};
823             }
824              
825             =head2 B<_delete_attribute( $attribute, $pattern )>
826              
827             Delete an attribute if its value match the pattern value
828              
829             =cut
830              
831             sub _delete_attribute {
832 4     4   9 my ( $self, $attribute, $pattern ) = @_;
833              
834 4         7 my @lines;
835              
836 4         6 for my $a ( @{ $self->{order} } ) {
  4         11  
837 36 100       69 my $val = ref $self->{$a} ? shift @{ $self->{$a} } : $self->{$a};
  28         41  
838 36         76 push @lines, [ $a, $val ];
839             }
840              
841 4 100       9 @lines = grep { $attribute ne $_->[0] or $_->[1] !~ /$pattern/ } @lines;
  36         150  
842 4 100 66     15 delete $self->{$attribute} if $self->attribute_is( $attribute, 'single' ) and $self->{$attribute} =~ /$pattern/;
843              
844 4         11 $self->{order} = [];
845 4         9 for my $l (@lines) {
846 30 100       71 $self->{ $l->[0] } = [] if ref( $self->{ $l->[0] } );
847             }
848              
849 4         11 for my $i ( 0 .. $#lines ) {
850 30         40 push @{ $self->{order} }, $lines[$i]->[0];
  30         51  
851 30 100       64 if ( $self->attribute_is( $lines[$i]->[0], 'multiple' ) ) {
852 23         33 push @{ $self->{ $lines[$i]->[0] } }, $lines[$i]->[1];
  23         56  
853             } else {
854 7         23 $self->{ $lines[$i]->[0] } = $lines[$i]->[1];
855              
856             }
857              
858             }
859              
860             }
861              
862             =head2 B<_init( @options )>
863              
864             Initialize self with C<@options>
865              
866             =cut
867              
868             sub _init {
869 81     81   219 my ( $self, @options ) = @_;
870              
871 81         348 while ( my ( $key, $val ) = splice( @options, 0, 2 ) ) {
872 95         357 $self->$key($val);
873             }
874             }
875              
876             =head2 B<_syncupdates_submit( $text, \%options )>
877              
878             Interact with the RIPE database through the web syncupdates interface.
879             Submit the text passed as parameter.
880             Use the password passed as parameter to authenticate.
881             The database used is chosen based on the 'source' attribute.
882              
883             Return the HTML code of the returned page.
884             (This will change in a near future)
885              
886             =cut
887              
888             sub _syncupdates_submit {
889 0     0   0 my ( $self, $text, $options ) = @_;
890              
891 0 0       0 if ( exists $options->{pgpkey} ) {
    0          
892 0         0 $text = $self->_pgp_sign( $text, $options );
893             } elsif ( exists $options->{password} ) {
894 0         0 my $password = $options->{password};
895 0         0 chomp $password;
896 0 0       0 croak("Passwords containing newlines are not supported")
897             if $password =~ /\n/;
898 0         0 $text .= "password: $password\n";
899             }
900              
901 0 0       0 croak "LWP::UserAgent required for updates" unless $LWP;
902              
903 0 0       0 my $url = $self->source eq 'RIPE' ? 'http://syncupdates.db.ripe.net/' : 'http://syncupdates-test.db.ripe.net';
904              
905 0         0 my $ua = LWP::UserAgent->new;
906              
907 0         0 my $response = $ua->post( $url, { DATA => $text } );
908 0         0 my $response_text = $response->decoded_content;
909              
910 0 0       0 unless ( $response->is_success ) {
911 0         0 croak "Can't sync object with RIPE database: $response_text";
912             }
913              
914 0         0 return $response_text;
915             }
916              
917             =head2 B<_pgp_sign( $text, $auth )>
918              
919             Sign the C<$text> with the C command and gpg information in C<$auth>
920             Returns the signed text.
921              
922             =cut
923              
924             sub _pgp_sign {
925 0     0   0 my ( $self, $text, $auth ) = @_;
926              
927 0   0     0 my $binary = $auth->{pgpexec} || 'gpg';
928 0         0 my $key_id = $auth->{pgpkey};
929 0 0       0 my @opts = @{ $auth->{pgpopts} || [] };
  0         0  
930              
931 0         0 $key_id =~ s/^0x//;
932 0         0 my $pid = open2( my $child_out, my $child_in, $binary, "--local-user=$key_id", '--clearsign', @opts );
933 0         0 print {$child_in} $text;
  0         0  
934 0         0 close $child_in;
935              
936 0         0 $text = do { local $/; <$child_out> };
  0         0  
  0         0  
937 0         0 close $child_out;
938              
939 0         0 waitpid( $pid, 0 );
940 0         0 my $child_exit_status = $? >> 8;
941 0 0       0 if ( $child_exit_status != 0 ) {
942 0         0 croak "Error while launching $binary for signing the message: child process exited with status $child_exit_status";
943             }
944              
945 0         0 return $text;
946             }
947              
948             =head2 B<_TYPE>
949              
950             Returns a hash ref that contains the attribute data for the class
951             of the object that the method was called on.
952              
953             =end UNDOCUMENTED
954              
955             =cut
956              
957             my %TYPES;
958              
959             sub _TYPE {
960 5360   66 5360   28487 $TYPES{ ref $_[0] || $_[0] } ||= {};
      100        
961             }
962              
963             =head1 SEE ALSO
964              
965             Please take a look at L the more generic whois client built on top of Net::Whois::RIPE.
966              
967             =head1 TODO
968              
969             The update part (in RIPE database) still needs a lot of work.
970              
971             Enhance testing without network
972              
973             Enhance test coverage
974              
975             =head1 AUTHOR
976              
977             Arnaud "Arhuman" Assad, C<< >>
978              
979             =head1 ACKNOWLEDGEMENTS
980              
981             Thanks to Jaguar Network for allowing me to work on this during some of my office
982             hours.
983              
984             Thanks to Luis Motta Campos for his trust when allowing me to publish this
985             release.
986              
987             Thanks to Moritz Lenz for all his contributions
988             (Thanks also to 'Noris Network AG', his employer, for allowing him to contribute in the office hours)
989              
990             =cut
991              
992             1;