File Coverage

blib/lib/Net/DRI/Protocol/EPP.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, EPP Protocol (STD 69)
2             ##
3             ## Copyright (c) 2005-2011,2013-2014 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::EPP;
16              
17 55     55   2272 use utf8;
  55         90  
  55         389  
18 55     55   1525 use strict;
  55         77  
  55         1396  
19 55     55   228 use warnings;
  55         77  
  55         1450  
20              
21 55     55   216 use base qw(Net::DRI::Protocol);
  55         81  
  55         28781  
22              
23 55     55   443 use Net::DRI::Util;
  55         91  
  55         1161  
24 55     55   34650 use Net::DRI::Protocol::EPP::Message;
  0            
  0            
25             use Net::DRI::Protocol::EPP::Core::Status;
26              
27             =pod
28              
29             =head1 NAME
30              
31             Net::DRI::Protocol::EPP - EPP Protocol (STD 69 aka RFC 5730,5731,5732,5733,5734 and RFC 3735) for Net::DRI
32              
33             =head1 DESCRIPTION
34              
35             Please see the README file for details.
36              
37             =head1 SUPPORT
38              
39             For now, support questions should be sent to:
40              
41             Enetdri@dotandco.comE
42              
43             Please also see the SUPPORT file in the distribution.
44              
45             =head1 SEE ALSO
46              
47             Ehttp://www.dotandco.com/services/software/Net-DRI/E
48              
49             =head1 AUTHOR
50              
51             Patrick Mevzek, Enetdri@dotandco.comE
52              
53             =head1 COPYRIGHT
54              
55             Copyright (c) 2005-2011,2013-2014 Patrick Mevzek .
56             All rights reserved.
57              
58             This program is free software; you can redistribute it and/or modify
59             it under the terms of the GNU General Public License as published by
60             the Free Software Foundation; either version 2 of the License, or
61             (at your option) any later version.
62              
63             See the LICENSE file that comes with this distribution for more details.
64              
65             =cut
66              
67             ####################################################################################################
68              
69             sub new
70             {
71             my ($c,$ctx,$rp)=@_;
72             my $drd=$ctx->{registry}->driver();
73             my $self=$c->SUPER::new($ctx);
74             $self->name('EPP');
75             my $version=Net::DRI::Util::check_equal($rp->{version},['1.0'],'1.0');
76             $self->version($version);
77              
78             foreach my $o (qw/ip status/) { $self->capabilities('host_update',$o,['add','del']); }
79             $self->capabilities('host_update','name',['set']);
80             $self->capabilities('contact_update','status',['add','del']);
81             $self->capabilities('contact_update','info',['set']);
82             foreach my $o (qw/ns status contact/) { $self->capabilities('domain_update',$o,['add','del']); }
83             foreach my $o (qw/registrant auth/) { $self->capabilities('domain_update',$o,['set']); }
84              
85             $self->{hostasattr}=$drd->info('host_as_attr') || 0;
86             $self->{contacti18n}=$drd->info('contact_i18n') || 7; ## bitwise OR with 1=LOC only, 2=INT only, 4=LOC+INT only
87             $self->{defaulti18ntype}=undef; ## only needed for registries not following truely EPP standard, like .CZ
88             $self->{usenullauth}=$drd->info('use_null_auth') || 0; ## See RFC4931 ยง3.2.5
89             $self->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'],
90             domain => ['urn:ietf:params:xml:ns:domain-1.0','domain-1.0.xsd'],
91             contact => ['urn:ietf:params:xml:ns:contact-1.0','contact-1.0.xsd'],
92             });
93              
94             $drd->set_factories($self) if $drd->can('set_factories');
95             $self->factories('message',sub { my $m=Net::DRI::Protocol::EPP::Message->new(@_); $m->ns($self->ns()); $m->version($version); return $m; });
96             $self->factories('status',sub { return Net::DRI::Protocol::EPP::Core::Status->new(); });
97              
98             $self->_load($rp);
99             $self->setup($rp);
100             return $self;
101             }
102              
103             my $BASE='Net::DRI::Protocol::EPP::Extensions::';
104              
105             sub _load
106             {
107             my ($self,$rp)=@_;
108             my $extramods=$rp->{extensions};
109             my @class=$self->core_modules($rp);
110             push @class,map { $BASE.$_; } $self->default_extensions($rp) if $self->can('default_extensions');
111             push @class,map { my $f=$_; if ($f=~m/^([^+])(.+)$/) { $f = $1 eq '-' ? '-'.$BASE.$2 : $BASE.$1.$2; } $f; } (ref $extramods ? @$extramods : ($extramods)) if defined $extramods && $extramods;
112             return $self->SUPER::_load(@class);
113             }
114              
115             sub setup {} ## subclass as needed
116              
117             sub core_modules
118             {
119             my ($self,$rp)=@_;
120             my @core=qw/Session RegistryMessage Domain Contact/;
121             if (! $self->{hostasattr})
122             {
123             push @core,'Host';
124             $self->ns({host => ['urn:ietf:params:xml:ns:host-1.0','host-1.0.xsd']});
125             }
126             return map { 'Net::DRI::Protocol::EPP::Core::'.$_ } @core;
127             }
128              
129             sub core_contact_types { return qw/admin tech billing/; }
130              
131             sub ns
132             {
133             my ($self,$add)=@_;
134             $self->{ns}={ ref $self->{ns} ? %{$self->{ns}} : (), %$add } if defined $add && ref $add eq 'HASH';
135             return $self->{ns};
136             }
137              
138             ## Called during server greeting parse
139             sub switch_to_highest_namespace_version
140             {
141             my ($self,$nsalias)=@_;
142              
143             my ($basens)=($self->message()->ns($nsalias)=~m/^(\S+)-[\d.]+$/);
144             my $rs=$self->default_parameters()->{server};
145             my @ns=grep { m/^${basens}-\S+$/ } @{$rs->{extensions_selected}};
146             Net::DRI::Exception::err_invalid_parameters("No extension found under namespace ${basens}-*") unless @ns;
147              
148             my $version;
149             foreach my $ns (@ns)
150             {
151             my ($v)=($ns=~m/^\S+-([\d.]+)$/);
152             $version=0+$v if ! defined $version || 0+$v > $version;
153             }
154              
155             my $fullns=$basens.'-'.$version;
156             if (@ns > 1)
157             {
158             $self->log_output('info','protocol',{action=>'greeting',direction=>'in',trid=>$self->message()->cltrid(),message=>sprintf('More than one "%s" extension announced by server, selecting "%s"',$nsalias,$fullns)});
159             } else
160             {
161             $self->log_output('info','protocol',{action=>'greeting',direction=>'in',trid=>$self->message()->cltrid(),message=>sprintf('For "%s" extension, using "%s"',$nsalias,$fullns)});
162             }
163              
164             my $xsd=($self->message()->nsattrs($nsalias))[2];
165             $xsd=~s/-([\d.]+)\.xsd$/-${version}.xsd/;
166             $self->ns({ $nsalias => [ $fullns, $xsd ]});
167             $self->message()->ns($self->ns()); ## not necessary, just to make sure
168             ## remove all other versions of same namespace
169             $rs->{extensions_selected}=[ grep { ! m/^${basens}-([\d.]+)$/ || $1 eq $version } @{$rs->{extensions_selected}} ];
170             return;
171             }
172              
173             sub transport_default
174             {
175             my ($self)=@_;
176             return (protocol_connection => 'Net::DRI::Protocol::EPP::Connection', protocol_version => 1);
177             }
178              
179             ####################################################################################################
180             1;