File Coverage

blib/lib/Net/DRI/Protocol/BookMyName/WS/Domain.pm
Criterion Covered Total %
statement 12 92 13.0
branch 0 54 0.0
condition 0 15 0.0
subroutine 4 11 36.3
pod 0 7 0.0
total 16 179 8.9


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, BookMyName Web Services Domain commands
2             ##
3             ## Copyright (c) 2008,2009,2013 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             ####################################################################################################
14              
15             package Net::DRI::Protocol::BookMyName::WS::Domain;
16              
17 1     1   652 use strict;
  1         1  
  1         22  
18 1     1   4 use warnings;
  1         1  
  1         19  
19              
20 1     1   3 use Net::DRI::Exception;
  1         1  
  1         13  
21 1     1   3 use Net::DRI::Util;
  1         1  
  1         710  
22              
23             =pod
24              
25             =head1 NAME
26              
27             Net::DRI::Protocol::BookMyName::WS::Domain - BookMyName Web Services Domain commands for Net::DRI
28              
29             =head1 DESCRIPTION
30              
31             Please see the README file for details.
32              
33             =head1 SUPPORT
34              
35             For now, support questions should be sent to:
36              
37             Enetdri@dotandco.comE
38              
39             Please also see the SUPPORT file in the distribution.
40              
41             =head1 SEE ALSO
42              
43             Ehttp://www.dotandco.com/services/software/Net-DRI/E
44              
45             =head1 AUTHOR
46              
47             Patrick Mevzek, Enetdri@dotandco.comE
48              
49             =head1 COPYRIGHT
50              
51             Copyright (c) 2008,2009,2013 Patrick Mevzek .
52             All rights reserved.
53              
54             This program is free software; you can redistribute it and/or modify
55             it under the terms of the GNU General Public License as published by
56             the Free Software Foundation; either version 2 of the License, or
57             (at your option) any later version.
58              
59             See the LICENSE file that comes with this distribution for more details.
60              
61             =cut
62              
63             ####################################################################################################
64              
65             sub register_commands
66             {
67 0     0 0   my ($class,$version)=@_;
68 0           my %tmp=(
69             info => [\&info, \&info_parse ],
70             check => [\&check, \&check_parse ],
71             );
72              
73 0           return { 'domain' => \%tmp };
74             }
75              
76             ## From http://api.doc.free.org/revendeur-de-nom-de-domaine#status
77             sub parse_status
78             {
79 0     0 0   my $s=shift;
80 0           my @s;
81 0 0         push @s,'clientDeleteProhibited' if ($s & 0x01);
82 0 0         push @s,'serverDeleteProhibited' if ($s & 0x02);
83 0 0         push @s,'clientHold' if ($s & 0x04);
84 0 0         push @s,'serverHold' if ($s & 0x08);
85 0 0         push @s,'clientRenewProhibited' if ($s & 0x10);
86 0 0         push @s,'serverRenewProhibited' if ($s & 0x20);
87 0 0         push @s,'clientTransferProhibited' if ($s & 0x40);
88 0 0         push @s,'serverTransferProhibited' if ($s & 0x80);
89 0 0         push @s,'clientUpdateProhibited' if ($s & 0x100);
90 0 0         push @s,'serverUpdateProhibited' if ($s & 0x200);
91 0 0         push @s,'pendingCreate' if ($s & 0x400);
92 0 0         push @s,'pendingDelete' if ($s & 0x800);
93 0 0         push @s,'pendingRenew' if ($s & 0x1000);
94 0 0         push @s,'pendingTransfer' if ($s & 0x2000);
95 0 0         push @s,'pendingUpdate' if ($s &0x4000);
96 0 0         return @s? @s : ('ok');
97             }
98              
99             sub build_msg
100             {
101 0     0 0   my ($msg,$command,$domain)=@_;
102 0 0 0       Net::DRI::Exception->die(1,'protocol/bookmyname/ws',2,'Domain name needed') unless defined($domain) && $domain;
103 0 0         Net::DRI::Exception->die(1,'protocol/bookmyname/ws',10,'Invalid domain name') unless Net::DRI::Util::is_hostname($domain);
104              
105 0 0         $msg->method($command) if defined($command);
106 0           return;
107             }
108              
109             sub info
110             {
111 0     0 0   my ($po,$domain)=@_;
112 0           my $msg=$po->message();
113 0           build_msg($msg,'domain_info',$domain);
114 0           $msg->params([ $domain ]);
115 0           return;
116             }
117              
118             sub info_parse
119             {
120 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
121 0           my $mes=$po->message();
122 0 0         return unless $mes->is_success();
123              
124 0           my $r=$mes->result();
125 0 0         Net::DRI::Exception->die(1,'protocol/bookmyname/ws',1,'Unexpected reply for domain_info: '.$r) unless (ref($r) eq 'HASH');
126              
127 0           my %r=%$r;
128 0           $oname=lc($r{domain});
129 0           $rinfo->{domain}->{$oname}->{action}='info';
130 0           $rinfo->{domain}->{$oname}->{exist}=1;
131 0           $rinfo->{domain}->{$oname}->{roid}=$r{id};
132 0           my %d=(registrar_creation => 'crDate', lastupdate => 'upDate', registrar_expiration => 'exDate');
133 0           while (my ($k,$v)=each(%d))
134             {
135 0 0         next unless exists($r{$k});
136 0           $rinfo->{domain}->{$oname}->{$v}=$po->parse_iso8601($r{$k});
137             }
138 0           $rinfo->{domain}->{$oname}->{upIP}=$r{lastupdate_ip};
139 0           my %c=(owner_id => 'registrant', admin_id => 'admin', tech_id => 'tech', bill_id => 'billing');
140 0           my $cs=$po->create_local_object('contactset');
141 0           while (my ($k,$v)=each(%d))
142             {
143 0 0         next unless exists($r{$k});
144 0           my $c=$po->create_local_object('contact')->srid($r{$k});
145 0           $cs->add($c,$v);
146             }
147 0           $rinfo->{domain}->{$oname}->{contact}=$cs;
148 0           $rinfo->{domain}->{$oname}->{auth}={pw => $r{authinfo}};
149              
150 0           foreach my $k (qw/service ip_dns_master/)
151             {
152 0 0 0       $rinfo->{domain}->{$oname}->{$k}=$r{$k} if (exists($r{$k}) && defined($r{$k}));
153             }
154 0           my $sl=$po->create_local_object('status');
155 0           foreach my $s (parse_status($r{registry_status})) { $sl->add($s); }
  0            
156 0           $rinfo->{domain}->{$oname}->{status}=$sl;
157             ## $r{status} is not used, what is it ?
158              
159 0           my $ns=$po->create_local_object('hosts');
160 0           foreach my $nsk (sort { ($a=~m/^ns(\d+)/)[0] <=> ($b=~m/^ns(\d+)/)[0] } grep { /^ns\d+$/ } keys(%r)) { $ns->add($r{$nsk}); }
  0            
  0            
  0            
161 0           $rinfo->{domain}->{$oname}->{ns}=$ns;
162 0           return;
163             }
164              
165             sub check
166             {
167 0     0 0   my ($po,$domain)=@_;
168 0           my $msg=$po->message();
169 0           build_msg($msg,'domain_check',$domain);
170 0           $msg->params([ $domain ]);
171 0           return;
172             }
173              
174             sub check_parse
175             {
176 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
177 0           my $mes=$po->message();
178              
179 0 0 0       if ($mes->retcode()==-1 && ($mes->retval()==-2 || $mes->retval()==-4)) ## domain does not exist
      0        
180             {
181 0           $mes->retcode(1); ## fake a success
182             }
183 0 0         return unless $mes->is_success();
184              
185 0           $rinfo->{domain}->{$oname}->{action}='check';
186 0 0 0       $rinfo->{domain}->{$oname}->{exist}=($mes->retcode()==1 && $mes->retval()==1)? 1 : 0;
187 0           return;
188             }
189              
190             ####################################################################################################
191             1;