Net-DRI-0.96/0002755000175000017500000000000011352534420012467 5ustar patrickpatrickNet-DRI-0.96/Makefile.PL0000644000175000017500000000201611350047151014434 0ustar patrickpatrickuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Net::DRI', AUTHOR => 'Patrick Mevzek ', VERSION_FROM => 'lib/Net/DRI.pm', ABSTRACT => 'Interface to Domain Name Registries/Registrars/Resellers', PL_FILES => {}, LICENSE => 'gpl', PREREQ_PM => { 'Carp' => 0, 'Test::More' => 0, 'DateTime' => 0, 'DateTime::Duration' => 0, 'DateTime::Format::Strptime' => 0, 'DateTime::TimeZone' => 0, 'DateTime::Format::ISO8601' => '0.06', ## version 0.0403 is also ok, version 0.05 IS NOT OK ! 'Class::Accessor' => 0, 'Class::Accessor::Chained' => 0, 'Time::HiRes' => 0, 'IO::Socket::INET' => 0, 'IO::Socket::SSL' => '0.90', 'Email::Valid' => 0, 'XML::LibXML' => '1.61', 'UNIVERSAL::require' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Net-DRI-*' }, ); Net-DRI-0.96/TODO0000644000175000017500000000343411350047216013161 0ustar patrickpatrickTODO file for Net::DRI Send your wishlist to ===================================================================== All * sign the distribution with Module::Signature (1) * add some introspections to be able to know what methods are really available per DRD, instead of throwing an exception ? * implement RFC5105 « ENUM Validation Token Format Definition » * switch from ExtUtils::MakeMaker to Module::Build for better META.yml ? * offer full asynchronous API ? Net::DRI * IDN support (in a cross registry fashion) with Net-IDN-Tools (1) see also http://www.bsdprojects.net/cgi-bin/archzoom.cgi/tonnerre@bsdprojects.net--2006/Net-DRI--tonnerre--0.81.1--patch-12?log Net::DRI::DRD * bulk operations (many domains at once) * domain_delete() : try to rename nameservers created in domain about to be deleted * domain_update() / host_update() - try to accomodate (set=>info+add+del, add=>info+set, del=>info+set) - verify not same info in add & del - verify final change is not empty ? * split the module in DRD::Objects::{Domain,Host,Contact,...} + smart loader (like Protocol register_commands) to load the relevant modules based on DRD::object_types() and/or Protocol registered actions and objects Net::DRI::Protocol::ResultStatus + Net::DRI::Registry * implement the results_* methods added in EPP/Message. Or change API based on wantarray Net::DRI::DRD::LU * implement startTLS extension ? Net::DRI::DRD::Nominet * implement DAS and Whois Net::DRI::Transport::HTTP::* * unify all three modules into one (Net::DRI::Transport::WS ?), taking into account all possible cases * retrofit Transport/SOAP into Transport/HTTP/SOAPLite (1), depending also on previous point (1) would be great to have before releasing Net::DRI version 1.0 Net-DRI-0.96/META.yml0000644000175000017500000000174311352534420013743 0ustar patrickpatrick--- #YAML:1.0 name: Net-DRI version: 0.96 abstract: Interface to Domain Name Registries/Registrars/Resellers license: gpl author: - Patrick Mevzek generated_by: ExtUtils::MakeMaker version 6.42 distribution_type: module requires: Carp: 0 Class::Accessor: 0 Class::Accessor::Chained: 0 DateTime: 0 DateTime::Duration: 0 DateTime::Format::ISO8601: 0.06 DateTime::Format::Strptime: 0 DateTime::TimeZone: 0 Email::Valid: 0 IO::Socket::INET: 0 IO::Socket::SSL: 0.90 Test::More: 0 Time::HiRes: 0 UNIVERSAL::require: 0 XML::LibXML: 1.61 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 Net-DRI-0.96/eg/0002755000175000017500000000000011352534417013070 5ustar patrickpatrickNet-DRI-0.96/eg/cat_epp.pl0000755000175000017500000001043211136730261015034 0ustar patrickpatrick#!/usr/bin/perl -w # # # A Net::DRI example # See also t/613cat_epp.t use strict; use Net::DRI; use DateTime::Duration; my $CLID='YOUR TEST CLIENT ID'; ### Change this information my $PASS='YOUR PASSWORD'; ### Change this information my $dri=Net::DRI->new({cache_ttl=>10,logging=>'files'}); eval { ############################################################################################################ $dri->add_registry('CAT',{clid=>$CLID}); ## This connects to .CAT server for tests my $rc=$dri->target('CAT')->add_current_profile('profile1','epp',{remote_host=>'epp.ote.puntcat.corenic.net',client_login=>$CLID,client_password=>$PASS}); die($rc) unless $rc->is_success(); ## Here we catch all errors during setup of transport, such as authentication errors my $c1=new_contact($dri,'CONTACT1'); my $c2=new_contact($dri,'CONTACT2'); my $c3=new_contact($dri,'CONTACT3'); my $c4=new_contact($dri,'CONTACT4'); $rc=$dri->contact_create($c1); die($rc) unless $rc->is_success(); $rc=$dri->contact_create($c2); die($rc) unless $rc->is_success(); $rc=$dri->contact_create($c3); die($rc) unless $rc->is_success(); $rc=$dri->contact_create($c4); die($rc) unless $rc->is_success(); my $nso=$dri->local_object('hosts'); foreach my $ns (qw/ns1.example22.com ns2.example22.com/) { print "Attempting to create host $ns "; my $e=$dri->host_exist($ns); if ($e==0) { $rc=$dri->host_create($ns); print $rc->is_success()? "OK\n" : "KO\n"; } else { print "EXIST already\n"; } $nso->add($ns); } my $dom='a-netdri'.time().'.cat'; $rc=$dri->domain_check($dom); print "$dom does ".($dri->get_info('exist')? '' : 'not ')."exist\n"; my $cs=$dri->local_object('contactset'); $cs->set($c1,'registrant'); $cs->set($c2,'billing'); $cs->set($c3,'tech'); $cs->set($c4,'admin'); print "Attempting to create domain $dom\n"; $rc=$dri->domain_create($dom,{pure_create=>1,duration=>DateTime::Duration->new(years =>1),ns=>$nso,contact=>$cs,lang=>'ca',ens=>{auth=>{id=>'FASE3-100000',key=>'0000'},intended_use=>'To test Net::DRI'},auth=>{pw=>'XYZE'}}); print "Created $dom is_success=".$rc->is_success()."\n"; # In OT&E you may need to wait for automated review of your domain, # in which case please uncomment the following lines #print "Now sleeping for 10 minutes...\n"; #sleep(10*60); #print "Back from sleep\n"; #$dri->transport()->current_state(0); ## forcing reconnection $rc=$dri->domain_check($dom); print "$dom does exist now\n" if $dri->get_info('exist'); $rc=$dri->domain_info($dom); print "domain_info OK\n" if $rc->is_success(); my $ns='ns.titi-'.time().'.fr'; $nso=$dri->local_object('hosts')->set('ns.titi-'.time().'.fr'); print "NS=$ns\n"; print "Creating $ns\n"; $rc=$dri->host_create($nso); print "Host created, is_success()=".$rc->is_success()."\n"; $rc=$dri->domain_update_ns_add($dom,$nso); print "ns_add OK=".$rc->is_success()."\n"; $rc=$dri->domain_info($dom); $rc=$dri->domain_update_ns_del($dom,$nso); print "ns_del OK=".$rc->is_success()."\n"; $rc=$dri->domain_info($dom); my $s=$dri->create_status()->no('update'); $rc=$dri->domain_update_status_add($dom,$s); print "status_add OK=".$rc->is_success()."\n"; $rc=$dri->domain_info($dom); $rc=$dri->domain_update_status_del($dom,$s); print "status_del OK=".$rc->is_success()."\n"; $rc=$dri->domain_info($dom); $rc=$dri->domain_delete($dom,{pure_delete => 1}); print "domain_delete OK=".$rc->is_success()."\n"; $rc=$dri->contact_delete($c1); print "Contact1 deleted successfully\n" if $rc->is_success(); $rc=$dri->contact_delete($c2); print "Contact2 deleted successfully\n" if $rc->is_success(); $rc=$dri->contact_delete($c3); print "Contact3 deleted successfully\n" if $rc->is_success(); $rc=$dri->contact_delete($c4); print "Contact4 deleted successfully\n" if $rc->is_success(); $dri->end(); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if (ref($@)) { $@->print(); } else { print($@); } } else { print "\n\nNo exception happened"; } print "\n"; exit 0; ###################################################### sub new_contact { my ($dri,$srid)=@_; my $c=$dri->local_object('contact'); $c->name('My Name'); $c->org('My Organisation àé æ'.time()); $c->street(['My Address']); $c->city('My city'); $c->pc(11111); $c->cc('FR'); $c->email('test@example.com'); $c->voice('+44.1111111'); $c->fax('+55.2222222'); $c->auth({pw=>'XYZ'}); $c->srid($srid); return $c; } Net-DRI-0.96/eg/afnic_email.pl0000755000175000017500000000444611136727361015667 0ustar patrickpatrick#!/usr/bin/perl use strict; use warnings; use Net::DRI; my $dri=Net::DRI->new(); eval { ############################################################################################################ ## You need to modify the following information to make this script work : ## Cc & Bcc are added to all outgoing messages, you can remove them if not needed ## smtphost is the server to connect to by SMTP to send emails ## CLIENTID/CLIENTPW are your AFNIC credentials ## test@localhost is the address that will be put in the From: field of all outgoing messages. $dri->add_registry('AFNIC', { clid => 'CLIENTID' } ); $dri->target('AFNIC')->add_current_profile('profile1','email',{cc=>'testcc@localhost',bcc=>'testbcc@localhost',smtphost=>'localhost'},['CLIENTID','CLIENTPW','test@localhost']); my $cs=$dri->local_object('contactset'); my $co=$dri->local_object('contact'); $co->org('MyORG'); $co->street(['Whatever street 35','éçp àô']); $co->city('Alphaville'); $co->pc('99999'); $co->cc('FR'); $co->legal_form('S'); $co->legal_id('111222333'); $co->voice('+33.123456789'); $co->email('test@example.com'); $co->disclose('N'); $cs->set($co,'registrant'); $co=$dri->local_object('contact'); $co->roid('TEST-FRNIC'); $cs->set($co,'tech'); my $ns=$dri->local_object('hosts'); $ns->add('ns.toto.fr',['123.45.67.89']); $ns->add('ns.toto.com'); my $rc=$dri->domain_create('toto1.fr',{pure_create => 1, contact => $cs, maintainer => 'ABCD', ns => $ns}); print "Mail successfully sent.\n" if $rc->is_success() && $rc->is_pending(); $co=$dri->local_object('contact'); $co->roid('JOHN-FRNIC'); $co->name('John, Doe'); ## Warning : AFNIC requires a , $co->street(['Whatever street 35','éçp àô']); $co->city('Alphaville'); $co->pc('99999'); $co->cc('FR'); $co->voice('+33.123456789'); $co->email('test@example.com'); $co->disclose('N'); $co->key('ABCDEFGH-100'); $cs->set($co,'registrant'); $rc=$dri->domain_create('toto2.fr',{pure_create => 1, contact => $cs, maintainer => 'ABCD', ns => $ns}); print "Mail successfully sent.\n" if $rc->is_success() && $rc->is_pending(); ############################################################################################################ }; if ($@) { print "AN ERROR happened !!!\n"; if (ref($@)) { $@->print(); } else { print($@); } } else { print "No error"; } print "\n"; exit 0; Net-DRI-0.96/eg/afnic_ws.pl0000755000175000017500000000176111136727530015224 0ustar patrickpatrick#!/usr/bin/perl -w # # A Net::DRI example use strict; use Net::DRI; my $dri=Net::DRI->new(); eval { ## You need ## 1) to download Domain-perl.wsdl and put it in the same path (or correct the URI in service_wsdl), ## as well as the certificate file, with name afnic-ca.crt (or change the name in ssl_ca_file) ## 2) to replace USERNAME and PASSWORD with your credentials at AFNIC. $dri->add_registry('AFNIC', { clid => 'USERNAME' }); $dri->target('AFNIC')->add_current_profile('profile1','ws',{proxy_url=>'https://soap-adh.nic.fr/',service_wsdl=>{Domain=>'file:./Domain-perl.wsdl'},ssl_ca_file=>'./afnic-ca.crt',credentials=>['soap-adh.nic.fr:443','Webservices Adherents AFNIC','USERNAME','PASSWORD']}); my $rc=$dri->domain_check('toto.fr'); print "Is success : ".$rc->is_success()."\n"; print "Object exists : ".($dri->get_info('exist','domain','toto.fr')? 'YES' : 'NO'); print "\n"; }; if ($@) { print "AN ERROR happened !!!\n"; $@->print(); } else { print "No error"; } print "\n"; exit 0; Net-DRI-0.96/eg/das.pl0000755000175000017500000000357011237317217014201 0ustar patrickpatrick#!/usr/bin/perl # # # A Net::DRI example use strict; use warnings; use Net::DRI; my ($rc,$dri); eval { $dri=Net::DRI->new(10); $dri->add_registry('EURid',{}); $rc=$dri->target('EURid')->add_current_profile('profile1','das'); die($rc) unless $rc->is_success(); das('europa.eu'); das('netdri-test-doestnotexist.eu'); $dri->add_registry('BE',{}); $rc=$dri->target('BE')->add_current_profile('profile1','das'); die($rc) unless $rc->is_success(); das('brussels.be'); das('netdri-test-doestnotexist.be'); $dri->add_registry('AU',{}); $rc=$dri->target('AU')->add_current_profile('profile1','das'); die($rc) unless $rc->is_success(); das('domain.com.au'); das('netdri-test-doestnotexist.com.au'); $dri->add_registry('AdamsNames',{}); $rc=$dri->target('AdamsNames')->add_current_profile('profile1','das'); die($rc) unless $rc->is_success(); das('adamsnames.tc'); das('netdri-test-doestnotexist.tc'); $dri->add_registry('SIDN',{}); $rc=$dri->target('SIDN')->add_current_profile('profile1','das'); die($rc) unless $rc->is_success(); das('amsterdam.nl'); sleep(2); das('netdri-test-doestnotexist.nl'); $dri->add_registry('BookMyName',{}); $rc=$dri->target('BookMyName')->add_current_profile('profile1','das'); die($rc) unless $rc->is_success(); das('free.org'); sleep(2); das('netdri-test-doestnotexist.com'); $dri->end(); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if (ref($@)) { $@->print(); } else { print($@); } } else { print "\n\nNo exception happened"; } print "\n"; exit 0; sub das { my $dom=shift; print 'DOMAIN: '.$dom."\n"; $rc=$dri->domain_check($dom); print 'IS_SUCCESS: '.$dri->result_is_success()."\n"; print 'CODE: '.$dri->result_code().' / '.$dri->result_native_code()."\n"; print 'MESSAGE: ('.$dri->result_lang().') '.$dri->result_message()."\n"; print 'EXIST: '.$dri->get_info('exist')."\n"; print 'EXIST_REASON: '.$dri->get_info('exist_reason')."\n"; print "\n"; } Net-DRI-0.96/eg/xmlfilter.pl0000755000175000017500000000470411024236032015425 0ustar patrickpatrick#!/usr/bin/perl -w ## =pod =head1 NAME xmlfilter.pl - A command line client program using Net::DRI towards the .NO EPP registry. =head1 DESCRIPTION This program is a small filter utility which acts an xml_pp (pretty-print) function for the xml-dump output coming from Net::DRI Transport.pm log function. The format in input is a long line like this: "2008-02-20 10:22:19.092865 C<=S [SOCKET_INET-92047-1203499339055994]\ http://www.norid.noE, Trond Haugen Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =head1 AUTHOR Trond Haugen, Einfo@norid.noE =cut use strict; use vars qw($opt_s); use Getopt::Std; # There are \0 chars in input, set binmode on stdin binmode STDIN; binmode STDOUT; use XML::Twig; &getopts('s'); my $tw = new XML::Twig( pretty_print => 'indented', output_encoding => 'UTF-8', ); my $fh = \*STDOUT; my $skipnext; while (<>) { #chomp; my $tp = $_; # .NO: changed the log output to a pretty-printed one if ( $tp =~ m|(^20\d\d.+C.+)(\<\?xml .+$)|msx ) { my $t = $1; my $s = $2; #print "t: $t\n"; #print "s: $s\n\n\n"; if ($opt_s) { if ($skipnext) { $skipnext = undef; next; } # skip dump of greeting, login, logout if ( $s =~ m//gmx ) { next; } if ( $s =~ m||gmx ) { ++$skipnext; next; } if ( $s =~ m||gmx ) { ++$skipnext; next; } } $tw->parse($s); $t = ""; # if ($opt_s); # No timestamps either if skip is on my $tpp = $t . $tw->sprint; print {$fh} $tpp . "\n---\n\n"; } else { print {$fh} $tp; } } Net-DRI-0.96/eg/whois.pl0000755000175000017500000000752311350044260014554 0ustar patrickpatrick#!/usr/bin/perl # # # A Net::DRI example use strict; use warnings; use Net::DRI; my $dri=Net::DRI->new(10); my $rc; eval { ############################################################################################################ $dri->add_registry('VNDS',{}); $rc=$dri->target('VNDS')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('nsi.com',$dri); display('laposte.net',$dri); $dri->add_registry('AERO',{}); $rc=$dri->target('AERO')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('cdg.aero',$dri); $dri->add_registry('ORG',{}); $rc=$dri->target('ORG')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('laptop.org',$dri); $dri->add_registry('INFO',{}); $rc=$dri->target('INFO')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('mta.info',$dri); $dri->add_registry('EURid',{}); $rc=$dri->target('EURid')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('europa.eu',$dri); display('eurid.eu',$dri); $dri->add_registry('BIZ',{}); $rc=$dri->target('BIZ')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('neulevel.biz',$dri); $dri->add_registry('MOBI',{}); $rc=$dri->target('MOBI')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('buongiorno.mobi',$dri); $dri->add_registry('NAME',{}); $rc=$dri->target('NAME')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('sudoku.name',$dri); $dri->add_registry('LU',{}); $rc=$dri->target('LU')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('restena.lu',$dri); $dri->add_registry('WS',{}); $rc=$dri->target('WS')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('website.ws',$dri); $dri->add_registry('SE',{}); $rc=$dri->target('SE')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('malmo.se',$dri); $dri->add_registry('CAT',{}); $rc=$dri->target('CAT')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('barcelona.cat',$dri); $dri->add_registry('AT',{}); $rc=$dri->target('AT')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('stare.at',$dri); $dri->add_registry('TRAVEL',{}); $rc=$dri->target('TRAVEL')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('paris.travel',$dri); $dri->add_registry('US',{}); $rc=$dri->target('US')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('disney.us',$dri); $dri->add_registry('PT',{}); $rc=$dri->target('PT')->add_current_profile('profile1','whois'); die($rc) unless $rc->is_success(); display('lisboa.pt',$dri); $dri->end(); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if (ref($@)) { $@->print(); } else { print($@); } } else { print "\n\nNo exception happened"; } print "\n"; exit 0; sub display { my ($dom,$dri)=@_; print 'DOMAIN: '.$dom."\n"; my $rc=$dri->domain_info($dom); print 'IS_SUCCESS: '.$dri->result_is_success().' [CODE: '.$dri->result_code().' / '.$dri->result_native_code()."]\n"; my $e=$dri->get_info('exist'); print 'EXIST: '.$e."\n" if defined $e; if ($e) { foreach my $k (qw/clName clID clWebsite clWhois upName upID crName crID crDate upDate exDate wuDate/) { print $k.': '.($dri->get_info($k) || 'n/a')."\n"; } print 'status: '.join(' ',$dri->get_info('status')->list_status())."\n" if defined($dri->get_info('status')); print 'ns: '.$dri->get_info('ns')->as_string()."\n" if defined($dri->get_info('ns')); } my $cs=$dri->get_info('contact'); if ($cs) { foreach my $t ($cs->types()) { foreach my $c ($cs->get($t)) { print 'contact '.$t.' : '.$c->as_string()."\n"; } } } print "\n\n"; } Net-DRI-0.96/eg/ws_rrp.pl0000755000175000017500000000427711136727623014757 0ustar patrickpatrick#!/usr/bin/perl -w use strict; use Net::DRI; use Net::DRI::Data::Hosts; use DateTime::Duration; my $dri=Net::DRI->new(10); eval { ############################################################################################################ $dri->add_registry('WS',{tz=>'America/Los_Angeles'}); ## This connects to .WS OT&E server my $rc=$dri->target('WS')->add_current_profile('profile1','rrp',{defer=>0,socktype=>'ssl',remote_host=>'www.worldsite.ws',remote_port=>648,ssl_key_file=>'./privkey.pem',ssl_cert_file=>'./cacert.pem',ssl_ca_file=>'./cacert.pem',ssl_cipher_list=>'TLSv1',protocol_connection=>'Net::DRI::Protocol::RRP::Connection',protocol_version=>1,client_login=>'MyLOGIN',client_password=>'MyPASSWORD'}); my $dom='toto-'.time().'.ws'; $rc=$dri->domain_check($dom); print "$dom does not exist\n" unless $dri->get_info('exist'); $rc=$dri->domain_create($dom,{pure_create=>1,duration=>DateTime::Duration->new(years =>5)}); print "$dom created\n" if $rc->is_success(); $rc=$dri->domain_check($dom); print "$dom does exist now\n" if $dri->get_info('exist'); $rc=$dri->domain_info($dom); print "domain_info OK\n" if $rc->is_success(); my $ns='ns.titi-'.time().'.fr'; my $nso=Net::DRI::Data::Hosts->new($ns); print "NS=$ns\n"; my $e=$dri->host_exist($ns); print "Host exist\n" if ($e==1); if ($e==0) { print "Creating $ns\n"; $rc=$dri->host_create($nso); print "Host created OK\n"; } $rc=$dri->domain_update_ns_add($dom,$nso); print "ns_add OK\n" if $rc->is_success(); $rc=$dri->domain_info($dom); $rc=$dri->domain_update_ns_del($dom,$nso); print "ns_del OK\n" if $rc->is_success(); $rc=$dri->domain_info($dom); $rc=$dri->host_delete($nso); print "host_delete OK\n"; my $s=$dri->create_status()->no('update'); $rc=$dri->domain_update_status_add($dom,$s); print "status_add OK\n" if $rc->is_success(); $rc=$dri->domain_info($dom); $rc=$dri->domain_update_status_del($dom,$s); print "status_del OK\n" if $rc->is_success(); $rc=$dri->domain_info($dom); $rc=$dri->domain_delete($dom,{pure_delete => 1}); print "domain_delete OK\n" if $rc->is_success(); }; if ($@) { print "\n\nAN ERROR happened !!!\n"; if (ref($@)) { $@->print(); } else { print($@); } } else { print "\n\nNo error"; } print "\n"; exit 0; Net-DRI-0.96/eg/epp_client_no.pl0000755000175000017500000015744211350044171016250 0ustar patrickpatrick#!/usr/bin/perl -w ## ## Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE ## All rights reserved. ## ## This program illustrate the usage of Net::DRI towards the .NO registry. ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. ## ## ## ## ----------------- ## ## What is this: A Net::DRI based command line client for .NO ## ## Note that it is developed for test purposes, not to be a complete client. ## ## The -p argument is expected to carry a %p parameter hash argument string ## which can be eval'ed into a %p hash, like this for a host create operation: ## -o host -c create -p "%p=(name=>'ns1.suniswanted.no',v4=>'123.234.123.12')" ## ## See POD section at the end for further details. ## ####### use strict; use Net::DRI; use DateTime::Duration; use Pod::Usage; use POSIX qw(locale_h); use Net::LibIDN ':all'; use Getopt::Std; use Data::Dumper; $Data::Dumper::Indent=1; use encoding "utf-8"; # assume utf-8 encoded argument input our $VERSION = '0.95.no'; our $SVN_VERSION = do { my @r = ( q$Revision: 1.3 $ =~ /\d+/gxm ); sprintf( "%d" . ".%02d" x $#r, @r ); }; # Format string for output of results my $F = " %-15s: %s\n"; # All possible dri object methods my @drim = ('id'); # All possible contact object methods my @cm = ( # standard DRI methods 'loid', 'srid', 'id', 'roid', 'name', 'org', 'street', 'city', 'sp', 'pc', 'cc', 'email', 'voice', 'fax', 'auth', 'disclose', # .no extra methods 'type', 'identity', 'mobilephone', 'organization', 'rolecontact', 'xemail', 'xdisclose', 'facets' ); # args use vars qw($opt_c $opt_o $opt_h $opt_p $opt_f $opt_P $opt_S $opt_L $opt_C $opt_W $opt_w); # Operations my %op = ( 'hello' => 1, 'create' => 1, 'update' => 1, 'delete' => 1, 'info' => 1, 'poll' => 1, 'check' => 1, 'renew' => 1, 'withdraw' => 1, 'transfer' => 1, 'transfer_query' => 1, 'transfer_cancel' => 1, 'transfer_execute' => 1, # extension command # message operations 'waiting' => 1, 'count' => 1, 'retrieve' => 1, # delete op is already defined ); # Objects my %obj = ( 'contact' => 'contact', 'person' => 'contact', 'organization' => 'contact', 'role' => 'contact', 'host' => 'host', 'domain' => 'domain', 'message' => 'message', ); # The possible facet keys must be registered here, the value part must be TRUE # in this hash for the facet to be activated my %facets = ( 'skip-dns-checks' => 1, 'skip-manual-review' => 1, 'ignore-exceptions-as-registrar' => 1, 'impersonate-registrar' => 1 ); # Hash to hold the EPP arguments my %p; &getopts("Lo:c:p:f:S:P:C:W:w:"); #server and port must be specified my $socktype = 'tcp'; die "No server specified" unless ($opt_S); die "No port specified" unless ($opt_P); die "No client id specified" unless ($opt_C); die "No password specified" unless ($opt_W); my $server = $opt_S; my $port = $opt_P; $socktype = 'ssl' if ($opt_L); my $clid = $opt_C; my $pass = $opt_W; my $newpass; $newpass = $opt_w if ($opt_w); unless ( $opt_c && $op{$opt_c} ) { pexit("Specify a valid command"); } unless ( $opt_c eq 'hello' ) { unless ( $opt_o && $obj{$opt_o} ) { pexit("Specify a valid object type"); } unless ($opt_p) { pexit("Specify a parameter string"); } #print "p: $opt_p \n"; unless ( parse_params($opt_p) ) { pexit("Specify a valid parameter string"); } } if ($p{facets}) { # verify that the facets are among the valid and registered ones foreach my $fkey (keys(%{$p{facets}})) { pexit("Invalid facet: '$fkey'") unless ($facets{$fkey}); } } my $t1 = time(); my $logf = 'results-' . time() . '.log'; $logf = $opt_f if ($opt_f); open( my $fh, '>>', $logf ) || die $!; do_epp_operation( $obj{$opt_o}, $opt_c, $clid, $pass, $newpass, $socktype, $server, $port, $fh, %p ); my $t2 = time(); print "\nTime used: ", $t2 - $t1, "secs\n"; ############ # # S U B S # ########### sub parse_params { my $p = shift; eval $opt_p; # assume a Data::Dumper syntax, read pars with eval! if ($@) { # eval has failed, $@ tells us why pexit( "Eval failed, specify a valid parameter string, msg: " . $@ . "\n" ); } return 1; } sub do_epp_operation { my ( $obj, $cmd, $clid, $pw, $newpw, $socktype, $server, $port, $fh, %p ) = @_; my $res = 1; select($fh); $|++; select(STDOUT); #print "Dumping XML exchange to $logf\n"; my ( $dri, $rc ); eval { ( $dri, $rc ) = init_reg_no( $clid, $pw, $newpw, $socktype, $server, $port, $fh ); do_command( $obj, $cmd, $dri, $rc, %p ); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if ( ref($@) ) { print "FAILURE: Error descriptions: ", ref($@), "\n"; $@->print(); print "\n"; dump_conditions($dri); } else { print "FAILURE: No extra info: "; print($@); } $res = 0; } else { print "\n\nSUCCESS"; } print "\n"; # Important not to call dri->end too early, because condition date may be # destroyed. $dri->end(); close($fh); return $res; } sub pexit { print shift, "\n\n"; # The error text supplied pod2usage( { -message => $0, -exitval => 0 } ); return; } sub print_result { my $dri = shift; my $rc = shift; print "\n", " result_code : ", $dri->result_code(), "\n", " native_code : ", $dri->result_native_code(), "\n", " result_message : ", $dri->result_message(), "\n", " language : ", $dri->result_lang(), "\n\n"; if ( $dri->can('result_is_pending') ) { print " pending : ", $dri->result_is_pending(), "\n"; } if ( $dri->can('result_info') ) { print "info : ", $dri->result_info(), "\n"; } if ( $dri->can('result_print') ) { print "result_print: ", $dri->result_print(), "\n"; } if ( $dri->can('result_print_full') ) { print "result_print_full: ", $dri->result_print_full(), "\n"; } if ($rc) { print_rc_result($rc); } foreach my $w ( 'action', 'exist', 'trStatus', 'reID', 'reDate', 'acID', 'acDate', 'exDate' ) { if ( my $v = $dri->get_info($w) ) { printf "$F", $w, $v; } } return 1; } sub print_rc_result { my $rc = shift; # Print rc-specific info, not found in $dri->result_*() if ( $rc->can('is_pending') ) { print "rcpending : ", $rc->is_pending(), "\n" if ( $rc->is_pending() ); } if ( $rc->can('info') ) { print "rcinfo : ", $rc->info(), "\n" if ( $rc->info() ); } my $F2 = " %-15s: %s%s\n"; if ( $rc->can('trid') && $rc->trid() ) { # trid seems to be returned as an array with two values printf "$F2", 'trid', $rc->trid(); } return 1; } sub contact_object_as_string { my ( $dri, $o, @om ) = @_; return unless $o; # Populate the loc-array values # $ci->int2loc(); # hmm, if int2loc is called, it overwrites the # localized data and destroys some of it my $s = ""; foreach my $m (@om) { my $r; if ( $o->can($m) ) { if ( $m eq 'street' ) { # Is an array up to 3 elements $r = join ", ", @{ $o->$m }; } elsif ( $m eq 'identity' ) { $r = "type : " . $o->$m->{type} if ( $o->$m && $o->$m->{type} ); $r .= ", value: " . $o->$m->{value} if ( $o->$m && $o->$m->{value} ); } elsif ( $m eq 'xemail' || $m eq 'rolecontact' ) { # Is an array up to n elements $r = join ", ", @{ $o->$m } if ( $o->$m ); } else { my @va; @va = $o->$m if ( $o->$m ); foreach my $v (@va) { if ( ref($v) && ( ref($v) ne 'SCALAR' ) ) { # don't bother diving into it ... use a Dumper $r .= sprintf Dumper $v; } else { $r .= $v if ($v); } } } $s .= sprintf "$F", $m, $r if ($r); } else { $s .= "-- method $m not possible \n"; } } foreach my $i ( 'roid', 'crDate', 'upDate', 'clID', 'crID', 'upID' ) { my $v = $dri->get_info($i); $v = '-' unless $v; $s .= sprintf "$F", $i, $v; } return $s; } sub host_object_as_string { my ($dri) = @_; my $s = ""; my $hi = $dri->get_info('self'); foreach my $m ( 'loid', 'count' ) { my $v = '-'; $v = $hi->$m if ( $hi->$m ); $s .= sprintf "$F", $m, $v; } my @nms = $hi->get_names(); $s .= sprintf "$F", 'names', @nms; foreach my $n (@nms) { my @d = $hi->get_details($n); # ip-addresses are optional my @v; @v = @{ $d[1] } if ( @{ $d[1] } ); @v = ("-") unless (@v); $s .= sprintf "$F", 'v4 addresses', join( ", ", @v ); @v = (); @v = @{ $d[2] } if ( @{ $d[2] } ); @v = ("-") unless (@v); $s .= sprintf "$F", 'v6 addresses', join( ", ", @v ); } # contact is a scalar my $ct = "-"; if ( $ct = $dri->get_info('contact') ) { $s .= sprintf "$F", 'contact', $ct; } foreach my $i ( 'roid', 'exDate', 'crDate', 'upDate', 'trDate', 'clID', 'crID', 'upID' ) { my $v = $dri->get_info($i); $v = '-' unless $v; $s .= sprintf "$F", $i, $v; } return $s; } #You may use get_info with the following keys to get more information: # - ns : a Net::DRI::Data::Hosts object representing the nameservers of the # domain # - status : a Net::DRI::Data::StatusList object representing the current # status list of the domain queried # - exDate, crDate, upDate, trDate : DateTime objects representing the # expiration, creation, last update, and transfer date for the domain # queried # - clID, crID, upID : (strings) local registry ID of the current sponsoring # registrar, the registrar having created, and the registrar (or # registry) having last modified the domain queried sub domain_object_as_string { my ($dri) = @_; my $s = ""; ## # authInfo # $s .= sprintf "--- Auth info ---\n"; my $au = $dri->get_info('auth'); foreach my $i ( 'name', 'roid', 'exDate', 'crDate', 'upDate', 'trDate', 'clID', 'crID', 'upID' ) { my $v = $dri->get_info($i); $v = '-' unless $v; $s .= sprintf "$F", $i, $v; if ( $i eq 'name' ) { # Also print the UTF-8 of an ACE my $idn = idn_to_unicode( $v, 'utf-8', IDNA_USE_STD3_ASCII_RULES ); $s .= sprintf "$F", 'IDN-name', $idn; } } ## # name servers # $s .= sprintf "--- Name servers ---\n"; my $ns = $dri->get_info('ns'); my $v = '-'; if ( ( $v = $ns->count() ) > 0 ) { $s .= sprintf "$F", 'ns count', $v; } foreach my $n ( $ns->get_names() ) { $s .= sprintf "$F", 'ns name', $n; } #################### # Contacts # # contact is an array ref. my $co = $dri->get_info('contact'); $s .= sprintf "--- Contacts ---\n"; foreach my $ct ( 'registrant', 'admin', 'tech' ) { my @r = $co->get($ct); $v = "-"; foreach my $r (@r) { $v = $r->srid if ( $r->srid ); $s .= sprintf "$F", $ct, $v; } } #################### # Domain status # $s .= sprintf "--- Status summary ---\n"; my $st = $dri->get_info('status'); # domain status methods my @dsm = ( 'is_active', 'is_published', 'is_pending', 'is_linked', 'can_update', 'can_transfer', 'can_delete', 'can_renew', #'possible_no', # hmmm.. what's this for? #'no' # hmmm.. what's this for? ); foreach my $ds (@dsm) { $v = "-"; $v = $st->$ds if ( $st->$ds ); $s .= sprintf "$F", $ds, $v; } #### # also dump all the detailed status values my @ls = $st->list_status(); $s .= sprintf "--- Flag details ---\n"; foreach my $l (@ls) { $s .= sprintf "$F", 'flag', $l; } return $s; } sub get_info_object_as_string { my ( $o, @om ) = @_; my $s = ""; foreach my $m (@om) { my $v = "-"; if ( $o->get_info($m) ) { $v = $o->get_info($m); if ( $v && ref($v) && ( ref($v) ne 'SCALAR' ) ) { # don't bother diving into it ... use a Dumper $v = sprintf Dumper $v; next; } $s .= sprintf "$F", $m, $v; } else { $s .= "-- method $m not possible \n"; } } return $s; } sub init_reg_no { my ( $clid, $pw, $newpw, $socktype, $server, $port, $fh ) = @_; my $dri = Net::DRI->new( { cache_ttl => 10, logging => ['files', {output_directory => './', output_filename=>$opt_f, level=>'notice', xml_indent=>1}] } ); $dri->add_registry( 'NO', { clid => $clid } ); my %pars = ( defer => 0, socktype => $socktype, remote_host => $server || 'epp.test.norid.no', remote_port => $port || 700, protocol_connection => 'Net::DRI::Protocol::EPP::Connection', protocol_version => 1, client_login => $clid, client_password => $pw, ); $pars{client_newpassword} = $newpw if ($newpw); my $rc = $dri->target('NO')->add_current_profile( 'profile1', 'epp', { %pars, }, ); ## Here we catch all errors during setup of transport, such as ## authentication errors die($rc) unless $rc->is_success(); return ( $dri, $rc ); } sub do_command { my ( $obj, $cmd, $dri, $rc, %p ) = @_; use Data::Dumper; $Data::Dumper::Indent = 1; if ( $cmd eq 'hello' ) { print "*** hello ***\n"; # no objects in this case $rc = $dri->process( 'session', 'noop', [] ); die($rc) unless $rc->is_success(); ## Her print "Hello was a success\n"; exit 0; } print "*** Executing EPP command: $obj . $cmd ***\n"; if ( $obj eq 'host' ) { if ( $cmd eq 'check' ) { print ".check ", $p{name}, "\n"; $rc = $dri->host_check( $p{name}, { facets => $p{facets}} ); print_result( $dri, $rc ); die($rc) unless $rc->is_success(); # For a host check, only an exist check is available in DRI print "Host $p{name} ", $dri->get_info('exist') ? "exists" : "do not exist"; } if ( $cmd eq 'info' ) { my %a; # host info can specify a sponsoringclientid $a{sponsoringclientid} = $p{sponsoringclientid} if ( $p{sponsoringclientid} ); $a{facets} = $p{facets} if ( $p{facets} ); $rc = $dri->host_info( $p{name}, \%a ); print_result( $dri, $rc ); die($rc) unless $rc->is_success(); print host_object_as_string($dri); } if ( $cmd eq 'create' ) { # DRI 0.85 need to create the hosts objects directly .. my $nso = $dri->local_object('hosts'); $nso->add( $p{name}, $p{v4}, $p{v6} ); $rc = $dri->host_create( $nso, { contact => $p{contact}, facets => $p{facets} } ); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'update' ) { ### # We can change all params, name, ip-addresses and contact # Proper add/del keys must be supplied by the user to do this my $toc = $dri->local_object('changes'); if ( $p{ipset} ) { # add and del keys shall describe what to do my ( $v4a, $v4d ); $v4a = $p{ipset}{add}{v4} if ( $p{ipset}{add}{v4} ); $v4d = $p{ipset}{del}{v4} if ( $p{ipset}{del}{v4} ); $toc->add( 'ip', $dri->local_object('hosts')->add( $p{name}, $v4a, [] ) ) if ($v4a); $toc->del( 'ip', $dri->local_object('hosts')->add( $p{name}, $v4d, [] ) ) if ($v4d); } # Update name if nname is specified if ( $p{nname} && $p{nname} ne $p{name} ) { # a new name is specified, insert it as a chg $toc->set( 'name', $p{nname} ); } # # Contact data if ( defined( $p{contact} ) ) { # add and del keys shall describe what to do foreach my $s ( 'add', 'del' ) { my $n = $p{contact}{$s}; $toc->$s( 'contact', $n ) if ( defined($n) && $n ); } } # Facets if ( defined($p{facets}) ) { $toc->set( 'facets', $p{facets} ); } $rc = $dri->host_update( $p{name}, $toc); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'delete' ) { $rc = $dri->host_delete( $p{name}, { facets => $p{facets} } ); print_result($dri); die($rc) unless $rc->is_success(); } } if ( $obj eq 'contact' ) { if ( $cmd eq 'check' ) { my $co = $dri->local_object('contact')->new()->srid( $p{srid} ); $rc = $dri->contact_check($co, { facets => $p{facets} } ); print_result($dri); die($rc) unless $rc->is_success(); print "Contact $p{srid} ", $dri->get_info('exist') ? " exists" : "do not exist"; } if ( $cmd eq 'info' ) { my $co = $dri->local_object('contact')->new()->srid( $p{srid} ); $rc = $dri->contact_info($co, { facets => $p{facets} } ); # print "Contact $p{srid} ", $dri->get_info('exist')?" exists":"do not exist"; print_result($dri); die($rc) unless $rc->is_success(); my $o = $dri->get_info('self'); print contact_object_as_string( $dri, $o, @cm ); } if ( $cmd eq 'create' ) { my $co = $dri->local_object('contact')->new(); # auth not supported for .NO contact foreach my $m (@cm) { #next if $m eq 'sp'; # Not supported by .NO today, # but better to let server reject in case that changes my $v = $p{$m}; #print STDERR "ref $m: ", ref($p{$m}), "\n"; $co->$m( $p{$m} ) if ( $p{$m} ); } $rc = $dri->contact_create($co); print_result($dri); die($rc) unless ( $rc->is_success() ); #print contact_object_as_string($dri, $co, @cm); print get_info_object_as_string( $dri, @drim ); } if ( $cmd eq 'update' ) { ### # We can change all params, name, ip-addresses and contact # Proper add/del keys must be supplied by the user to do this ######### my $co = $dri->local_object('contact')->srid( $p{srid} ); my $toc = $dri->local_object('changes'); my $co2 = $dri->local_object('contact'); foreach my $m (@cm) { $co2->$m( $p{$m} ) if ( $p{$m} ); } $toc->set( 'info', $co2 ); if ( $p{type} ) { $toc->set( 'type', $p{type} ); } if ( $p{mobilephone} ) { $toc->set( 'mobilephone', $p{mobilephone} ); } if ( $p{xdisclose} ) { $toc->set( 'xdisclose', $p{xdisclose} ); } if ( $p{identity} ) { $toc->set( 'identity', $p{identity} ); } # # organization data # if ( $p{organization} ) { # add and del keys shall describe what to do foreach my $s ( 'add', 'del' ) { my $n = $p{organization}{$s}; $toc->$s( 'organization', $n ) if ( defined($n) && $n ); } } # # RoleContact data # if ( $p{rolecontact} ) { # add and del keys shall describe what to do foreach my $s ( 'add', 'del' ) { my $n = $p{rolecontact}{$s}; $toc->$s( 'rolecontact', $n ) if ( defined($n) && $n ); } } # # xemail data # if ( $p{xemail} ) { # add and del keys shall describe what to do foreach my $s ( 'add', 'del' ) { my $n = $p{xemail}{$s}; $toc->$s( 'xemail', $n ) if ( defined($n) && $n ); } } # Facets if ( defined($p{facets}) ) { $toc->set( 'facets', $p{facets} ); } $rc = $dri->contact_update( $co, $toc ); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'delete' ) { my $co = $dri->local_object('contact')->new()->srid( $p{srid} ); $rc = $dri->contact_delete($co, { facets => $p{facets} } ); print_result($dri); die($rc) unless $rc->is_success(); # Do an info to verify the delete print "Verifying delete by an info ....: \n"; do_command( $obj, 'info', $dri, $rc, %p ); } } if ( $obj eq 'domain' ) { my ( $ace, $idn ); # We accept input name as either an ace-name or an utf-8 if ( $p{name} ) { $idn = lc( $p{name} ); die "Cannot lower case domain name: $idn" unless ($idn); $ace = idn_to_ascii( $idn, 'utf-8', IDNA_USE_STD3_ASCII_RULES ); die "Cannot convert domain to ace" unless ($ace); $idn = idn_to_unicode( $ace, 'utf-8', IDNA_USE_STD3_ASCII_RULES ); die "Cannot convert domain to ace" unless ($ace); undef $idn if ( $ace eq $idn ); } else { die "No domain name specified"; } #print "input name: $p{name}\n"; #print "ace : $ace\n"; #print "idn : $idn\n"; die "Illegal domain name" unless ($ace); if ( $cmd eq 'check' ) { $rc = $dri->domain_check($ace, { facets => $p{facets} }); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); print "Domain $p{name} ", $dri->get_info('exist') ? " exists" : "do not exist"; } if ( $cmd eq 'info' ) { $rc = $dri->domain_info($ace, { facets => $p{facets} }); print_result($dri); die($rc) unless $rc->is_success(); print domain_object_as_string($dri); } if ( $cmd eq 'create' ) { # # A create is supported as follows: # A domain name in 'name' # A contact set in coset=>{billing=>'THO123', admin=>'TH2345P', ... # A name server set in nsset=>{billing=>'THO123', admin=>'TH2345P', ... # my $cs = $dri->local_object('contactset'); my $du; if ( $p{duration} ) { $du = DateTime::Duration->new( $p{duration} ); die "Illegal duration value" unless ($du); } $cs->set( $dri->local_object('contact')->srid( $p{registrant} ), 'registrant' ) if ( $p{registrant} ); my $c; if ( $c = $p{coset} ) { # we have a contact set, DRI accepts multiple of each type, so we implement ## that and let server policy decide if multiple can be accepted my @acs; my @ca; foreach my $t ( 'admin', 'billing', 'tech' ) { if ( $c->{$t} ) { if ( ref( $c->{$t} ) eq 'ARRAY' ) { @ca = @{ $c->{$t} }; } else { # A single scalar srid push @ca, $c->{$t}; } foreach my $s (@ca) { push @acs, $dri->local_object('contact')->srid($s); } $cs->set( [@acs], $t ); undef @ca; undef @acs; } } } # see the DRI README doc. # - domain_create() does a lot of checking and creating if the objects does # not exist, # - domain_create_only() has a simpler behaviour # We use domain_create_only(), it's simplest my $nso = $dri->local_object('hosts'); if ( $p{nsset} ) { if ( my @ns = @{ $p{nsset} } ) { foreach my $n (@ns) { $nso->add( $n, [], [] ); } } } $rc = $dri->domain_create( $ace, { pure_create => 1, ## this was previously achieved by using domain_create_only that is now deprecated auth => { pw => $p{pw} }, duration => $du, contact => $cs, ns => $nso, facets => $p{facets}, } ); print_result($dri); die($rc) unless ( $rc->is_success() ); } if ( $cmd eq 'update' ) { ### # We can change most params, but not domain name or duration # Proper add/del keys must be supplied by the user to do this my $cs = $dri->local_object('contactset'); my $toc = $dri->local_object('changes'); $toc->set( 'registrant', $dri->local_object('contact')->srid( $p{registrant} ), 'registrant' ) if ( $p{registrant} ); # Update is the only command where the status flags can be set/changed # The flag values to use by the DRI user is the following (from Status.pm): # my %s=('delete' => 'clientDeleteProhibited', # 'renew' => 'clientRenewProhibited', # 'update' => 'clientUpdateProhibited', # 'transfer' => 'clientTransferProhibited', # 'publish' => 'clientHold', # ); if ( $p{pw} ) { $toc->set( 'auth', { pw => $p{pw} } ); } if ( my $s = $p{status} ) { foreach my $op ( 'add', 'del' ) { my $sl = $dri->local_object('status'); # add and del keys shall describe what to do my $a; $a = $p{status}{$op} if ( $p{status}{$op} ); # array or not if ( ref($a) eq 'ARRAY' ) { foreach my $m (@$a) { $sl->no($m); } } else { $sl->no($a); } $toc->$op( 'status', $sl ) or die "Invalid status value"; } } if ( my $c = $p{coset} ) { # we have a contact set, DRI accepts multiple of each type, so we implement # that and let server policy decide if multiple can be accepted my @acs; my @ca; # add and del keys shall describe what to do foreach my $op ( 'add', 'del' ) { $cs = $dri->local_object('contactset'); foreach my $r ( 'admin', 'billing', 'tech' ) { if ( my $v = $c->{$op}->{$r} ) { if ( ref($v) eq 'ARRAY' ) { @ca = @{$v}; } else { # A single scalar srid push @ca, $v; } foreach my $va (@ca) { push @acs, $dri->local_object('contact')->srid($va); } } $cs->set( [@acs], $r ); undef @ca; undef @acs; } $toc->$op( 'contact', $cs ); undef $cs; } } if ( $p{nsset} ) { foreach my $op ( 'add', 'del' ) { # add and del keys shall describe what to do my $a; $a = $p{nsset}{$op} if ( $p{nsset}{$op} ); # array or not if ( ref($a) eq 'ARRAY' ) { foreach my $m (@$a) { $toc->$op( 'ns', $dri->local_object('hosts')->add($m) ); } } else { $toc->$op( 'ns', $dri->local_object('hosts')->add($a) ); } } } # Facets if ( defined($p{facets}) ) { $toc->set( 'facets', $p{facets} ); } $rc = $dri->domain_update( $ace, $toc ); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'delete' ) { die "Cannot delete domain, rejected by DRI:domain_status_allows_delete()" unless ( $dri->domain_status_allows_delete($ace) ); # pure_delete should suppress a domain_info() from being first performed # to check if the domain exists my %a=(pure_delete => 1); $a{deletefromdns} = $p{deletefromdns} if $p{deletefromdns}; $a{deletefromregistry} = $p{deletefromregistry} if $p{deletefromregistry}; $a{facets} = $p{facets} if $p{facets}; $rc = $dri->domain_delete( $ace, \%a ); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'transfer_query' ) { my %a; $a{auth} = { pw => $p{pw} } if ( $p{pw} ); $a{facets} = $p{facets} if ( $p{facets} ); $rc = $dri->domain_transfer_query( $ace, \%a ); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'transfer_cancel' ) { my %a; $a{auth} = { pw => $p{pw} } if ( $p{pw} ); $a{facets} = $p{facets} if ( $p{facets} ); $rc = $dri->domain_transfer_stop( $ace, \%a ); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'transfer' ) { # this is a transfer init operation. my %a; $a{auth} = { pw => $p{pw} } if ( $p{pw} ); $a{facets} = $p{facets} if ( $p{facets} ); # notify parameters if ( $p{notify} ) { # Only one is accept $a{mobilephone} = $p{notify}{mobilephone} if ( $p{notify}{mobilephone} ); $a{email} = $p{notify}{email} if ( $p{notify}{email} ); } $rc = $dri->domain_transfer_start( $ace, \%a ); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'transfer_execute' ) { my %a; $a{auth} = { pw => $p{pw} } if ( $p{pw} ); $a{token} = $p{token} if ( $p{token} ); $a{facets} = $p{facets} if ( $p{facets} ); # require either a token or a pw unless ( exists( $p{token} ) && $p{token} || exists( $p{pw} ) ) { die "Missing mandatory 'token' or 'pw' parameter in $cmd"; } my $du; if ( $p{duration} ) { $du = DateTime::Duration->new( $p{duration} ); die "Illegal duration value" unless ($du); $a{duration} = $du; } $rc = $dri->domain_transfer_execute( $ace, \%a ); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'renew' ) { my $du = undef; if ( $p{duration} ) { $du = DateTime::Duration->new( $p{duration} ); die "$0: Illegal duration value" unless ($du); } my $exp = undef; if ( $p{curexpiry} ) { my ( $y, $m, $d ) = split '-', $p{curexpiry}; $exp = DateTime->new( year => $y, month => $m, day => $d ); die "$0: Illegal curexpiry date " unless ($exp); } $rc = $dri->domain_renew( $ace, { duration => $du, current_expiration => $exp, facets => $p{facets} } ); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'withdraw' ) { $rc = $dri->domain_withdraw($ace, { facets => $p{facets} } ); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } } # End of domain operations # Standardized EPP elements my @epp = ( 'id', 'qdate', 'msg', 'content', 'nocontent', # .NO specific content desc 'lang', 'object_type', 'object_id', 'action', 'result', 'trid', 'svtrid', 'date', ); # .NO conditions my @noc = ( 'msg', 'code', 'severity', 'details' ); my %m; # Message / poll operations if ( $obj eq 'message' ) { if ( $cmd eq 'waiting' ) { print "Poll: messages waiting: ", $dri->message_waiting({ facets => $p{facets} }), "\n"; } if ( $cmd eq 'count' ) { print "Poll: message count: ", $dri->message_count({ facets => $p{facets} }), "\n"; } if ( $cmd eq 'retrieve' ) { $rc = $dri->message_retrieve({ facets => $p{facets} }); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); if ( my $c = ($dri->message_count() > 0) ) { # messages returned for ( my $i = 1; $i <= $c; $i++ ) { my $li = $dri->get_info('last_id'); my ($qda, $lng, $cnt, $oty, $oid, $act, $res, $ctr, $str, $tr, $dat ); if ( defined($li) && $li) { foreach my $e (@epp) { my $v; $v = $dri->get_info( $e, 'message', $li ); if (defined($v) && $v) { if ($e eq 'qdate') { # make the DateTime object a scalar time string $v = sprintf $v; } $m{$e} = $v; } } # .NO conditions my $c; $c = $dri->get_info( 'conditions', 'message', $li ); $m{conditions} = $c if ($c); } } } # Just dump the message elements print "message: ", Dumper \%m; } if ( $cmd eq 'delete' ) { if ( my $id = $p{id} ) { $rc = $dri->message_delete($id, { facets => $p{facets} }); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } else { print "Poll: No 'id' specified\n"; } } } return; } sub dump_conditions { my $dri = shift; # get the conditions array from $rinfo structure which is built by Result.pm # my $cd = $dri->get_info('conditions'); #print "cd: ", Dumper $cd; foreach my $c (@$cd) { foreach my $i ( 'code', 'severity', 'msg', 'details' ) { my $v; $v = '-' unless ( $v = $c->{$i} ); printf "$F", $i, $v; } } return; } #__END__ =pod =head1 NAME epp_client_no.pl - A command line client program using Net::DRI towards the .NO EPP registry. =head1 DESCRIPTION The client supports creation and maintainance of host, contact and domain objects for .NO. It supports various transfer operations, as well as poll operation for the message queue. It was developed for testing of the .NO extensions to Net::DRI, but can probably be used by users who are comfortable with a simple command line interfaces. =head1 SYNOPSIS =head2 Command line B =head3 Arguments =over =item Mandatory connect arguments -C: Client ID, your EPP registrar account name, typical regxxx, where xxx is a number -W: Account password, your EPP account password -S: Server name, the registry server -P: EPP server port =item Optional connect arguments -f: Log file. The Net::DRI raw XML exchange will be dumped to this file -L: Use SSL connection -w: New account password, will be set in first EPP login =item Command arguments The command argument specify the EPP operation to perform: -o: EPP object. One of contact, host, domain, message -c: EPP command. One of hello, create, update, info, delete, transfer, transfer_cancel, transfer_execute, count, waiting, retrieve -p: EPP parameter argument string, in a format that can be eval'ed into a hash, se parameter string examples below. =back =head3 About each EPP command sequence Each command will be performed as follows: - Socket connect, session initiation, a greeting is returned - an EPP login, which will succeed if the connect arguments are correct, otherwise fail, a greeting is returned if login is OK - an EPP command, according to the specified command arguments - an EPP logout - Session termination =head3 A simple connect and greeting test Basic connect to an EPP server should give you a greeting back if successful. A simple connect to an EPP server and port: Raw port (no SSL): telnet Encrypted with SSL: openssl s_client -host -port =head3 About logging and filtering of the log output Logging is useful for debugging purposes, A client side log can be activated by -f option, like: '-f xx.log' Tail on the log-file in a separate window is nice then. Even nicer is to filter the tail through the supplied xmlfilter.pl utility, which will wrap the raw XML to a pretty-printed dump. The filters '-s' option will skip all the login/logout and greetings which otherwise will dominate the outpot. 'tail -f xx.log | ./xmlfilter.pl -s' =head3 About authInfo Auth-info (pw) can be set and updated only for domain objects, and is needed only for a transfer-execute. =head1 EPP commands and arguments =head2 Hello command =over =item Hello -c hello A greeting shall be returned, with the menu! =back =head2 Contact object commands =head3 Contact create A .NO contact can be one of three types, person, organization or role. For each contact created, the type must be specified via the mandatory type extension. =over =item 1 Organization contact -o contact -c create -p E<34>%p=(name=>'EXAMPLE FIRM AS', street=>['Example building','Example st. 23', '5 etg'], city=>'Trondheim', pc=>'7465', cc=>'NO', voice=>'+47.12345678', fax=>'+47.12345678x01', email=>'xml@example.no', type=>'organization', identity=>{type=>'organizationNumber', value=>'987654321'})E<34> =item 2 Person contact 1 affiliated with a company -o contact -c create -p E<34>%p=(name=>'Peter Example Olsen', street=>['First example building','Example st. 1'], city=>'Trondheim', pc=>'7465', cc=>'NO', voice=>'+47.22345671', mobilephone=>'+47.123456781', email=>'peter.xml@example.no', type=>'person', organization=>'EFA12O')E<34> =item 3 Person contact 2 not affiliated with a company -o contact -c create -p E<34>%p=(name=>'John Example Johnsen', street=>['Second example building','Example st. 2'], city=>'Trondheim', pc=>'7465', cc=>'NO', voice=>'+47.22345672', mobilephone=>'+47.123456782', email=>'john.xml@example.no', type=>'person')E<34> =item 4 Role contact with two contact end a secondary extra email address -o contact -c create -p E<34>%p=(name=>'Example hostmaster', street=>['Example building','Example st. 23', '5 floor'], city=>'Trondheim', pc=>'7465', cc=>'NO', voice=>'+47.12345678', fax=>'+47.12345678x01', mobilephone=>'+47.123456789', email=>'hostmaster@example.no', type=>'role', rolecontact=>['PEO1P', 'JEO2P'], xemail=>'xml@example.no')E<34> =back =head3 Contact update In this example, a role contact update is shown. =over =item Role contact update Update a role and add an org. affiliation and a new person affiliation, also remove one of the existing person affiliations. Also change some of the address information and the mobile phone number. Keep the rest of the info. -o contact -c update -p E<34>%p=(srid=>'TOH12R', name=>'New name on Hostmaster', street=>['Changed example building','Changed Example st. 23', '5 floor'], city=>'Trondheim', pc=>'7465', cc=>'NO', mobilephone=>'+47.123433389', organization=>{add=>['TOH1O']}, rolecontact=>{add=>['TOH1P'], del=>['TOH1P']})E<34> =back =head3 Contact info If a 'srid' returned on a create is 'TOH169O', it means that the org. handle has the value 'TOH169O-NORID'. Lets do an info on this handle. =over =item Info on an organization contact handle -o contact -c info -p E<34>%p=(srid=>'TOH169O')E<34> =back =head3 Contact check =over =item Check on an organization contact handle -o contact -c check -p E<34>%p=(srid=>'TOH169O')E<34> You may get an usupported command on this! =back =head3 Contact delete =over =item Delete on an organization contact handle -o contact -c delete -p E<34>%p=(srid=>'TOH169O')E<34> =back =head2 Host object commands =head3 Host create =over =item 1 Create an external name server An external name server is a non .NO name server. External name servers must be registered without any IP-addresses. -o host -c create -p E<34>%p=(name=>'ns1.example.com')E<34> =item 2 A .NO name server will require an ipv4-address -o host -c create -p E<34>%p=(name=>'ns1.test.no', v4=>'123.234.123.12')E<34> =item 3 A .NO name server also with an optional contact -o host -c create -p E<34>%p=(name=>'ns2.test.no', v4=>'123.234.123.12', contact=>'JEO50P')E<34> =item 4 Multiple ip-addresses, pass them as an array -o host -c create -p E<34>%p=(name=>'ns3.test.no', v4=>['123.234.123.12','129.123.23.23'])E<34> =item 5 A .NO name server with ipv6 address as well Will probably be rejected by server policy: -o host -c create -p E<34>%p=(name=>'ns4.test.no', v4=>['123.234.123.12','129.123.23.23'], v6=>['2001:700:1:0:215:f2ff:fe3e:fe65'])E<34> =back =head3 Host info =over =item 1 Info on a sponsored host object -o host -c info -p E<34>%p=(name=>'ns1.suniswanted.no')E<34> =item 2 info on a host object sponsored (owned) by another registrar It is possible to query hosts sponsored by other registrars, but you need to specify his registrar id by the 'sponsoringClientID'. -o host -c info -p E<34>%p=(name=>'ns1.suniswanted.no', sponsoringclientid=>'reg9998')E<34> =back =head3 Host check =over =item Check to see whether a host name is available or registered -o host -c check -p E<34>%p=(name=>'ns1.test.no')E<34> =back =head3 Host delete =over =item Delete a host -o host -c delete -p E<34>%p=(name=>'ns1.test.no')E<34> =back =head3 Host update =over =item 1 First create a host with two ip-addresses and a contact -o host -c create -p E<34>%p=(name=>'ns7.test.no', v4=>['123.234.123.100','129.123.23.23'], contact=>'TAH8P')E<34> =item 2 Do an info to verify -o host -c info -p E<34>%p=(name=>'ns7.test.no')E<34> =item 3 Now, change/update it - The name is changed to a new name specified in key nname - 3 new ip-addresses are added, one of the existing is removed, thus 4 ip-addresses shall be the final result - The contact is deleted and changed to another one. -o host -c update -p E<34>%p=(name=>'ns7.test.no', nname=>'ns8.test.no', ipset=>{add=>{v4=>['1.2.3.1','1.2.3.2','1.2.3.3']}, del=>{v4=>'123.234.123.100'}}, contact=>{del=>'TAH8P', add=>'EFA2P'})E<34> =back =head2 Domain object commands =head3 Domain check =over =item 1 Check to see whether a domain name is available or registered -o domain -c check -p E<34>%p=(name=>'test.no')E<34> =back =head3 Domain info =over =item 1 Do an info on an existing domain -o domain -c info -p E<34>%p=(name=>'test.no')E<34> =back =head3 Domain create =over =item Notes =over =item * on the domain create methods in Net::DRI A lot of domain create methods are offered by Net::DRI. The client uses one specific create method, namely the domain_create_only(). =over =item * domain_create_only() This method assumes that the contacts handles and the nameservers listed are ALREADY created in the registry, and this is closest to Norid's datamodel. Hence, the client uses this method. =item * domain_create() This is another method which is a very powerful Net::DRI method. This method will do the same as domain_create_only(), but will also accept and handle full contacts and nameserver objects as parameters, meaning that it will check and create various objects as an integral part of the command. Support for this variant is not added to the client. =back =item * on the duration syntax The duration parameter must specify one year to be accepted in create, due to the period definition in lib/Net/DRI/DRD/NO.pm Duration syntax: 'duration=>{years=>1}' or 'duration=>{months=>12}' =back =item 1 Create a normal domain Create a single domain with a a registrant, a contact set with one type each, and two existing name servers, which is the minimum for .no: -o domain -c create -p E<34>%p=(name=>'test.no', pw=>'', registrant=>'THO12O', coset=>{tech=>'THO23P', admin=>'TH2345P'}, nsset=>['ns1.sol.no', 'ns2.sol.no'])E<34> =item 2 Create an IDN domain Create a single IDN-domain with a duration of 12 months, a registrant, a contact set with one type each, and two existing name servers, which is the minimum for .NO. IDN domains are converted to the ACE-form (xn--...) by the client, and the ACE-form is passed as the domain name to the registry. -o domain -c create -p E<34>%p=(name=>'test-ÆØÅ.no', pw=>'', duration=>{months=>12}, registrant=>'THO12O', coset=>{tech=>'THO23P', admin=>'TH2345P'}, nsset=>['ns1.sol.no', 'ns2.sol.no'])E<34> This should be accepted if the handles and name servers exist and the domain don't. =back =over =item Some domain create variants supported by Net::DRI but rejected by .NO registry policy. A lot of variants will pass the DRI, but should be rejected by the registry because of local policy. =over =item * Create a single domain with a pw and a contact set, no name servers -o domain -c create -p E<34>%p=(name=>'test.no', pw=>'xxx', registrant=>'THO12O', coset=>{tech=>'THO23P', admin=>'TH2345P'})E<34> =item * Create a single domain with a duration of 12 months, no contact set, but only a nameserver -o domain -c create -p E<34>%p=(name=>'test2.no', pw=>'', registrant=>'THO12O', nsset=>['ns1.sol.no', 'ns2.sol.no'])E<34> =item * Create a single domain with a duration of 12 months, no registrant, no contact set, but only a nameserver -o domain -c create -p E<34>%p=(name=>'test2.no', pw=>'', nsset=>['ns1.sol.no'])E<34> =item * Create a single domain with a a domain name only: -o domain -c create -p E<34>%p=(name=>'test2.no', pw=>'')E<34> =back =back =head3 Domain delete Delete domain, optionally specify the two optional Norid dates for removal from DNS and registry: -o domain -c delete -p E<34>%p=(name=>'test.no', deletefromregistry=>'2008-02-27', deletefromdns=>'2008-01-15')E<34> =head3 Domain update The domain name cannot be changed, otherwise all parameters may be changed. =over =item 1 Update (change) some domain attributes - registrant is changed - set authInfo to 'abc' - add and del on all the multiple objects, coset and nsset, which may be arrays or scalars -o domain -c update -p E<34>%p=(name=>'test.no', pw=>'abc', duration=>{months=>12}, registrant=>'TOH191O', coset=>{add=>{tech=>['TOH1P'], admin=>['TOH2P']}, del=>{tech=>['TOH1P'], admin=>['TOH2P', 'TOH3P']}}, nsset=>{add=>['ns1.sol.no', 'ns2.sol.no'], del=>'ns4.sol.no'})E<34> =item 2 Update of status flags Update is the only command where the status flags can be set/changed The flag values to use by the DRI user is the following (from Status.pm): my %s=('delete' => 'clientDeleteProhibited', 'renew' => 'clientRenewProhibited', 'update' => 'clientUpdateProhibited', 'transfer' => 'clientTransferProhibited', 'publish' => 'clientHold'); Example update when a couple of flags are set, and two already set are removed: -o domain -c update -p E<34>%p=(name=>'test.no', status=>{add=>['delete','publish'], del=>['update', 'transfer']})E<34> =back =head3 Domain renew Rule from DRD.pm: we must have : curexp+duration < now + maxdelta maxdelta = the permitted period which is 1 year (set in NO.pm). So basicly curexpiry must have a value between today (=now) and up to one year ahead in time. Values outside that generates a DRI-error. =over =item 1 Renew with minimum parameters DRI requires curexpiry, which should match the expiry date of the domain being renewed: -o domain -c renew -p E<34>%p=(name=>'ÆRE-pw-abc.no', curexpiry=>'2007-12-11')E<34> =item 2 Renew with max. parameters. We specify duration as well to two months -o domain -c renew -p E<34>%p=(name=>'ÆRE-pw-abc.no', curexpiry=>'2007-12-11', duration=>{months=>2})E<34> =back =head3 Domain withdraw This is a .NO specific extension command. Withdraw will transfer the domain to REG0, thus a registrar can push the responsibility for a domain into the bucket. -o domain -c withdraw -p E<34>%p=(name=>'test.no')E<34> If the sponsor for a domain is REG0, any registrar can do a transfer on it to take over the responsibility. =head2 Domain transfer commands Domain transfers are used if the registrant wants to change his registrar. He must then ask a new registrar to transfer his domains from the current registrar to the new one. =head3 authInfo is known, can use it in a direct 'transfer execute' If the registrant knows the authInfo, he passes it to the new registrar, who can do a transfer 'op=execute' containing the authInfo, and the transfer will be performed. - The execute must be authorized by the token. - An optional duration can specify a renew period for the domain (1-12 months). -o domain -c transfer_execute -p E<34>%p=(name=>'test.no', pw=>'abc', duration=>{months=>'6'})E<34> If the password is correct, the domain should be transferred. =head3 authInfo not known, must request one-time token If the registrant does not know the authInfo, the new registrar must initiate a transfer by sending a transfer request without authInfo. This will trig the registry to generate a one-time password (a token) and send it to the registrant, which in turn must pass the token to his new registrar. The new registrar can then send a transfer execute containing the token, and then the transfer will be performed. =over =item 1 Domain transfer request Initate a transfer request to ask for a token. The DRI-method used is domain_transfer_start(). The token will be sent to the primary email address registered on the registrant unless a special alternative address is selected. -o domain -c transfer -p E<34>%p=(name=>'test.no')E<34> Optionally, use the notify address to specify that the token shall be sent to another email address. It must match one of the registered email addresses: -o domain -c transfer -p E<34>%p=(name=>'test.no', notify=>{email=>'xml@example.no'})E<34> Optionally, specify that the token shall be sent by SMS to a mobilePhone number as notify address. It must match the registered mobilePhone number. -o domain -c transfer -p E<34>%p=(name=>'test.no', notify=>{mobilephone=>'+47123456789'})E<34> =item 2 Domain transfer query After a transfer request is received, the token is sent to the registrant. Until a transfer execute is received the domain will remain in a pending state. The status of pending transfers can be queried. -o domain -c transfer_query -p E<34>%p=(name=>'test.no')E<34> =item 3 Cancel a pending transfer A pending transfer can be cancelled. The token will be deleted and the pending state information will be restored to the normal state. -o domain -c transfer_cancel -p E<34>%p=(name=>'test.no') =item 4 Execute a pending transfer - Execute must be authorized by the token. - An optional duration can specify a renew period for the domain (1-12 months). -o domain -c transfer_execute -p E<34>%p=(name=>'test.no', token=>'MySecretToken', duration=>{months=>'9'})E<34> If the token is correct, the domain should be transferred. =back =head2 Polling the message queue =head3 Poll messages =over =item 1 message_waiting() This method performs a poll request and returns true if one or more messages are waiting in the queue. -o message -c waiting -p E<34>%p=()E<34> =item 2 message_count() This method performs a poll request and returns the 'msgQ count' value from the response, if any. -o message -c count -p E<34>%p=()E<34> =item 3 message_retrieve() This method performs a poll request, and with get_info() you can grab all the message details. -o message -c retrieve -p E<34>%p=()E<34> =item 4 message_delete() This is the poll ack message, which will remove message (with id=12) from the server message queue. -o message -c delete -p E<34>%p=(id=>12)E<34> =back =head2 Facets Facets are some special control attributes that can be used to trig special behaviour by the registry when a transaction is received. By use of facets, a registrar can suppress certain checks and perform actions on behalf of another registrar. The right do do such an operation could be defined as a super registrar function. The facets are only available for a registrar account when the account has been granted these special control rights by server configuration. Warning: If facets are attempted set by a non-authorized registrar account, they will be rejected. The registry may detect such abuse and apply prevailing actions towards non-authorized registrars, so don't play with this mechanism unless you know you have the rights to use a facet on your account. =head3 Facet keys, values and functionality Facets are key/value pairs and their names and syntax are decided by the registry. =head3 Facets usage in commands Facets may be set for any EPP command. To add facets into the parameter string, use the following facet syntax in the parameter string: facets => { '' => '', '' => '', => ', ... } =head1 COPYRIGHT Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =head1 AUTHOR Trond Haugen, Einfo@norid.noE =cut Net-DRI-0.96/eg/eurid_epp.pl0000755000175000017500000000753111136730204015400 0ustar patrickpatrick#!/usr/bin/perl -w # # # A Net::DRI example # See also t/606eurid_epp.t use strict; use Net::DRI; use DateTime::Duration; my $CLID='YOUR TEST CLIENT ID'; ### Change this information my $PASS='YOUR PASSWORD'; ### Change this information my $dri=Net::DRI->new({cache_ttl=>10,logging=>'files'}); eval { ############################################################################################################ $dri->add_registry('EURid',{clid=>$CLID}); ## This connects to .EU server for tests my $rc=$dri->target('EURid')->add_current_profile('profile1','epp',{client_login=>$CLID,client_password=>$PASS}); die($rc) unless $rc->is_success(); ## Here we catch all errors during setup of transport, such as authentication errors my $c1=new_contact($dri,'registrant'); my $c2=new_contact($dri,'billing'); my $c3=new_contact($dri,'tech'); $rc=$dri->contact_create($c1); die($rc) unless $rc->is_success(); my $id=$dri->get_info('id'); print "Contact1 created, id=$id\n"; $c1->srid($id); $rc=$dri->contact_create($c2); die($rc) unless $rc->is_success(); $id=$dri->get_info('id'); print "Contact2 created, id=$id\n"; $c2->srid($id); $rc=$dri->contact_create($c3); die($rc) unless $rc->is_success(); $id=$dri->get_info('id'); print "Contact3 created, id=$id\n"; $c3->srid($id); my $dom='toto-'.time().'.eu'; $rc=$dri->domain_check($dom); print "$dom does not exist\n" unless $dri->get_info('exist'); my $cs=$dri->local_object('contactset'); $cs->set($c1,'registrant'); $cs->set($c2,'billing'); $cs->set($c3,'tech'); print "Attempting to create domain $dom\n"; $rc=$dri->domain_create($dom,{pure_create=>1,duration=>DateTime::Duration->new(years =>1),ns=>$dri->local_object('hosts')->set('ns.example.com'),contact=>$cs}); print "$dom created\n" if $rc->is_success(); ## After the domain:create, the connection is dropped by the server ## Net::DRI will see that and reconnect automatically $rc=$dri->domain_check($dom); print "$dom does exist now\n" if $dri->get_info('exist'); $rc=$dri->domain_info($dom); print "domain_info OK\n" if $rc->is_success(); my $ns='ns.titi-'.time().'.fr'; my $nso=$dri->local_object('hosts')->set($ns); print "NS=$ns\n"; if ($dri->has_object('ns')) ## Should be false for EURid { my $e=$dri->host_exist($ns); print "Host exist\n" if ($e==1); if ($e==0) { print "Creating $ns\n"; $rc=$dri->host_create($nso); print "Host created OK\n"; } } $rc=$dri->domain_update_ns_add($dom,$nso); print "ns_add OK\n" if $rc->is_success(); $rc=$dri->domain_info($dom); $rc=$dri->domain_update_ns_del($dom,$nso); print "ns_del OK\n" if $rc->is_success(); $rc=$dri->domain_info($dom); # No domain status handling in EURid #my $s=$dri->create_status()->no('update'); #$rc=$dri->domain_update_status_add($dom,$s); #print "status_add OK\n" if $rc->is_success(); #$rc=$dri->domain_info($dom); #$rc=$dri->domain_update_status_del($dom,$s); #print "status_del OK\n" if $rc->is_success(); #$rc=$dri->domain_info($dom); $rc=$dri->domain_delete($dom,{pure_delete => 1}); print "domain_delete OK\n" if $rc->is_success(); $rc=$dri->contact_delete($c1); print "Contact1 deleted successfully" if $rc->is_success(); $rc=$dri->contact_delete($c2); print "Contact2 deleted successfully" if $rc->is_success(); $rc=$dri->contact_delete($c3); print "Contact3 deleted successfully" if $rc->is_success(); $dri->end(); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if (ref($@)) { $@->print(); } else { print($@); } } else { print "\n\nNo exception happened"; } print "\n"; exit 0; ###################################################### sub new_contact { my ($dri,$type)=@_; my $c=$dri->local_object('contact'); $c->name('My Name'); $c->org('My Organisation àé æ'.time()); $c->street(['My Address']); $c->city('My city'); $c->pc(11111); $c->cc('FR'); $c->email('test@example.com'); $c->lang('fr'); $c->type($type); $c->voice('+44.1111111'); $c->fax('+55.2222222'); return $c; } Net-DRI-0.96/eg/epp_client_se.pl0000755000175000017500000014663011241344353016244 0ustar patrickpatrick#!/usr/bin/perl -w ## ## Copyright (c) 2008 .SE, , ## Jan Saell ## All rights reserved. ## ## This program illustrate the usage of Net::DRI towards the .SE registry. ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. ## ## ## ## ----------------- ## ## What is this: A Net::DRI based command line client for .SE ## ## Note that it is developed for test purposes, not to be a complete client. ## ## The -p argument is expected to carry a %p parameter hash argument string ## which can be eval'ed into a %p hash, like this for a host create operation: ## -o host -c create -p "%p=(name=>'ns1.suniswanted.no',v4=>'123.234.123.12')" ## ## See POD section at the end for further details. ## ####### use strict; use Net::DRI; use DateTime::Duration; use Pod::Usage; use POSIX qw(locale_h); use Net::LibIDN ':all'; use Getopt::Std; use Data::Dumper; $Data::Dumper::Indent=1; use encoding "utf-8"; # assume utf-8 encoded argument input our $VERSION = '0.90.se'; our $SVN_VERSION = do { my @r = ( q$Revision: 1.1 $ =~ /\d+/gxm ); sprintf( "%d" . ".%02d" x $#r, @r ); }; # Format string for output of results my $F = " %-15s: %s\n"; # All possible dri object methods my @drim = ('id'); # All possible contact object methods my @cm = ( # standard DRI methods 'loid', 'srid', 'id', 'roid', 'name', 'org', 'street', 'city', 'sp', 'pc', 'cc', 'email', 'voice', 'fax', 'auth', 'disclose', # .se extra methods 'orgno', 'vatno', 'clientDelete', # Secdns extensions 'secdns', ); # args use vars qw($opt_c $opt_o $opt_h $opt_p $opt_f $opt_P $opt_S $opt_L $opt_C $opt_W $opt_w); # Operations my %op = ( 'hello' => 1, 'create' => 1, 'update' => 1, 'delete' => 1, 'info' => 1, 'poll' => 1, 'check' => 1, 'renew' => 1, 'transfer' => 1, # message operations 'waiting' => 1, 'count' => 1, 'retrieve' => 1, # delete op is already defined ); # Objects my %obj = ( 'contact' => 'contact', 'person' => 'contact', 'organization' => 'contact', 'role' => 'contact', 'host' => 'host', 'domain' => 'domain', 'message' => 'message', ); # Hash to hold the EPP arguments my %p; &getopts("Lo:c:p:f:S:P:C:W:"); #server and port must be specified my $socktype = 'tcp'; die "No server specified" unless ($opt_S); die "No port specified" unless ($opt_P); die "No client id specified" unless ($opt_C); die "No password specified" unless ($opt_W); my $server = $opt_S; my $port = $opt_P; $socktype = 'ssl' if ($opt_L); my $clid = $opt_C; my $pass = $opt_W; my $newpass; unless ( $opt_c && $op{$opt_c} ) { pexit("Specify a valid command"); } unless ( $opt_c eq 'hello' ) { unless ( $opt_o && $obj{$opt_o} ) { pexit("Specify a valid object type"); } unless ($opt_p) { pexit("Specify a parameter string"); } #print "p: $opt_p \n"; unless ( parse_params($opt_p) ) { pexit("Specify a valid parameter string"); } } my $t1 = time(); my $logf = 'results-' . time() . '.log'; $logf = $opt_f if ($opt_f); open( my $fh, '>>', $logf ) || die $!; do_epp_operation( $obj{$opt_o}, $opt_c, $clid, $pass, $newpass, $socktype, $server, $port, $fh, %p ); my $t2 = time(); print "\nTime used: ", $t2 - $t1, "secs\n"; ############ # # S U B S # ########### sub parse_params { my $p = shift; eval $opt_p; # assume a Data::Dumper syntax, read pars with eval! if ($@) { # eval has failed, $@ tells us why pexit( "Eval failed, specify a valid parameter string, msg: " . $@ . "\n" ); } return 1; } sub do_epp_operation { my ( $obj, $cmd, $clid, $pw, $newpw, $socktype, $server, $port, $fh, %p ) = @_; my $res = 1; select($fh); $|++; select(STDOUT); #print "Dumping XML exchange to $logf\n"; my ( $dri, $rc ); eval { ( $dri, $rc ) = init_reg_se( $clid, $pw, $newpw, $socktype, $server, $port, $fh ); do_command( $obj, $cmd, $dri, $rc, %p ); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if ( ref($@) ) { print "FAILURE: Error descriptions: ", ref($@), "\n"; $@->print(); print "\n"; dump_conditions($dri); } else { print "FAILURE: No extra info: "; print($@); } $res = 0; } else { print "\n\nSUCCESS"; } print "\n"; # Important not to call dri->end too early, because condition date may be # destroyed. $dri->end(); close($fh); return $res; } sub pexit { print shift, "\n\n"; # The error text supplied pod2usage( { -message => $0, -exitval => 0 } ); return; } sub print_result { my $dri = shift; my $rc = shift; print "\n", " result_code : ", $dri->result_code(), "\n", " native_code : ", $dri->result_native_code(), "\n", " result_message : ", $dri->result_message(), "\n", " language : ", $dri->result_lang(), "\n\n"; if ( $dri->can('result_is_pending') ) { print " pending : ", $dri->result_is_pending(), "\n"; } if ( $dri->can('result_info') ) { print "info : ", $dri->result_info(), "\n"; } if ( $dri->can('result_print') ) { print "result_print: ", $dri->result_print(), "\n"; } if ( $dri->can('result_print_full') ) { print "result_print_full: ", $dri->result_print_full(), "\n"; } if ($rc) { print_rc_result($rc); } foreach my $w ( 'action', 'exist', 'trStatus', 'reID', 'reDate', 'acID', 'acDate', 'exDate' ) { if ( my $v = $dri->get_info($w) ) { printf "$F", $w, $v; } } return 1; } sub print_rc_result { my $rc = shift; # Print rc-specific info, not found in $dri->result_*() if ( $rc->can('is_pending') ) { print "rcpending : ", $rc->is_pending(), "\n" if ( $rc->is_pending() ); } if ( $rc->can('info') ) { print "rcinfo : ", $rc->info(), "\n" if ( $rc->info() ); } my $F2 = " %-15s: %s%s\n"; if ( $rc->can('trid') && $rc->trid() ) { # trid seems to be returned as an array with two values printf "$F2", 'trid', $rc->trid(); } return 1; } sub contact_object_as_string { my ( $dri, $o, @om ) = @_; return unless $o; # Populate the loc-array values # $ci->int2loc(); # hmm, if int2loc is called, it overwrites the # localized data and destroys some of it my $s = ""; foreach my $m (@om) { my $r; if ( $o->can($m) ) { if ( $m eq 'street' ) { # Is an array up to 3 elements $r = join ", ", @{ $o->$m }; } elsif ( $m eq 'identity' ) { $r = "type : " . $o->$m->{type} if ( $o->$m && $o->$m->{type} ); $r .= ", value: " . $o->$m->{value} if ( $o->$m && $o->$m->{value} ); } elsif ( $m eq 'xemail' || $m eq 'rolecontact' ) { # Is an array up to n elements $r = join ", ", @{ $o->$m } if ( $o->$m ); } else { my @va; @va = $o->$m if ( $o->$m ); foreach my $v (@va) { if ( ref($v) && ( ref($v) ne 'SCALAR' ) ) { # don't bother diving into it ... use a Dumper $r .= sprintf Dumper $v; } else { $r .= $v if ($v); } } } $s .= sprintf "$F", $m, $r if ($r); } else { $s .= "-- method $m not possible \n"; } } foreach my $i ( 'roid', 'crDate', 'upDate', 'clID', 'crID', 'upID' ) { my $v = $dri->get_info($i); $v = '-' unless $v; $s .= sprintf "$F", $i, $v; } return $s; } sub host_object_as_string { my ($dri) = @_; my $s = ""; my $hi = $dri->get_info('self'); foreach my $m ( 'loid', 'count' ) { my $v = '-'; $v = $hi->$m if ( $hi->$m ); $s .= sprintf "$F", $m, $v; } my @nms = $hi->get_names(); $s .= sprintf "$F", 'names', @nms; foreach my $n (@nms) { my @d = $hi->get_details($n); # ip-addresses are optional my @v; @v = @{ $d[1] } if ( @{ $d[1] } ); @v = ("-") unless (@v); $s .= sprintf "$F", 'v4 addresses', join( ", ", @v ); @v = (); @v = @{ $d[2] } if ( @{ $d[2] } ); @v = ("-") unless (@v); $s .= sprintf "$F", 'v6 addresses', join( ", ", @v ); } # contact is a scalar my $ct = "-"; if ( $ct = $dri->get_info('contact') ) { $s .= sprintf "$F", 'contact', $ct; } foreach my $i ( 'roid', 'exDate', 'crDate', 'upDate', 'trDate', 'clID', 'crID', 'upID' ) { my $v = $dri->get_info($i); $v = '-' unless $v; $s .= sprintf "$F", $i, $v; } return $s; } #You may use get_info with the following keys to get more information: # - ns : a Net::DRI::Data::Hosts object representing the nameservers of the # domain # - status : a Net::DRI::Data::StatusList object representing the current # status list of the domain queried # - exDate, crDate, upDate, trDate : DateTime objects representing the # expiration, creation, last update, and transfer date for the domain # queried # - clID, crID, upID : (strings) local registry ID of the current sponsoring # registrar, the registrar having created, and the registrar (or # registry) having last modified the domain queried sub domain_object_as_string { my ($dri) = @_; my $s = ""; ## # authInfo # $s .= sprintf "--- Auth info ---\n"; my $au = $dri->get_info('auth'); foreach my $i ( 'name', 'roid', 'exDate', 'crDate', 'upDate', 'trDate', 'delDate', 'deactDate', 'clID', 'crID', 'upID', ) { my $v = $dri->get_info($i); $v = '-' unless $v; $s .= sprintf "$F", $i, $v; if ( $i eq 'name' ) { # Also print the UTF-8 of an ACE my $idn = idn_to_unicode( $v, 'utf-8', IDNA_USE_STD3_ASCII_RULES ); $s .= sprintf "$F", 'IDN-name', $idn; } } ## # name servers # my $v; my $ns = $dri->get_info('ns'); if (defined ($ns) ) { $s .= sprintf "--- Name servers ---\n"; $v = '-'; if ( ( $v = $ns->count() ) > 0 ) { $s .= sprintf "$F", 'ns count', $v; } foreach my $n ( $ns->get_names() ) { $s .= sprintf "$F", 'ns name', $n; } } #################### # Contacts # # contact is an array ref. my $co = $dri->get_info('contact'); $s .= sprintf "--- Contacts ---\n"; foreach my $ct ( 'registrant', 'admin', 'tech' ) { my @r = $co->get($ct); my $v = "-"; foreach my $r (@r) { $v = $r->srid if ( $r->srid ); $s .= sprintf "$F", $ct, $v; } } ## # SecDNS # my $secdns = $dri->get_info('secdns'); if (defined ($secdns) ) { $s .= sprintf "--- Secure DNS ---\n"; my $count = scalar(@$secdns); if ($count > 0) { $s .= sprintf "$F", 'SecDNS Key count', $count; #print "SecDNS: ", Dumper \$secdns; my $i = 0; while ($i < $count) { my $n = $secdns->[$i]; $s .= sprintf "$F", 'SecDNS keyTag', $n->{keyTag}; $s .= sprintf "$F", ' digestType', $n->{digestType}; $s .= sprintf "$F", ' alg', $n->{alg}; $s .= sprintf "$F", ' digest', $n->{digest}; $i++; } } } #################### # Domain status # $s .= sprintf "--- Status summary ---\n"; my $st = $dri->get_info('status'); # domain status methods my @dsm = ( 'is_active', 'is_published', 'is_pending', 'is_linked', 'can_update', 'can_transfer', 'can_delete', 'can_renew', #'possible_no', # hmmm.. what's this for? #'no' # hmmm.. what's this for? ); foreach my $ds (@dsm) { $v = "-"; $v = $st->$ds if ( $st->$ds ); $s .= sprintf "$F", $ds, $v; } #### # also dump all the detailed status values my @ls = $st->list_status(); $s .= sprintf "--- Flag details ---\n"; foreach my $l (@ls) { $s .= sprintf "$F", 'flag', $l; } return $s; } sub get_info_object_as_string { my ( $o, @om ) = @_; my $s = ""; foreach my $m (@om) { my $v = "-"; if ( $o->get_info($m) ) { $v = $o->get_info($m); if ( $v && ref($v) && ( ref($v) ne 'SCALAR' ) ) { # don't bother diving into it ... use a Dumper $v = sprintf Dumper $v; next; } $s .= sprintf "$F", $m, $v; } else { $s .= "-- method $m not possible \n"; } } return $s; } sub init_reg_se { my ( $clid, $pw, $newpw, $socktype, $server, $port, $fh ) = @_; my $dri = Net::DRI->new(10); $dri->add_registry( 'SE', { clid => $clid } ); my %pars = ( log_fh => $fh || \*STDERR, defer => 0, socktype => $socktype, remote_host => $server || 'epptest.iis.se', remote_port => $port || 700, protocol_connection => 'Net::DRI::Protocol::EPP::Connection', protocol_version => 1, client_login => $clid, client_password => $pw, ); $pars{client_newpassword} = $newpw if ($newpw); my $rc = $dri->target('SE')->new_current_profile( 'profile1', 'Net::DRI::Transport::Socket', [ { %pars, } ], 'Net::DRI::Protocol::EPP::Extensions::SE', [ '1.0', [ 'SecDNS', 'Net::DRI::Protocol::EPP::Extensions::SE::Extensions', ], ] ); ## Here we catch all errors during setup of transport, such as ## authentication errors die($rc) unless $rc->is_success(); return ( $dri, $rc ); } sub do_command { my ( $obj, $cmd, $dri, $rc, %p ) = @_; use Data::Dumper; $Data::Dumper::Indent = 1; if ( $cmd eq 'hello' ) { print "*** hello ***\n"; # no objects in this case $rc = $dri->process( 'session', 'noop', [] ); die($rc) unless $rc->is_success(); ## Her print "Hello was a success\n"; exit 0; } print "*** Executing EPP command: $obj . $cmd ***\n"; if ( $obj eq 'host' ) { if ( $cmd eq 'check' ) { print ".check ", $p{name}, "\n"; $rc = $dri->host_check( $p{name} ); print_result( $dri, $rc ); die($rc) unless $rc->is_success(); # For a host check, only an exist check is available in DRI print "Host $p{name} ", $dri->get_info('exist') ? "exists" : "do not exist"; } if ( $cmd eq 'info' ) { my %oi; # host info can specify a ownerid $oi{ownerid} = $p{ownerid} if ( $p{ownerid} ); $rc = $dri->host_info( $p{name}, \%oi ); print_result( $dri, $rc ); die($rc) unless $rc->is_success(); print host_object_as_string($dri); } if ( $cmd eq 'create' ) { # DRI 0.85 need to create the hosts objects directly .. my $nso = $dri->local_object('hosts'); $nso->add( $p{name}, $p{v4}, $p{v6} ); if ( $p{contact} ) { $rc = $dri->host_create( $nso, { contact => $p{contact} } ); } else { $rc = $dri->host_create($nso); } print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'update' ) { ### # We can change all params, name, ip-addresses and contact # Proper add/del keys must be supplied by the user to do this my $toc = $dri->local_object('changes'); if ( $p{ipset} ) { # add and del keys shall describe what to do my ( $v4a, $v4d , $v6a, $v6d ); $v4a = $p{ipset}{add}{v4} if ( $p{ipset}{add}{v4} ); $v4d = $p{ipset}{del}{v4} if ( $p{ipset}{del}{v4} ); $v6a = $p{ipset}{add}{v6} if ( $p{ipset}{add}{v6} ); $v6d = $p{ipset}{del}{v6} if ( $p{ipset}{del}{v6} ); # Add if ($v4a) { if ($v6a) { $toc->add( 'ip', $dri->local_object('hosts')->add( $p{name}, $v4a, $v6a ) ); } else { $toc->add( 'ip', $dri->local_object('hosts')->add( $p{name}, $v4a, [] ) ); } } else { if ($v6a) { $toc->add( 'ip', $dri->local_object('hosts')->add( $p{name}, [], $v6a ) ); } } # Del if ($v4d) { if ($v6d) { $toc->del( 'ip', $dri->local_object('hosts')->add( $p{name}, $v4d, $v6d ) ); } else { $toc->del( 'ip', $dri->local_object('hosts')->add( $p{name}, $v4d, [] ) ); } } else { if ($v6d) { $toc->del( 'ip', $dri->local_object('hosts')->add( $p{name}, [], $v6d ) ); } } } # Update name if nname is specified if ( $p{nname} && $p{nname} ne $p{name} ) { # a new name is specified, insert it as a chg $toc->set( 'name', $p{nname} ); } # # Contact data if ( defined( $p{contact} ) ) { # add and del keys shall describe what to do foreach my $s ( 'add', 'del' ) { my $n = $p{contact}{$s}; $toc->$s( 'contact', $n ) if ( defined($n) && $n ); } } $rc = $dri->host_update( $p{name}, $toc ); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'delete' ) { $rc = $dri->host_delete( $p{name} ); print_result($dri); die($rc) unless $rc->is_success(); } } if ( $obj eq 'contact' ) { if ( $cmd eq 'check' ) { my $co = $dri->local_object('contact')->new()->srid( $p{srid} ); $rc = $dri->contact_check($co); print_result($dri); die($rc) unless $rc->is_success(); print "Contact $p{srid} ", $dri->get_info('exist') ? " exists" : "do not exist"; } if ( $cmd eq 'info' ) { my $co = $dri->local_object('contact')->new()->srid( $p{srid} ); $rc = $dri->contact_info($co); # print "Contact $p{srid} ", $dri->get_info('exist')?" exists":"do not exist"; print_result($dri); die($rc) unless $rc->is_success(); my $o = $dri->get_info('self'); print contact_object_as_string( $dri, $o, @cm ); } if ( $cmd eq 'create' ) { my $co = $dri->local_object('contact')->new(); # auth not supported for .NO contact foreach my $m (@cm) { #next if $m eq 'sp'; # Not supported by .NO today, # but better to let server reject in case that changes my $v = $p{$m}; #print STDERR "ref $m: ", ref($p{$m}), "\n"; $co->$m( $p{$m} ) if ( $p{$m} ); } $rc = $dri->contact_create($co); print_result($dri); die($rc) unless ( $rc->is_success() ); #print contact_object_as_string($dri, $co, @cm); print get_info_object_as_string( $dri, @drim ); } if ( $cmd eq 'update' ) { ### # We can change all params, name, ip-addresses and contact # Proper add/del keys must be supplied by the user to do this ######### my $co = $dri->local_object('contact')->srid( $p{srid} ); my $toc = $dri->local_object('changes'); my $co2 = $dri->local_object('contact'); foreach my $m (@cm) { $co2->$m( $p{$m} ) if ( $p{$m} ); } $toc->set( 'info', $co2 ); if ( $p{type} ) { $toc->set( 'type', $p{type} ); } if ( $p{mobilephone} ) { $toc->set( 'mobilephone', $p{mobilephone} ); } if ( $p{xdisclose} ) { $toc->set( 'xdisclose', $p{xdisclose} ); } if ( $p{identity} ) { $toc->set( 'identity', $p{identity} ); } # # organization data # if ( $p{organization} ) { # add and del keys shall describe what to do foreach my $s ( 'add', 'del' ) { my $n = $p{organization}{$s}; $toc->$s( 'organization', $n ) if ( defined($n) && $n ); } } # # RoleContact data # if ( $p{rolecontact} ) { # add and del keys shall describe what to do foreach my $s ( 'add', 'del' ) { my $n = $p{rolecontact}{$s}; $toc->$s( 'rolecontact', $n ) if ( defined($n) && $n ); } } # # xemail data # if ( $p{xemail} ) { # add and del keys shall describe what to do foreach my $s ( 'add', 'del' ) { my $n = $p{xemail}{$s}; $toc->$s( 'xemail', $n ) if ( defined($n) && $n ); } } $rc = $dri->contact_update( $co, $toc ); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'delete' ) { my $co = $dri->local_object('contact')->new()->srid( $p{srid} ); $rc = $dri->contact_delete($co); print_result($dri); die($rc) unless $rc->is_success(); # Do an info to verify the delete print "Verifying delete by an info ....: \n"; do_command( $obj, 'info', $dri, $rc, %p ); } } if ( $obj eq 'domain' ) { my ( $ace, $idn ); # We accept input name as either an ace-name or an utf-8 if ( $p{name} ) { $idn = lc( $p{name} ); die "Cannot lower case domain name: $idn" unless ($idn); $ace = idn_to_ascii( $idn, 'utf-8', IDNA_USE_STD3_ASCII_RULES ); die "Cannot convert domain to ace" unless ($ace); $idn = idn_to_unicode( $ace, 'utf-8', IDNA_USE_STD3_ASCII_RULES ); die "Cannot convert domain to ace" unless ($ace); undef $idn if ( $ace eq $idn ); } else { die "No domain name specified"; } #print "input name: $p{name}\n"; #print "ace : $ace\n"; #print "idn : $idn\n"; die "Illegal domain name" unless ($ace); if ( $cmd eq 'check' ) { $rc = $dri->domain_check($ace); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); print "Domain $p{name} ", $dri->get_info('exist') ? " exists" : "do not exist"; } if ( $cmd eq 'info' ) { $rc = $dri->domain_info($ace); print_result($dri); die($rc) unless $rc->is_success(); print domain_object_as_string($dri); } if ( $cmd eq 'create' ) { # # A create is supported as follows: # A domain name in 'name' # A contact set in coset=>{billing=>'THO123', admin=>'TH2345P', ... # A name server set in nsset=>{billing=>'THO123', admin=>'TH2345P', ... # my $cs = $dri->local_object('contactset'); my $du; if ( $p{duration} ) { $du = DateTime::Duration->new( $p{duration} ); die "Illegal duration value" unless ($du); } $cs->set( $dri->local_object('contact')->srid( $p{registrant} ), 'registrant' ) if ( $p{registrant} ); my $c; if ( $c = $p{coset} ) { # we have a contact set, DRI accepts multiple of each type, so we implement ## that and let server policy decide if multiple can be accepted my @acs; my @ca; foreach my $t ( 'admin', 'billing', 'tech' ) { if ( $c->{$t} ) { if ( ref( $c->{$t} ) eq 'ARRAY' ) { @ca = @{ $c->{$t} }; } else { # A single scalar srid push @ca, $c->{$t}; } foreach my $s (@ca) { push @acs, $dri->local_object('contact')->srid($s); } $cs->set( [@acs], $t ); undef @ca; undef @acs; } } } # see the DRI README doc. # - domain_create() does a lot of checking and creating if the objects does # not exist, # - domain_create_only() has a simpler behaviour # We use domain_create_only(), it's simplest my $nso = $dri->local_object('hosts'); if ( $p{nsset} ) { if ( my @ns = @{ $p{nsset} } ) { foreach my $n (@ns) { $nso->add( $n, [], [] ); } } } # Secdns my @secdnso; if ( $p{secdns} ) { if ( my @secdns = @{ $p{secdns} } ) { @secdnso = @secdns; } } $rc = $dri->domain_create_only( $ace, { auth => { pw => $p{pw} }, duration => $du, contact => $cs, ns => $nso, secdns => [ @secdnso ] } ); print_result($dri); die($rc) unless ( $rc->is_success() ); } if ( $cmd eq 'update' ) { ### # We can change most params, but not domain name or duration # Proper add/del keys must be supplied by the user to do this my $cs = $dri->local_object('contactset'); my $toc = $dri->local_object('changes'); $toc->set( 'registrant', $dri->local_object('contact')->srid( $p{registrant} ), 'registrant' ) if ( $p{registrant} ); # Update is the only command where the status flags can be set/changed # The flag values to use by the DRI user is the following (from Status.pm): # my %s=('delete' => 'clientDeleteProhibited', # 'renew' => 'clientRenewProhibited', # 'update' => 'clientUpdateProhibited', # 'transfer' => 'clientTransferProhibited', # 'publish' => 'clientHold', # ); if ( $p{pw} ) { $toc->set( 'auth', { pw => $p{pw} } ); } if ( defined( $p{clientDelete} ) && ( ( $p{clientDelete} == 0 ) || ( $p{clientDelete} == 1 ) ) ) { $toc->set( 'client_delete', $p{clientDelete} ); } if ( my $s = $p{status} ) { foreach my $op ( 'add', 'del' ) { my $sl = $dri->local_object('status'); # add and del keys shall describe what to do my $a; $a = $p{status}{$op} if ( $p{status}{$op} ); # array or not if ( ref($a) eq 'ARRAY' ) { foreach my $m (@$a) { $sl->no($m); } } else { $sl->no($a); } $toc->$op( 'status', $sl ) or die "Invalid status value"; } } if ( my $c = $p{coset} ) { # we have a contact set, DRI accepts multiple of each type, so we implement # that and let server policy decide if multiple can be accepted my @acs; my @ca; # add and del keys shall describe what to do foreach my $op ( 'add', 'del' ) { $cs = $dri->local_object('contactset'); foreach my $r ( 'admin', 'billing', 'tech' ) { if ( my $v = $c->{$op}->{$r} ) { if ( ref($v) eq 'ARRAY' ) { @ca = @{$v}; } else { # A single scalar srid push @ca, $v; } foreach my $va (@ca) { push @acs, $dri->local_object('contact')->srid($va); } } $cs->set( [@acs], $r ); undef @ca; undef @acs; } $toc->$op( 'contact', $cs ); undef $cs; } } if ( $p{nsset} ) { foreach my $op ( 'add', 'del' ) { # add and del keys shall describe what to do my $a; $a = $p{nsset}{$op} if ( $p{nsset}{$op} ); # array or not if ( ref($a) eq 'ARRAY' ) { print "Here: ", Dumper \$a; foreach my $m (@$a) { $toc->$op( 'ns', $dri->local_object('hosts')->add($m) ); } } else { $toc->$op( 'ns', $dri->local_object('hosts')->add($a) ); } } } if ( $p{secdns} ) { foreach my $op ( 'add', 'del' ) { # add and del keys shall describe what to do my $a; $a = $p{secdns}{$op} if ( $p{secdns}{$op} ); # array or not if ( ref($a) eq 'ARRAY' ) { foreach my $m (@$a) { $toc->$op( 'secdns', $m ); } } else { $toc->$op( 'secdns', $a ); } } } $rc = $dri->domain_update( $ace, $toc ); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'delete' ) { die "Cannot delete domain, rejected by DRI:domain_status_allows_delete()" unless ( $dri->domain_status_allows_delete($ace) ); my %a; $a{deletefromdns} = $p{deletefromdns} if $p{deletefromdns}; $a{deletefromregistry} = $p{deletefromregistry} if $p{deletefromregistry}; $rc = $dri->domain_delete_only( $ace, \%a ); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'transfer' ) { # this is a transfer init operation. my %a; $a{auth} = { pw => $p{pw} } if ( $p{pw} ); # notify parameters if ( $p{notify} ) { # Only one is accept $a{mobilephone} = $p{notify}{mobilephone} if ( $p{notify}{mobilephone} ); $a{email} = $p{notify}{email} if ( $p{notify}{email} ); } $rc = $dri->domain_transfer_start( $ace, \%a ); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } if ( $cmd eq 'renew' ) { my $du = undef; if ( $p{duration} ) { $du = DateTime::Duration->new( $p{duration} ); die "$0: Illegal duration value" unless ($du); } my $exp = undef; if ( $p{curexpiry} ) { my ( $y, $m, $d ) = split '-', $p{curexpiry}; $exp = DateTime->new( year => $y, month => $m, day => $d ); die "$0: Illegal curexpiry date " unless ($exp); } $rc = $dri->domain_renew( $ace, $du, $exp ); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } } # End of domain operations # Standardized EPP elements my @epp = ( 'id', 'qdate', 'msg', 'content', 'lang', 'object_type', 'object_id', 'action', 'result', 'trid', 'svtrid', 'date', ); my %m; # Message / poll operations if ( $obj eq 'message' ) { if ( $cmd eq 'waiting' ) { print "Poll: messages waiting: ", $dri->message_waiting(), "\n"; } if ( $cmd eq 'count' ) { print "Poll: message count: ", $dri->message_count(), "\n"; } if ( $cmd eq 'retrieve' ) { $rc = $dri->message_retrieve(); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); if ( my $c = ($dri->message_count() > 0) ) { # messages returned for ( my $i = 1; $i <= $c; $i++ ) { my $li = $dri->get_info('last_id'); my ($qda, $lng, $cnt, $oty, $oid, $act, $res, $ctr, $str, $tr, $dat ); if ( defined($li) && $li) { foreach my $e (@epp) { my $v; $v = $dri->get_info( $e, 'message', $li ); if (defined($v) && $v) { if ($e eq 'qdate') { # make the DateTime object a scalar time string $v = sprintf $v; } $m{$e} = $v; } } } } } # Just dump the message elements print "message: ", Dumper \%m; } if ( $cmd eq 'delete' ) { if ( my $id = $p{id} ) { $rc = $dri->message_delete($id); print_rc_result($rc); print_result($dri); die($rc) unless $rc->is_success(); } else { print "Poll: No 'id' specified\n"; } } } return; } sub dump_conditions { my $dri = shift; # get the conditions array from $rinfo structure which is built by Result.pm # my $cd = $dri->get_info('conditions'); #print "cd: ", Dumper $cd; foreach my $c (@$cd) { foreach my $i ( 'code', 'severity', 'msg', 'details' ) { my $v; $v = '-' unless ( $v = $c->{$i} ); printf "$F", $i, $v; } } return; } #__END__ =pod =head1 NAME epp_client_se.pl - A command line client program using Net::DRI towards the .SE EPP registry. =head1 DESCRIPTION The client supports creation and maintainance of host, contact and domain objects for .SE. It supports transfer operations, as well as poll operation for the message queue. It was developed for testing of the .SE extensions to Net::DRI, but can probably be used by users who are comfortable with a simple command line interfaces. =head1 SYNOPSIS =head2 Command line B =head3 Arguments =over =item Mandatory connect arguments -C: Client ID, your EPP registrar account name, typical regxxx, where xxx is a number -W: Account password, your EPP account password -S: Server name, the registry server -P: EPP server port =item Optional connect arguments -f: Log file. The Net::DRI raw XML exchange will be dumped to this file -L: Use SSL connection =item Command arguments The command argument specify the EPP operation to perform: -o: EPP object. One of contact, host, domain, message -c: EPP command. One of hello, create, update, info, delete, transfer, count, waiting, retrieve -p: EPP parameter argument string, in a format that can be eval'ed into a hash, se parameter string examples below. =back =head3 About each EPP command sequence Each command will be performed as follows: - Socket connect, session initiation, a greeting is returned - an EPP login, which will succeed if the connect arguments are correct, otherwise fail, a greeting is returned if login is OK - an EPP command, according to the specified command arguments - an EPP logout - Session termination =head3 A simple connect and greeting test Basic connect to an EPP server should give you a greeting back if successful. A simple connect to an EPP server and port: Raw port (no SSL): telnet Encrypted with SSL: openssl s_client -host -port =head3 About logging and filtering of the log output Logging is useful for debugging purposes, A client side log can be activated by -f option, like: '-f xx.log' Tail on the log-file in a separate window is nice then. Even nicer is to filter the tail through the supplied xmlfilter.pl utility, which will wrap the raw XML to a pretty-printed dump. The filters '-s' option will skip all the login/logout and greetings which otherwise will dominate the outpot. 'tail -f xx.log | ./xmlfilter.pl -s' =head3 About authInfo Auth-info (pw) can be set and updated only for domain objects, and is needed only for a transfer. =head1 EPP commands and arguments =head2 Hello command =over =item Hello -c hello -o host -p E<34>%p=()E<34> A greeting shall be returned. =back =head2 Contact object commands =head3 Contact create A .SE contact can be one of two types, person, or organization. For each contact created, the type must be specified via the mandatory type extension. =over =item 1 Organization contact -o contact -c create -p E<34>%p=(id=>'testse0810-0001', name=>'Anders ANdersson', org=>'Exempel AB', street=>['Box 42','Exempelfatan 42'], city=>'Stockholm', pc=>'12345', cc=>'SE', voice=>'+46.12345678', fax=>'+46.12345679', email=>'test@test.se', auth=>{pw=>''}, orgno=>'[SE]551234-5678', vatno=>'SE551234567801', disclose=>{voice=>0, email=>0})E<34> =item 3 Person contact -o contact -c create -p E<34>%p=(id=>'testse0811-0002', name=>'Anders Andersson', street=>['Exempelgatan 42'], city=>'Stockholm', pc=>'12345', cc=>'SE', voice=>'+46.12345678', fax=>'+46.12345679', email=>'test@test.se', auth=>{pw=>''}, orgno=>'[SE]640823-3234')" =back =head3 Contact update In this example, a role contact update is shown. =over =item Contact update -o contact -c update -p E<34>%p=(srid=>'testse0811-0002', street=>['Exempelgatan 24'], city=>'Stockholm', pc=>'12354', fax=>'+46.12345679', email=>'test@test.se')E<34> =back =head3 Contact info The 'srid' returned on a create is the same as the id when creating it. Lets do an info on this handle. =over =item Info on an contact handle -o contact -c info -p E<34>%p=(srid=>'testse0811-0002')E<34> =back =head3 Contact check =over =item Check on an contact handle -o contact -c check -p E<34>%p=(srid=>'testse0811-0002')E<34> =back =head3 Contact delete =over =item Delete on an contact handle -o contact -c delete -p E<34>%p=(srid=>'testse0811-0002')E<34> =back =head2 Host object commands =head3 Host create =over =item 1 Create an external name server An external name server is a non .SE name server. External name servers must be registered without any IP-addresses. -o host -c create -p E<34>%p=(name=>'ns1.example.com')E<34> =item 2 A .SE name server can have up to 5 ipv4-addresses and up to 5 ipv6-addresses. -o host -c create -p E<34>%p=(name=>'ns1.test.se', v4=>'123.234.123.12')E<34> =item 3 Multiple ip-addresses, pass them as an array -o host -c create -p E<34>%p=(name=>'ns2.test.se', v4=>['123.234.123.12','129.123.23.23'])E<34> =item 4 A .SE name server with ipv6 address as well -o host -c create -p E<34>%p=(name=>'ns3.test.se', v4=>['123.234.123.12','129.123.23.23'], v6=>['2001:700:1:0:215:f2ff:fe3e:fe65'])E<34> =back =head3 Host info =over =item 1 Info on a sponsored host object -o host -c info -p E<34>%p=(name=>'ns1.test.se')E<34> =item 2 info on a host object sponsored (owned) by another registrar It is possible to query hosts sponsored by other registrars. -o host -c info -p E<34>%p=(name=>'ns2.test2.se')E<34> =back =head3 Host check =over =item Check to see whether a host name is available or registered -o host -c check -p E<34>%p=(name=>'ns1.test.se')E<34> =back =head3 Host delete =over =item Delete a host -o host -c delete -p E<34>%p=(name=>'ns1.test.se')E<34> =back =head3 Host update =over =item 1 First create a host with no ip-addressest. -o host -c create -p E<34>%p=(name=>'ns4.test.se')E<34> =item 2 Do an info to verify -o host -c info -p E<34>%p=(name=>'ns4.test.se')E<34> =item 3 Now, change/update it - 1 new ipv4-addresses are added -o host -c update -p E<34>%p=(name=>'ns4.test.se', ipset=>{add=>{v4=>['123.234.123.100']}})E<34> =item 4 Do an info to verify -o host -c info -p E<34>%p=(name=>'ns4.test.se')E<34> =item 5 Now, change/update it again - 1 new ipv4-address are added - 1 old ipv4-address is removed -o host -c update -p E<34>%p=(name=>'ns4.test.se', ipset=>{add=>{v4=>['123.234.123.101']}, del=>{v4=>['123.234.123.100']}})E<34> =item 4 Do an info to verify -o host -c info -p E<34>%p=(name=>'ns4.test.se')E<34> =item 5 Now, change/update it again - 1 new ipv6-address are added -o host -c update -p E<34>%p=(name=>'ns3.yask.se', ipset=>{add=>{v6=>['2001:698:a:e:208:2ff:fe15:b2e8']}})E<34> =back =head2 Domain object commands =head3 Domain check =over =item 1 Check to see whether a domain name is available or registered -o domain -c check -p E<34>%p=(name=>'test.se')E<34> =back =head3 Domain info =over =item 1 Do an info on an existing domain -o domain -c info -p E<34>%p=(name=>'test.se')E<34> =back =head3 Domain create =over =item Notes =over =item * on the domain create methods in Net::DRI A lot of domain create methods are offered by Net::DRI. The client uses one specific create method, namely the domain_create_only(). =over =item * domain_create_only() This method assumes that the contacts handles and the nameservers listed are ALREADY created in the registry, and this is closest to .SE's datamodel. Hence, the client uses this method. =item * domain_create() This is another method which is a very powerful Net::DRI method. This method will do the same as domain_create_only(), but will also accept and handle full contacts and nameserver objects as parameters, meaning that it will check and create various objects as an integral part of the command. Support for this variant is not added to the client. =back =item * on the duration syntax The duration parameter must specify one year to be accepted in create, due to the period definition in lib/Net/DRI/DRD/SE.pm Duration syntax: 'duration=>{years=>1}' or 'duration=>{months=>12}' =back =item 1 Create a normal domain without nameservers Create a single domain with a a registrant, a contact set with one type each, and and no name servers: -o domain -c create -p E<34>%p=(name=>'test.se', pw=>'', registrant=>'testse0810-0001', coset=>{tech=>'testse0810-0002', admin=>'testse0810-0002'}, duration=>{years=>1})E<34> =item 2 Create a normal domain with nameservers Create a single domain with a a registrant, a contact set with one type each, and and two name servers: -o domain -c create -p E<34>%p=(name=>'test2.se', pw=>'', registrant=>'testse0810-0001', coset=>{tech=>'testse0810-0002', admin=>'testse0810-0002'}, duration=>{years=>1}, nsset=>['ns1.test.se', 'ns2.test.se'])E<34> =item 3 Create an IDN domain Create a single IDN-domain with a duration of 12 months, a registrant, a contact set with one type each, and no name servers. IDN domains are converted to the ACE-form (xn--...) by the client, and the ACE-form is passed as the domain name to the registry. -o domain -c create -p E<34>%p=(name=>'räksmörgås.se', pw=>'', registrant=>'testse0810-0001', coset=>{tech=>'testse0810-0002', admin=>'testse0810-0002'}, duration=>{years=>1})E<34> =item 4 Create a domain with Secure DNS keys Create a single domain with a a registrant, a contact set with one type each, and and two name servers and one Secure DNS Key: -o domain -c create -p E<34>%p=(name=>'test3.se', pw=>'', registrant=>'testse0810-0001', coset=>{tech=>'testse0810-0002', admin=>'testse0810-0002'}, duration=>{years=>1}, nsset=>['ns1.test.se', 'ns2.test.se'], secdns=>[{keyTag=>'12345',alg=>3,digestType=>2,digest=>'49FD46E6C4B45C55D4AC'}])E<34> =back =over =back =head3 Domain delete Delete domain is not suported by .SE. =head3 Domain update The domain name cannot be changed, otherwise all parameters may be changed. =over =item 1 Update (change) some domain attributes - set authInfo to 'abc' - add and del on all the multiple objects, coset and nsset, which may be arrays or scalars - delete all secude DNS keys -o domain -c update -p E<34>%p=(name=>'test.se', pw=>'abc', coset=>{add=>{tech=>['testse0810-0001'], admin=>['testse0810-0001']}, del=>{tech=>['testse0810-0002'], admin=>['testse0810-0002']}}, nsset=>{add=>['ns3.yask.se'], del=>'ns1.test.se'}, secdns=>{del=>[{keyTag=>'0'}]})E<34> =item 2 Update of status flags Update is the only command where the status flags can be set/changed. .SE only handles clientHold. The name is not intuative so to put the clientHold flag on, ie not to publish the domain - use the add command to set that the domain should NOT be published and request the domain to be published again by deleteing the status flag. The flag values to use by the DRI user is the following (from Status.pm): my %s=('delete' => 'clientDeleteProhibited', 'renew' => 'clientRenewProhibited', 'update' => 'clientUpdateProhibited', 'transfer' => 'clientTransferProhibited', 'publish' => 'clientHold'); Example update to set a domain to NOT be published: -o domain -c update -p E<34>%p=(name=>'test.se', status=>{add=>['publish']})E<34> Example update to set a domain to be published: -o domain -c update -p E<34>%p=(name=>'test.se', status=>{del=>['publish']})E<34> =back =head3 DNS Secure .SE suports the DNS secure extensions secDNS. The epp_client_se.pl can get/set/remove the keys for DNSsec. One extensions that .SE has added is that you can delete all keys by just sending a delete with keyTag 0. This will delete all keys. =item 1 Add a DNSsec key Add a DNSsec key to a domain. -o domain -c update -p E<34>%p=(name=>'test.se', secdns=>{add=>[{keyTag=>'12346', alg=>3, digestType=>1, digest=>'49FD46E6C4B45C55D4DD'}]})E<34> =item 2 Delete a DNSsec key Delete a DNSsec key from a domain. -o domain -c update -p E<34>%p=(name=>'yask04.se', secdns=>{del=>[{keyTag=>'12345'}]})E<34> =over =head3 clientRelease .SE has one extensions for clientDelete. is you set this it will remove the domain before its expiration date. =over =item 1 Set the clientDelete flag - Update the domain and set the clientDelete flag to forece the domain to be removed -o domain -c update -p E<34>%p=(name=>'test.se', clientDelete=>1)E<34> =item 2 Unset the clientDelete flag - Update the domain and remove the clientDelete flag to not have the domain be removed -o domain -c update -p E<34>%p=(name=>'test.se', clientDelete=>0)E<34> =back =head3 Domain renew =item 1 Renew with parameters. Duration has to be 12 months or 1 year for .SE. DRI requires curexpiry, which should match the expiry date of the domain being renewed: -o domain -c renew -p E<34>%p=(name=>'test.se', curexpiry=>'2008-12-11', duration=>{months=>12})E<34> =head2 Domain transfer commands Domain transfers are used if the registrant wants to change his registrar. He must then ask the old registrar for the password and the old one has to set that. The the new registrars can do the transfer. =head3 Domain transfer request When the registrant knows the authInfo, he passes it to the new registrar, who can do a transfer containing the authInfo, and the transfer will be performed. - The transfer must be authorized by the token. -o domain -c transfer -p E<34>%p=(name=>'test.se', pw=>'abc')E<34> If the password is correct, the domain should be transferred. =head2 Polling the message queue =head3 Poll messages =over =item 1 message_waiting() This method performs a poll request and returns true if one or more messages are waiting in the queue. -o message -c waiting -p E<34>%p=()E<34> =item 2 message_count() This method performs a poll request and returns the 'msgQ count' value from the response, if any. -o message -c count -p E<34>%p=()E<34> =item 3 message_retrieve() This method performs a poll request, and with get_info() you can grab all the message details. -o message -c retrieve -p E<34>%p=()E<34> =item 4 message_delete() This is the poll ack message, which will remove message (with id=12) from the server message queue. -o message -c delete -p E<34>%p=(id=>12)E<34> =back =head1 COPYRIGHT Copyright (c) 2008 .SE, Ehttp://www.iis.se, Jan Saell Ejan@yask.seE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =head1 AUTHOR Jan Saell, Ejan@yask.seE =cut Net-DRI-0.96/eg/coop_epp.pl0000755000175000017500000001043111136730225015224 0ustar patrickpatrick#!/usr/bin/perl -w # # # A Net::DRI example for .COOP : creation of contacts, hosts, domains, and deleting domain use strict; use Net::DRI; use DateTime::Duration; ## Fill these variables : your registrar id, password, and contact prefix my $CLID=''; my $PASS=''; my $CID_PREFIX=''; ## The registry mandates all contacts ID to start with a specific prefix, tied to your account my $dri=Net::DRI->new({cache_ttl=>10,logging=>'files'}); eval { ############################################################################################################ $dri->add_registry('COOP',{clid=>$CLID}); ## This connects to .COOP server for tests : make sure you have local files key.pem and cert.pem my $rc=$dri->target('COOP')->add_current_profile('profile1','epp',{ssl_key_file=>'./key.pem',ssl_cert_file=>'./cert.pem',ssl_ca_file=>'./cert.pem',client_login=>$CLID,client_password=>$PASS}); die($rc) unless $rc->is_success(); ## Here we catch all errors during setup of transport, such as authentication errors my $t1=time()%100; my $c1=new_contact($dri); ## sponsor 1 $c1->srid($CID_PREFIX.'1s'.$t1); my $c2=new_contact($dri); ## sponsor 2 $c2->srid($CID_PREFIX.'s'.($t1+1)); my $c3=new_contact($dri); $c3->srid($CID_PREFIX.'r'.($t1+2)); $c3->sponsors([$c1->srid(),$c2->srid()]); ## $c3 will be used as registrant, hence it needs 2 sponsors ! $c3->mailing_list(1); my $c4=new_contact($dri); $c4->srid($CID_PREFIX.'c'.($t1+3)); ## will be used as billing/technical/admin $c4->mailing_list(0); $rc=$dri->contact_create($c1); die($rc) unless $rc->is_success(); my $id=$dri->get_info('id'); print "Contact1 created, id=$id\n"; $rc=$dri->contact_create($c2); die($rc) unless $rc->is_success(); $id=$dri->get_info('id'); print "Contact2 created, id=$id\n"; $rc=$dri->contact_create($c3); die($rc) unless $rc->is_success(); $id=$dri->get_info('id'); print "Contact3 created, id=$id\n"; $rc=$dri->contact_create($c4); die($rc) unless $rc->is_success(); $id=$dri->get_info('id'); print "Contact3 created, id=$id\n"; my $nso=$dri->local_object('hosts'); foreach my $ns (qw/ns1.example.com ns2.example.com/) { print "Attempting to create host $ns "; my $e=$dri->host_exist($ns); if ($e==0) { $rc=$dri->host_create($ns); print $rc->is_success()? "OK\n" : "KO\n"; } else { print "EXIST already\n"; } $nso->add($ns); } my $dom='toto-'.time().'.coop'; $rc=$dri->domain_check($dom); print "$dom exists: ".($dri->get_info('exist')? 'YES' : 'NO')."\n"; my $cs=$dri->local_object('contactset'); $cs->set($c3,'registrant'); $cs->set($c4,'billing'); $cs->set($c4,'tech'); $cs->set($c4,'admin'); print "Attempting to create domain $dom\n"; $rc=$dri->domain_create($dom,{pure_create=>1,duration=>DateTime::Duration->new(years =>2),ns=>$nso,contact=>$cs,auth=>{pw=>'whatever'}}); print "$dom created successfully:".($rc->is_success()? 'YES' : 'NO')."\n"; $rc=$dri->domain_check($dom); print "$dom does exists now: ".($dri->get_info('exist')? 'YES' : 'NO')."\n"; $rc=$dri->domain_info($dom); print "$dom domain_info: ".($rc->is_success()? 'YES' : 'NO')."\n"; $rc=$dri->domain_delete($dom,{pure_delete => 1}); print "$dom domain_delete: ".($rc->is_success()? 'YES' : 'NO')."\n"; $rc=$dri->contact_delete($c3); print 'Contact3 deleted successfully: '.($rc->is_success()? 'YES' : 'NO')."\n"; $rc=$dri->contact_delete($c1); print 'Contact1 deleted successfully: '.($rc->is_success()? 'YES' : 'NO')."\n"; $rc=$dri->contact_delete($c2); print 'Contact2 deleted successfully: '.($rc->is_success()? 'YES' : 'NO')."\n"; $rc=$dri->contact_delete($c4); print 'Contact4 deleted successfully: '.($rc->is_success()? 'YES' : 'NO')."\n"; $dri->end(); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if (ref($@)) { $@->print(); } else { print($@); } } else { print "\n\nNo exception happened, everything seems OK !"; } print "\n"; exit 0; ###################################################### sub new_contact { my ($dri)=@_; my $c=$dri->local_object('contact'); $c->name('My Name'); $c->org('My Organisation àé æ'.time()); $c->street(['My Address']); $c->city('My city'); $c->pc(11111); $c->cc('FR'); $c->email('test@example.com'); $c->voice('+33.1111111'); $c->fax('+33.2222222'); $c->auth({pw => 'whatever'}); $c->lang('fr'); $c->loc2int(); ## registry operator needs internationalized & localized forms (not just internationalized alone) return $c; } Net-DRI-0.96/eg/epp_server.pl0000755000175000017500000000223010267306542015575 0ustar patrickpatrick#!/usr/bin/perl -w # # A minimalistic server to send back EPP frame with correct length use IO::Socket; our $PORT=5555; die "File to send must be provided on command line !!!" unless @ARGV; my $server = IO::Socket::INET->new( Proto => 'tcp', LocalPort => $PORT, Listen => SOMAXCONN, Reuse => 1); die "can't setup server" unless $server; print "[Server $0 accepting clients on $PORT]\n"; my $client = $server->accept(); $client->autoflush(1); print "Got a new client\n"; my ($c,$length,$content); while(my $file=shift(@ARGV)) { open my $fh, "< ${file}" or die $!; local $/; # enable localized slurp mode $content=<$fh>; close $fh; print "Sending content of file $file [".length($content)." bytes]\n"; $client->print(pack('N',length($content)+4).$content); next unless @ARGV; print "Waiting for client data\n"; $c=''; $client->read($c,4); $length=unpack('N',$c)-4; print "Got length=${length} bytes\n"; $c=''; $client->read($c,$length); print "Got from client: $c\n"; } print "Closing connection to client\n"; close $client; exit 0; Net-DRI-0.96/eg/iris_dchk.pl0000755000175000017500000000253211241344220015353 0ustar patrickpatrick#!/usr/bin/perl # # # A Net::DRI example for IRIS DCHK operations, currently only .DE use strict; use warnings; use Net::DRI; my ($dri,$rc); eval { $dri=Net::DRI->new(10); $dri->add_registry('DENIC',{}); $rc=$dri->target('DENIC')->add_current_profile('profile1','dchk'); die($rc) unless $rc->is_success(); display($dri,'denic.de'); display($dri,'ecb.de'); display($dri,'netdri-test-doesnotexist.de'); display($dri,'1.5.3.2.7.2.9.6.9.4.e164.arpa'); ## example with ENUM domain names $dri->end(); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if (ref($@)) { $@->print(); } else { print($@); } } else { print "\n\nNo exception happened"; } print "\n"; exit 0; sub display { my ($dri,$dom)=@_; print 'DOMAIN: '.$dom."\n"; my $rc=$dri->domain_info($dom); print 'IS_SUCCESS: '.$rc->is_success().' [CODE: '.$rc->code().' / '.$rc->native_code()."]\n"; unless ($rc->is_success()) { print $rc->message(),"\n"; return; } my $e=$dri->get_info('exist'); print 'EXIST: '.$e."\n"; if ($e eq '1') { foreach my $k (qw/crDate exDate duDate idDate/) { print $k.': '.($dri->get_info($k) || 'n/a')."\n"; } print 'status: '.join(' ',$dri->get_info('status')->list_status())."\n" if defined($dri->get_info('status')); } my $rs=$dri->get_info('result_status'); print 'RESULT STATUS: '; $rs->print_full() if defined($rs); print "\n\n"; } Net-DRI-0.96/MANIFEST0000644000175000017500000003474511352534420013633 0ustar patrickpatrickChanges eg/afnic_email.pl eg/afnic_ws.pl eg/cat_epp.pl eg/coop_epp.pl eg/das.pl eg/epp_client_no.pl eg/epp_client_se.pl eg/epp_server.pl eg/eurid_epp.pl eg/iris_dchk.pl eg/whois.pl eg/ws_rrp.pl eg/xmlfilter.pl INSTALL lib/Net/DRI.pm lib/Net/DRI/BaseClass.pm lib/Net/DRI/Cache.pm lib/Net/DRI/Data/Changes.pm lib/Net/DRI/Data/Contact.pm lib/Net/DRI/Data/Contact/AERO.pm lib/Net/DRI/Data/Contact/AFNIC.pm lib/Net/DRI/Data/Contact/ARNES.pm lib/Net/DRI/Data/Contact/ASIA.pm lib/Net/DRI/Data/Contact/AT.pm lib/Net/DRI/Data/Contact/BE.pm lib/Net/DRI/Data/Contact/BR.pm lib/Net/DRI/Data/Contact/CAT.pm lib/Net/DRI/Data/Contact/CIRA.pm lib/Net/DRI/Data/Contact/COOP.pm lib/Net/DRI/Data/Contact/DENIC.pm lib/Net/DRI/Data/Contact/EURid.pm lib/Net/DRI/Data/Contact/FCCN.pm lib/Net/DRI/Data/Contact/IT.pm lib/Net/DRI/Data/Contact/JOBS.pm lib/Net/DRI/Data/Contact/LU.pm lib/Net/DRI/Data/Contact/NO.pm lib/Net/DRI/Data/Contact/Nominet.pm lib/Net/DRI/Data/Contact/OpenSRS.pm lib/Net/DRI/Data/Contact/PL.pm lib/Net/DRI/Data/Contact/SE.pm lib/Net/DRI/Data/Contact/SIDN.pm lib/Net/DRI/Data/Contact/SWITCH.pm lib/Net/DRI/Data/Contact/US.pm lib/Net/DRI/Data/ContactSet.pm lib/Net/DRI/Data/Hosts.pm lib/Net/DRI/Data/Raw.pm lib/Net/DRI/Data/RegistryObject.pm lib/Net/DRI/Data/StatusList.pm lib/Net/DRI/DRD.pm lib/Net/DRI/DRD/AdamsNames.pm lib/Net/DRI/DRD/AERO.pm lib/Net/DRI/DRD/AFNIC.pm lib/Net/DRI/DRD/AG.pm lib/Net/DRI/DRD/ARNES.pm lib/Net/DRI/DRD/ASIA.pm lib/Net/DRI/DRD/AT.pm lib/Net/DRI/DRD/AU.pm lib/Net/DRI/DRD/BE.pm lib/Net/DRI/DRD/BIZ.pm lib/Net/DRI/DRD/BookMyName.pm lib/Net/DRI/DRD/BR.pm lib/Net/DRI/DRD/BZ.pm lib/Net/DRI/DRD/CAT.pm lib/Net/DRI/DRD/CentralNic.pm lib/Net/DRI/DRD/CIRA.pm lib/Net/DRI/DRD/CoCCA.pm lib/Net/DRI/DRD/COOP.pm lib/Net/DRI/DRD/CZ.pm lib/Net/DRI/DRD/DENIC.pm lib/Net/DRI/DRD/EURid.pm lib/Net/DRI/DRD/Gandi.pm lib/Net/DRI/DRD/GL.pm lib/Net/DRI/DRD/HN.pm lib/Net/DRI/DRD/ICANN.pm lib/Net/DRI/DRD/IENUMAT.pm lib/Net/DRI/DRD/IM.pm lib/Net/DRI/DRD/INFO.pm lib/Net/DRI/DRD/IRegistry.pm lib/Net/DRI/DRD/IT.pm lib/Net/DRI/DRD/LC.pm lib/Net/DRI/DRD/LU.pm lib/Net/DRI/DRD/ME.pm lib/Net/DRI/DRD/MN.pm lib/Net/DRI/DRD/MOBI.pm lib/Net/DRI/DRD/NAME.pm lib/Net/DRI/DRD/NO.pm lib/Net/DRI/DRD/Nominet.pm lib/Net/DRI/DRD/NU.pm lib/Net/DRI/DRD/OpenSRS.pm lib/Net/DRI/DRD/ORG.pm lib/Net/DRI/DRD/OVH.pm lib/Net/DRI/DRD/PL.pm lib/Net/DRI/DRD/PRO.pm lib/Net/DRI/DRD/PT.pm lib/Net/DRI/DRD/SC.pm lib/Net/DRI/DRD/SE.pm lib/Net/DRI/DRD/SIDN.pm lib/Net/DRI/DRD/SWITCH.pm lib/Net/DRI/DRD/TRAVEL.pm lib/Net/DRI/DRD/US.pm lib/Net/DRI/DRD/VC.pm lib/Net/DRI/DRD/VNDS.pm lib/Net/DRI/DRD/WS.pm lib/Net/DRI/Exception.pm lib/Net/DRI/Logging.pm lib/Net/DRI/Logging/Files.pm lib/Net/DRI/Logging/Null.pm lib/Net/DRI/Logging/Stderr.pm lib/Net/DRI/Logging/Syslog.pm lib/Net/DRI/Protocol.pm lib/Net/DRI/Protocol/AdamsNames/WS.pm lib/Net/DRI/Protocol/AdamsNames/WS/Connection.pm lib/Net/DRI/Protocol/AdamsNames/WS/Domain.pm lib/Net/DRI/Protocol/AdamsNames/WS/Message.pm lib/Net/DRI/Protocol/AFNIC/Email.pm lib/Net/DRI/Protocol/AFNIC/Email/Domain.pm lib/Net/DRI/Protocol/AFNIC/Email/Message.pm lib/Net/DRI/Protocol/AFNIC/WS.pm lib/Net/DRI/Protocol/AFNIC/WS/Domain.pm lib/Net/DRI/Protocol/AFNIC/WS/Message.pm lib/Net/DRI/Protocol/BookMyName/WS.pm lib/Net/DRI/Protocol/BookMyName/WS/Account.pm lib/Net/DRI/Protocol/BookMyName/WS/Domain.pm lib/Net/DRI/Protocol/BookMyName/WS/Message.pm lib/Net/DRI/Protocol/DAS.pm lib/Net/DRI/Protocol/DAS/AdamsNames.pm lib/Net/DRI/Protocol/DAS/AdamsNames/Connection.pm lib/Net/DRI/Protocol/DAS/AdamsNames/Domain.pm lib/Net/DRI/Protocol/DAS/AdamsNames/Message.pm lib/Net/DRI/Protocol/DAS/AU.pm lib/Net/DRI/Protocol/DAS/AU/Connection.pm lib/Net/DRI/Protocol/DAS/AU/Domain.pm lib/Net/DRI/Protocol/DAS/AU/Message.pm lib/Net/DRI/Protocol/DAS/Connection.pm lib/Net/DRI/Protocol/DAS/Domain.pm lib/Net/DRI/Protocol/DAS/Message.pm lib/Net/DRI/Protocol/DAS/SIDN.pm lib/Net/DRI/Protocol/DAS/SIDN/Connection.pm lib/Net/DRI/Protocol/DAS/SIDN/Domain.pm lib/Net/DRI/Protocol/DAS/SIDN/Message.pm lib/Net/DRI/Protocol/EPP.pm lib/Net/DRI/Protocol/EPP/Connection.pm lib/Net/DRI/Protocol/EPP/Core/Contact.pm lib/Net/DRI/Protocol/EPP/Core/Domain.pm lib/Net/DRI/Protocol/EPP/Core/Host.pm lib/Net/DRI/Protocol/EPP/Core/RegistryMessage.pm lib/Net/DRI/Protocol/EPP/Core/Session.pm lib/Net/DRI/Protocol/EPP/Core/Status.pm lib/Net/DRI/Protocol/EPP/Extensions/AERO.pm lib/Net/DRI/Protocol/EPP/Extensions/AERO/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/AERO/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/Afilias.pm lib/Net/DRI/Protocol/EPP/Extensions/Afilias/IDNLanguage.pm lib/Net/DRI/Protocol/EPP/Extensions/Afilias/Restore.pm lib/Net/DRI/Protocol/EPP/Extensions/AFNIC.pm lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/Notifications.pm lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/Status.pm lib/Net/DRI/Protocol/EPP/Extensions/ARNES.pm lib/Net/DRI/Protocol/EPP/Extensions/ARNES/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/ARNES/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/ASIA.pm lib/Net/DRI/Protocol/EPP/Extensions/ASIA/CED.pm lib/Net/DRI/Protocol/EPP/Extensions/ASIA/IPR.pm lib/Net/DRI/Protocol/EPP/Extensions/AT.pm lib/Net/DRI/Protocol/EPP/Extensions/AT/ATResult.pm lib/Net/DRI/Protocol/EPP/Extensions/AT/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/AT/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/AT/IOptions.pm lib/Net/DRI/Protocol/EPP/Extensions/AT/Message.pm lib/Net/DRI/Protocol/EPP/Extensions/AT/Result.pm lib/Net/DRI/Protocol/EPP/Extensions/AU.pm lib/Net/DRI/Protocol/EPP/Extensions/AU/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/BR.pm lib/Net/DRI/Protocol/EPP/Extensions/BR/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/BR/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/CAT.pm lib/Net/DRI/Protocol/EPP/Extensions/CAT/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/CAT/DefensiveRegistration.pm lib/Net/DRI/Protocol/EPP/Extensions/CAT/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/CentralNic.pm lib/Net/DRI/Protocol/EPP/Extensions/CentralNic/Release.pm lib/Net/DRI/Protocol/EPP/Extensions/CentralNic/TTL.pm lib/Net/DRI/Protocol/EPP/Extensions/CentralNic/WebForwarding.pm lib/Net/DRI/Protocol/EPP/Extensions/CIRA.pm lib/Net/DRI/Protocol/EPP/Extensions/CIRA/Agreement.pm lib/Net/DRI/Protocol/EPP/Extensions/CIRA/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/CIRA/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/CIRA/Notifications.pm lib/Net/DRI/Protocol/EPP/Extensions/COOP.pm lib/Net/DRI/Protocol/EPP/Extensions/COOP/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/CZ.pm lib/Net/DRI/Protocol/EPP/Extensions/CZ/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/CZ/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/CZ/NSSET.pm lib/Net/DRI/Protocol/EPP/Extensions/DNSBE.pm lib/Net/DRI/Protocol/EPP/Extensions/DNSBE/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/DNSBE/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/DNSBE/Message.pm lib/Net/DRI/Protocol/EPP/Extensions/E164.pm lib/Net/DRI/Protocol/EPP/Extensions/E164Validation.pm lib/Net/DRI/Protocol/EPP/Extensions/E164Validation/RFC5076.pm lib/Net/DRI/Protocol/EPP/Extensions/EURid.pm lib/Net/DRI/Protocol/EPP/Extensions/EURid/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/EURid/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/EURid/Message.pm lib/Net/DRI/Protocol/EPP/Extensions/EURid/Notifications.pm lib/Net/DRI/Protocol/EPP/Extensions/EURid/Registrar.pm lib/Net/DRI/Protocol/EPP/Extensions/EURid/Sunrise.pm lib/Net/DRI/Protocol/EPP/Extensions/FCCN.pm lib/Net/DRI/Protocol/EPP/Extensions/FCCN/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/FCCN/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/GracePeriod.pm lib/Net/DRI/Protocol/EPP/Extensions/HTTP.pm lib/Net/DRI/Protocol/EPP/Extensions/IENUMAT.pm lib/Net/DRI/Protocol/EPP/Extensions/IRegistry.pm lib/Net/DRI/Protocol/EPP/Extensions/IT.pm lib/Net/DRI/Protocol/EPP/Extensions/IT/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/IT/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/IT/Notifications.pm lib/Net/DRI/Protocol/EPP/Extensions/LU.pm lib/Net/DRI/Protocol/EPP/Extensions/LU/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/LU/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/LU/Poll.pm lib/Net/DRI/Protocol/EPP/Extensions/LU/Status.pm lib/Net/DRI/Protocol/EPP/Extensions/MOBI.pm lib/Net/DRI/Protocol/EPP/Extensions/MOBI/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/NAME.pm lib/Net/DRI/Protocol/EPP/Extensions/NAME/EmailFwd.pm lib/Net/DRI/Protocol/EPP/Extensions/NeuLevel/IDNLanguage.pm lib/Net/DRI/Protocol/EPP/Extensions/NeuLevel/UIN.pm lib/Net/DRI/Protocol/EPP/Extensions/NO.pm lib/Net/DRI/Protocol/EPP/Extensions/NO/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/NO/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/NO/Host.pm lib/Net/DRI/Protocol/EPP/Extensions/NO/Message.pm lib/Net/DRI/Protocol/EPP/Extensions/NO/Result.pm lib/Net/DRI/Protocol/EPP/Extensions/Nominet.pm lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Account.pm lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Host.pm lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Notifications.pm lib/Net/DRI/Protocol/EPP/Extensions/NSgroup.pm lib/Net/DRI/Protocol/EPP/Extensions/PL.pm lib/Net/DRI/Protocol/EPP/Extensions/PL/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/PL/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/PL/Message.pm lib/Net/DRI/Protocol/EPP/Extensions/PRO.pm lib/Net/DRI/Protocol/EPP/Extensions/PRO/AV.pm lib/Net/DRI/Protocol/EPP/Extensions/PRO/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/SE.pm lib/Net/DRI/Protocol/EPP/Extensions/SE/Extensions.pm lib/Net/DRI/Protocol/EPP/Extensions/SE/Message.pm lib/Net/DRI/Protocol/EPP/Extensions/SecDNS.pm lib/Net/DRI/Protocol/EPP/Extensions/SIDN.pm lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Domain.pm lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Host.pm lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Message.pm lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Notifications.pm lib/Net/DRI/Protocol/EPP/Extensions/SWITCH.pm lib/Net/DRI/Protocol/EPP/Extensions/US.pm lib/Net/DRI/Protocol/EPP/Extensions/US/Contact.pm lib/Net/DRI/Protocol/EPP/Extensions/VeriSign.pm lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/IDNLanguage.pm lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/JobsContact.pm lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/NameStore.pm lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/PollLowBalance.pm lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/PollRGP.pm lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/Sync.pm lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/WhoisInfo.pm lib/Net/DRI/Protocol/EPP/Message.pm lib/Net/DRI/Protocol/EPP/Util.pm lib/Net/DRI/Protocol/Gandi/WS.pm lib/Net/DRI/Protocol/Gandi/WS/Account.pm lib/Net/DRI/Protocol/Gandi/WS/Connection.pm lib/Net/DRI/Protocol/Gandi/WS/Domain.pm lib/Net/DRI/Protocol/Gandi/WS/Message.pm lib/Net/DRI/Protocol/IRIS.pm lib/Net/DRI/Protocol/IRIS/Core.pm lib/Net/DRI/Protocol/IRIS/DCHK/Domain.pm lib/Net/DRI/Protocol/IRIS/DCHK/Status.pm lib/Net/DRI/Protocol/IRIS/LWZ.pm lib/Net/DRI/Protocol/IRIS/Message.pm lib/Net/DRI/Protocol/IRIS/XCP.pm lib/Net/DRI/Protocol/Message.pm lib/Net/DRI/Protocol/OpenSRS/XCP.pm lib/Net/DRI/Protocol/OpenSRS/XCP/Account.pm lib/Net/DRI/Protocol/OpenSRS/XCP/Connection.pm lib/Net/DRI/Protocol/OpenSRS/XCP/Domain.pm lib/Net/DRI/Protocol/OpenSRS/XCP/Message.pm lib/Net/DRI/Protocol/OpenSRS/XCP/Session.pm lib/Net/DRI/Protocol/OVH/WS.pm lib/Net/DRI/Protocol/OVH/WS/Account.pm lib/Net/DRI/Protocol/OVH/WS/Connection.pm lib/Net/DRI/Protocol/OVH/WS/Domain.pm lib/Net/DRI/Protocol/OVH/WS/Message.pm lib/Net/DRI/Protocol/ResultStatus.pm lib/Net/DRI/Protocol/RRI.pm lib/Net/DRI/Protocol/RRI/Connection.pm lib/Net/DRI/Protocol/RRI/Contact.pm lib/Net/DRI/Protocol/RRI/Domain.pm lib/Net/DRI/Protocol/RRI/Message.pm lib/Net/DRI/Protocol/RRI/RegistryMessage.pm lib/Net/DRI/Protocol/RRI/Session.pm lib/Net/DRI/Protocol/RRP.pm lib/Net/DRI/Protocol/RRP/Connection.pm lib/Net/DRI/Protocol/RRP/Core/Domain.pm lib/Net/DRI/Protocol/RRP/Core/Host.pm lib/Net/DRI/Protocol/RRP/Core/Session.pm lib/Net/DRI/Protocol/RRP/Core/Status.pm lib/Net/DRI/Protocol/RRP/Message.pm lib/Net/DRI/Protocol/Whois.pm lib/Net/DRI/Protocol/Whois/Connection.pm lib/Net/DRI/Protocol/Whois/Domain/AERO.pm lib/Net/DRI/Protocol/Whois/Domain/AT.pm lib/Net/DRI/Protocol/Whois/Domain/BIZ.pm lib/Net/DRI/Protocol/Whois/Domain/CAT.pm lib/Net/DRI/Protocol/Whois/Domain/COM.pm lib/Net/DRI/Protocol/Whois/Domain/common.pm lib/Net/DRI/Protocol/Whois/Domain/EU.pm lib/Net/DRI/Protocol/Whois/Domain/INFO.pm lib/Net/DRI/Protocol/Whois/Domain/LU.pm lib/Net/DRI/Protocol/Whois/Domain/MOBI.pm lib/Net/DRI/Protocol/Whois/Domain/NAME.pm lib/Net/DRI/Protocol/Whois/Domain/ORG.pm lib/Net/DRI/Protocol/Whois/Domain/PT.pm lib/Net/DRI/Protocol/Whois/Domain/SE.pm lib/Net/DRI/Protocol/Whois/Domain/TRAVEL.pm lib/Net/DRI/Protocol/Whois/Domain/US.pm lib/Net/DRI/Protocol/Whois/Domain/WS.pm lib/Net/DRI/Protocol/Whois/Message.pm lib/Net/DRI/Registry.pm lib/Net/DRI/Shell.pm lib/Net/DRI/Transport.pm lib/Net/DRI/Transport/Defer.pm lib/Net/DRI/Transport/Dummy.pm lib/Net/DRI/Transport/HTTP.pm lib/Net/DRI/Transport/HTTP/SOAPLite.pm lib/Net/DRI/Transport/HTTP/SOAPWSDL.pm lib/Net/DRI/Transport/HTTP/XMLRPCLite.pm lib/Net/DRI/Transport/SMTP.pm lib/Net/DRI/Transport/SOAP.pm lib/Net/DRI/Transport/Socket.pm lib/Net/DRI/Util.pm LICENSE Makefile.PL MANIFEST This list of files README SUPPORT t/001load_mandatory.t t/001load_optional.t t/002pod.t t/003critic.t t/101exception.t t/102util.t t/103cache.t t/150data_hosts.t t/151data_changes.t t/152data_contact.t t/153data_contactset.t t/154data_registryobject.t t/155data_statuslist.t t/200protocol.t t/201protocol_message.t t/202protocol_resultstatus.t t/211rrp_message.t t/212rrp_connection.t t/221afnicws_message.t t/241epp_message.t t/242epp_connection.t t/501drd_icann.t t/502drd_name.t t/600vnds_rrp.t t/601vnds_epp.t t/602vnds_epp_graceperiod.t t/603vnds_epp_e164.t t/604vnds_epp_secdns.t t/605vnds_epp_nsgroup.t t/606eurid_epp.t t/607pl_epp.t t/608afnic_email.t t/609us_epp.t t/610vnds_epp_sync.t t/611vnds_epp_idnlang.t t/612vnds_epp_whoisinfo.t t/613cat_epp.t t/614aero_epp.t t/615mobi_epp.t t/616vnds_epp_namestore.t t/617vnds_epp_polllowbalance.t t/618vnds_epp_pollrgp.t t/619coop_epp.t t/620lu_epp.t t/621centralnic_epp.t t/622vnds_epp_e164validation.t t/626nominet_epp.t t/627at_epp.t t/628de_rri.t t/629asia_epp.t t/630afilias_epp_restore.t t/631cz_epp.t t/632travel_epp.t t/633norid_epp.t t/634afnic_epp.t t/635br_epp.t t/636vnds_epp_jobs.t t/637pro_epp.t t/638switch_epp.t t/639opensrs_xcp.t t/640pt_epp.t t/641sidn_epp.t t/642cira_epp.t t/701ovh_ws_live.t t/702bookmyname_ws_live.t t/703gandi_ws_live.t t/704opensrs_xcp_live.t t/705adamsnames_ws_live.t TODO META.yml Module meta-data (added by MakeMaker) Net-DRI-0.96/LICENSE0000644000175000017500000004313110232741533013475 0ustar patrickpatrick GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. Net-DRI-0.96/t/0002755000175000017500000000000011352534417012740 5ustar patrickpatrickNet-DRI-0.96/t/600vnds_rrp.t0000755000175000017500000001307011241325175015206 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 48; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : "200 Command completed successfully\r\n.\r\n"); } my $dri=Net::DRI::TrapExceptions->new(-1); ## we do not want caching for now $dri->add_registry('VNDS',{tz=>'America/New_York'}); $dri->target('VNDS')->add_current_profile('p1','test=RRP',{f_send=>\&mysend,f_recv=>\&myrecv}); $R2="200 Command completed successfully\r\nregistration expiration date:2009-09-22 10:27:00.0\r\nstatus:ACTIVE\r\n.\r\n"; my $rc=$dri->domain_create('example2.com',{pure_create=>1,duration => DateTime::Duration->new(years => 10)}); is($R1,"add\r\nEntityName:Domain\r\nDomainName:EXAMPLE2.COM\r\n-Period:10\r\n.\r\n",'domain_create build'); is($rc->is_success(),1,'domain_create rc is_success'); is($dri->get_info('action'),'create','domain_create get_info(action)'); is($dri->get_info('exist'),1,'domain_create get_info(exist)'); is($rc->code(),1000,'domain_create rc code'); is($rc->native_code(),200,'domain_create rc native_code'); is($rc->message(),'Command completed successfully','domain_create rc message'); my $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_create get_info(exDate)'); is($d.'','2009-09-22T10:27:00','domain_create get_info(exDate) value'); my $s=$dri->get_info('status'); is($s->is_active(),1,'domain_create get_info(status) is_active'); is($s->is_published(),1,'domain_create get_info(status) is_published'); is($s->can_update(),1,'domain_create get_info(status) can_update'); $R2="211 Domain name not available\r\n.\r\n"; $rc=$dri->domain_check('example2.com'); is($R1,"check\r\nEntityName:Domain\r\nDomainName:EXAMPLE2.COM\r\n.\r\n",'domain_check send'); is($rc->is_success(),1,'domain_check rc is_success'); is($dri->get_info('action'),'check','domain_check get_info(action)'); is($dri->get_info('exist'),1,'domain_check get_info(exist)'); is($rc->code(),2302,'domain_check rc code'); is($rc->native_code(),211,'domain_check rc native_code'); is($rc->message(),'Domain name not available','domain_check rc message'); is($dri->domain_exist('example2.com'),1,'domain_exist'); $R2="213 Name server not available\r\nipAddress:192.10.10.10\r\n.\r\n"; $rc=$dri->host_check('ns1.example2.com'); is($R1,"check\r\nEntityName:NameServer\r\nNameServer:NS1.EXAMPLE2.COM\r\n.\r\n",'host_check send'); is($dri->host_exist('ns1.example2.com'),1,'host_exist'); is($dri->get_info('action'),'check','host_check get_info(action)'); is($dri->get_info('exist'),1,'host_check get_info(exist)'); my $dh=$dri->get_info('self'); my @c=$dh->get_names(1); is_deeply(\@c,['ns1.example2.com'],'host_check get_info(self) get_names'); $R2="532 Domain names linked with name server\r\n.\r\n"; $rc=$dri->host_delete('ns1.registrarA.com'); is($R1,"del\r\nEntityName:NameServer\r\nNameServer:NS1.REGISTRARA.COM\r\n.\r\n",'host_delete send'); is($rc->is_success(),0,'host_delete rc is_success'); is($rc->code(),2305,'host_delete rc code'); $R2=undef; $rc=$dri->domain_update_ns_add('example2.com',$dri->local_object('hosts')->set('ns3.registrarA.com')); is($R1,"mod\r\nEntityName:Domain\r\nDomainName:EXAMPLE2.COM\r\nNameServer:ns3.registrara.com\r\n.\r\n",'domain_update_ns_add send'); $rc=$dri->domain_update_ns_del('example2.com',$dri->local_object('hosts')->set('ns1.registrarA.com')); is($R1,"mod\r\nEntityName:Domain\r\nDomainName:EXAMPLE2.COM\r\nNameServer:ns1.registrara.com=\r\n.\r\n",'domain_update_ns_del send'); $rc=$dri->domain_update_ns('example2.com',$dri->local_object('hosts')->set('ns3.registrarA.com'),$dri->local_object('hosts')->set('ns1.registrarA.com')); is($R1,"mod\r\nEntityName:Domain\r\nDomainName:EXAMPLE2.COM\r\nNameServer:ns3.registrara.com\r\nNameServer:ns1.registrara.com=\r\n.\r\n",'domain_update_ns send'); $R2="200 Command completed successfully\r\nnameserver:ns2.registrarA.com\r\nnameserver:ns3.registrarA.com\r\nregistration expiration date:2010-09-22 10:27:00.0\r\nregistrar:registrarA\r\nregistrar transfer date:1999-09-22 10:27:00.0\r\nstatus:ACTIVE\r\ncreated date:1998-09-22 10:27:00.0\r\ncreated by:registrarA\r\nupdated date:2002-09-22 10:27:00.0\r\nupdated by:registrarA\r\n.\r\n"; $rc=$dri->domain_info('example2.com'); is($R1,"status\r\nEntityName:Domain\r\nDomainName:EXAMPLE2.COM\r\n.\r\n",'domain_info send'); is($rc->is_success(),1,'domain_info rc is_success'); is($dri->result_is_success(),1,'result_is_success'); is($dri->result_code(),1000,'result_code'); is($dri->result_native_code(),200,'result_native_code'); is($dri->get_info('action'),'info','domain_info get_info(action)'); is($dri->get_info('exist'),1,'domain_info get_info(exist)'); $dh=$dri->get_info('ns'); @c=$dh->get_names(); is_deeply(\@c,['ns2.registrara.com','ns3.registrara.com'],'domain_info get_info(host) get_names'); is($dri->get_info('exDate').'','2010-09-22T10:27:00','domain_info get_info(exDate)'); is($dri->get_info('clID'),'registrarA','domain_info get_info(clID)'); is($dri->get_info('trDate').'','1999-09-22T10:27:00','domain_info get_info(trDate)'); is($dri->get_info('trDate')->time_zone->name,'America/New_York','domain_info get_info(trDate)->time_zone->name'); is($dri->get_info('crDate').'','1998-09-22T10:27:00','domain_info get_info(crDate)'); is($dri->get_info('crID'),'registrarA','domain_info get_info(crID)'); is($dri->get_info('upDate').'','2002-09-22T10:27:00','domain_info get_info(upDate)'); is($dri->get_info('upID'),'registrarA','domain_info get_info(upID)'); $s=$dri->get_info('status'); is($s->is_active(),1,'domain_info get_info(status) is_active'); exit 0; Net-DRI-0.96/t/152data_contact.t0000755000175000017500000000245410575331503016004 0ustar patrickpatrick#!/usr/bin/perl -w use strict; use Net::DRI::Data::Contact; use Test::More tests => 13; can_ok('Net::DRI::Data::Contact',qw/new id validate name org street city sp pc cc email voice fax loid roid srid auth disclose/); my $s=Net::DRI::Data::Contact->new(); isa_ok($s,'Net::DRI::Data::Contact'); $s->name('Test'); is(scalar($s->name()),'Test','Scalar access (simple set)'); my @d=$s->name(); is_deeply(\@d,['Test'],'List access (simple set)'); $s->name('Test1','Test2'); is(scalar($s->name()),'Test1','Scalar access (double set)'); @d=$s->name(); is_deeply(\@d,['Test1','Test2'],'List access (double set)'); $s->street(['A1','A2']); is_deeply(scalar($s->street()),['A1','A2'],'street() Scalar access (simple set)'); @d=$s->street(); is_deeply(\@d,[['A1','A2']],'street() List access (simple set)'); $s->street(['A1','A2'],['B1','B2']); is_deeply(scalar($s->street()),['A1','A2'],'street() Scalar access (double set)'); @d=$s->street(); is_deeply(\@d,[['A1','A2'],['B1','B2']],'street() List access (double set)'); $s=Net::DRI::Data::Contact->new(); $s->org('Something é'); $s->loc2int(); is_deeply([$s->org()],['Something é','Something ?'],'loc2int()'); $s->int2loc(); is_deeply([$s->org()],['Something ?','Something ?'],'int2loc()'); TODO: { local $TODO="tests on validate()"; ok(0); } exit 0; Net-DRI-0.96/t/614aero_epp.t0000755000175000017500000001546211241325410015147 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 5; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('AERO'); $dri->target('AERO')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my ($rc,$s,$d,$dh,@c,$co); #################################################################################################### ## Contacts $R2=$E1.''.r().'sh8013SH8013-REPJohn DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+1.7035555555+1.7035555556jdoe@example.comR-123R-1231999-04-03T22:00:00.0ZR-1231999-12-03T09:00:00.0Z2000-04-08T09:00:00.0Z2fooBARAirportsitamanualADA ADB BXN DLM ESB ISE IST NAV TZXcredentials typecredentials valuecode valueunique identifier2006-01-01T18:54:36.0ZABC-1234554322-XYZ'.$E2; $co=$dri->local_object('contact')->srid('sh8013')->auth({pw=>'2fooBAR'}); $rc=$dri->contact_info($co); my $ens=$dri->get_info('self')->ens(); is(ref($ens),'HASH','contact_info parse 1'); is(''.$ens->{last_checked_date},'2006-01-01T18:54:36','contact_info parse 2'); delete($ens->{last_checked_date}); is_deeply($ens,{registrant_group=>'Airport',ens_o=>'sita',request_type=>'manual',registration_type=>'ADA ADB BXN DLM ESB ISE IST NAV TZX',credentials_type=>'credentials type',credentials_value=>'credentials value',code_value=>'code value',unique_identifier=>'unique identifier'},'contact_info parse 3'); #################################################################################################### ## Domains $R2=''; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $cs->set($c2,'billing'); $rc=$dri->domain_create('whatever.aero',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns1.example.net']),contact=>$cs,auth=>{pw=>'2fooBAR'},ens=>{auth_id=>'ENS-C1',auth_key=>'my secret'}}); is_string($R1,$E1.'whatever.aero2ns1.example.comns1.example.netjd1234sh8013sh8013sh80132fooBARENS-C1my secretABC-12345'.$E2,'domain_create build'); $R2=$E1.''.r().'whatever.aeroBARCA-REPjd1234sh8013sh8013sh8013ns1.example.comns1.example.netns1.barca.catns2.barca.catClientXClientY2006-04-03T22:00:00.0ZClientX2006-12-03T09:00:00.0Z2007-04-03T22:00:00.0Z2006-04-08T09:00:00.0Z2fooBARENS-C1ABC-1234554322-XYZ'.$E2; $rc=$dri->domain_info('whatever.aero',{auth=>{pw=>'2fooBAR'}}); is_deeply($dri->get_info('ens'),{auth_id=>'ENS-C1'},'domain_info parse'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/636vnds_epp_jobs.t0000755000175000017500000003557711241325755016241 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Data::Dumper; use Test::More tests => 29; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport, $count, $msg) = @_; $R1 = $msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2 ? $R2 : $E1 . '' . r() . $TRID . '' . $E2); } my $dri; eval { $dri = Net::DRI->new(10); }; print $@->as_string() if $@; $dri->{trid_factory} = sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); eval { $dri->target('VNDS')->add_current_profile('p1', 'test=Net::DRI::Protocol::EPP::Extensions::VeriSign', { f_send=> \&mysend, f_recv=> \&myrecv }, {default_product=>'dotJOBS'}); }; print $@->as_string() if $@; my $rc; my $s; my $d; my ($dh,@c); ############################################################################ ## Create a contact $R2 = $E1 . '' . r(1001,'Command completed successfully; ' . 'action pending') . $TRID . '' . $E2; my $c = $dri->local_object('contact'); $c->srid('8013'); $c->name('John Doe'); $c->org('Example Inc.'); $c->street(['123 Example Dr.', 'Suite 100']); $c->city('Dulles'); $c->sp('VA'); $c->pc('20166-6503'); $c->cc('US'); $c->email('john@doe.com'); $c->voice('+1.703555555x1234'); $c->fax('+1.703555555x1235'); $c->auth({pw => '2fooBAR'}); $c->disclose({voice => 0, email => 0}); $c->jobinfo({ title => 'SE', website => 'http://localhost:8989/index.txt', industry => 'IT', admin => 1, member => 1 }); eval { $rc = $dri->contact_create($c); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'contact create'); is($R1, '8013John DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+1.703555555+1.703555555john@doe.com2fooBARSEhttp://localhost:8989/index.txtITYesYesdotJOBSABC-12345', 'contact create xml'); $c->srid('8014'); eval { $rc = $dri->contact_create($c, {subproductid => 'dotAA'}); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'contact create w/subproductid'); is($R1, '8014John DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+1.703555555+1.703555555john@doe.com2fooBARSEhttp://localhost:8989/index.txtITYesYesdotAAABC-12345', 'contact create xml w/subproductid'); ## Update a contact $R2 = $E1 . '' . r(1001,'Command completed successfully; ' . 'action pending') . $TRID . '' . $E2; $c = $dri->local_object('contact'); $c->srid('sh8013'); $c->jobinfo({ title => 'SE', website => 'http://localhost:8989/index.txt', industry => 'IT', admin => 1, member => 1 }); my $todo = $dri->local_object('changes'); $todo->set('info', $c); eval { $rc = $dri->contact_update($c, $todo); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'contact update'); is($R1, 'sh8013SEhttp://localhost:8989/index.txtITYesYesdotJOBSABC-12345', 'contact update xml'); ## Query a contact $R2 = $E1 . '' . r(1001,'Command completed successfully') . 'sh8023SH8023-VRSNJohn DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503USi15d John Doei15d Example Inc.i15d 123 Example Dr.i15d Suite 100DullesVA20166-6503US+1.7035555555+1.7035555556jdoe@example.comClientYClientX2007-06-19T00:38:11.0304Z2fooBARInfo-titlewhois.example.comITYesYes' . $TRID . '' . $E2; eval { $rc = $dri->contact_info($dri->local_object('contact')->srid('sh8023')); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'contact query'); is($R1, 'sh8023dotJOBSABC-12345', 'contact query xml'); $c = $dri->get_info('self', 'contact', 'sh8023'); isa_ok($c, 'Net::DRI::Data::Contact::JOBS'); my $jobinfo = $c->jobinfo(); isa_ok($jobinfo, 'HASH'); is($jobinfo->{title}, 'Info-title', 'contact query job title'); is($jobinfo->{website}, 'whois.example.com', 'contact query job website'); is($jobinfo->{industry}, 'IT', 'contact query job industry'); is($jobinfo->{admin}, 1, 'contact query job admin'); is($jobinfo->{member}, 1, 'contact query job member'); ## Query a contact with corrected data $R2 = $E1 . '' . r(1001,'Command completed successfully') . 'sh40534053_CONTACT-JOBSFourty Fifty-ThreeSyGroup GmbHGueterstrasse 86BaselBasel-Stadt4053CH+41.613338033+41.613831467fourty.fifty-three@sygroup.chSYREGSYREG2008-01-01T01:01:01.0000ZSYREG2008-01-01T01:01:01.0000Zomnomnomhttp://www.sygroup.ch/5No' . $TRID . '' . $E2; eval { $rc = $dri->contact_info($dri->local_object('contact')->srid('sh4053')); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'contact query'); is($R1, 'sh4053dotJOBSABC-12345', 'contact query xml'); $c = $dri->get_info('self', 'contact', 'sh4053'); isa_ok($c, 'Net::DRI::Data::Contact::JOBS'); $jobinfo = $c->jobinfo(); isa_ok($jobinfo, 'HASH'); is($jobinfo->{title}, undef, 'contact query job title'); is($jobinfo->{website}, 'http://www.sygroup.ch/', 'contact query job website'); is($jobinfo->{industry}, '5', 'contact query job industry'); is($jobinfo->{admin}, 0, 'contact query job admin'); is($jobinfo->{member}, undef, 'contact query job member'); ############################################################################ exit(0); sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/619coop_epp.t0000755000175000017500000001700511241325474015173 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 28; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('COOP'); $dri->target('COOP')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); ## Domain commands $R2=$E1.''.r().'th1domain1test.coop2004-12-06T11:32:39.0Z2006-12-06T11:32:39.0Zth1contact1Testverified'.$TRID.''.$E2; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234')->org('Whatever'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $rc=$dri->domain_create('th1domain1test.coop',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns1.example.net']),contact=>$cs,auth=>{pw=>'2fooBAR'}}); is($dri->get_info('action'),'create','domain_create get_info(action)'); is($dri->get_info('exist'),1,'domain_create get_info(exist)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_create get_info(crDate)'); is(''.$d,'2004-12-06T11:32:39','domain_create get_info(crDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_create get_info(exDate)'); is(''.$d,'2006-12-06T11:32:39','domain_create get_info(exDate) value'); is($dri->get_info('registrant_id'),'th1contact1Test','domain_create get_info(registrant_id) value'); is($dri->get_info('registrant_state'),'verified','domain_create get_info(registrant_state) value'); is($dri->get_info('state','contact','th1contact1Test'),'verified','domain_create get_info(state,contact,X) value'); ## Contact commands $R2=$E1.''.r().'th1domainTest62273C-COOPokKermit The FrogThe Muppet ShowChicagoUSk.frog@example.tldTestHarness1TestHarness12004-10-29T12:29:02.6ZMatch SticksVerifiedth1Sponsor1th1Sponsor2'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('th1domainTest'); $rc=$dri->contact_info($co); is($rc->is_success(),1,'contact_info is_success'); is($dri->get_info('action'),'info','contact_info get_info(action)'); is($dri->get_info('exist'),1,'contact_info get_info(exist)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::Contact','contact_info get_info(self)'); is($co->state(),'verified','contact_info get_info(self) state'); is_deeply($co->sponsors(),['th1Sponsor1','th1Sponsor2'],'contact_info get_info(self) sponsors'); $R2=$E1.''.r().'th1domainTest1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('th1domainTest'); $co->name('Kermit The Frog'); $co->org('The Muppet Show'); $co->city('Chicago'); $co->cc('US'); $co->email('k.frog@example.tld'); $co->auth({pw=>'Match Sticks'}); $co->sponsors(['th1Sponsor1','th1Sponsor2']); $rc=$dri->contact_create($co); is_string($R1,$E1.'th1domainTestKermit The FrogThe Muppet ShowChicagoUSk.frog@example.tldMatch Sticksth1Sponsor1th1Sponsor2ABC-12345'.$E2,'contact_create build'); is($rc->is_success(),1,'contact_create is_success'); is($dri->get_info('action'),'create','contact_create get_info(action)'); is($dri->get_info('exist'),1,'contact_create get_info(exist)'); #################################################################################################### ## Registry Messages $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2004-12-21T13:46:06.8ZRegistrant verification state changedth1Test2verified00000000000000032212'; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),11082,'message get_info last_id 1'); is($dri->get_info('last_id','message','session'),11082,'message get_info last_id 2'); is($dri->get_info('id','message',11082),11082,'message get_info id'); is(''.$dri->get_info('qdate','message',11082),'2004-12-21T13:46:06','message get_info qdate'); is($dri->get_info('content','message',11082),'Registrant verification state changed','message get_info msg'); is($dri->get_info('lang','message',11082),'en','message get_info lang'); is($dri->get_info('object_type','message',11082),'contact','message get_info object_type'); is($dri->get_info('object_id','message',11082),'th1Test2','message get_info id'); is($dri->get_info('action','message',11082),'verification_review','message get_info action'); ## with this, we know what action has triggered this delayed message exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/703gandi_ws_live.t0000755000175000017500000000273411137716740016202 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Test::More; unless ($ENV{TEST_GANDI_WS_LIVE_CLIENTID} && $ENV{TEST_GANDI_WS_LIVE_CLIENTPASS}) { plan skip_all => 'Set $ENV{TEST_GANDI_WS_LIVE_CLIENTID} and $ENV{TEST_GANDI_WS_LIVE_CLIENTPASS} if you want (normally harmless) *live* tests for Gandi'; } else { plan tests => 4; } my $dri=Net::DRI->new(10); $dri->add_registry('Gandi'); $dri->target('Gandi')->add_current_profile('p1','ws',{client_login=>$ENV{TEST_GANDI_WS_LIVE_CLIENTID},client_password=>$ENV{TEST_GANDI_WS_LIVE_CLIENTPASS}}); eval { my $rc=$dri->account_list_domains(); diag('Got session ID '.$dri->transport()->session_data()->{id}); is($rc->is_success(),1,'account_list_domains() is_success') or diag(sprintf('Code=%s Native_Code=%d Message=%s',$rc->code(),$rc->native_code(),$rc->message())); my $rd=$dri->get_info('list','account','domains'); is(ref($rd),'ARRAY','get_info(list,account,domains)'); diag('Successfully retrieved list of '.scalar(@$rd).' domain names: '.join(' ',@$rd)); my $rd2=$dri->get_info('list'); is_deeply($rd2,$rd,'get_info(list,account,domains) and get_info(list) give the same results'); $rc=$dri->domain_info($rd->[0]); is($rc->is_success(),1,'domain_info() is_success') or diag(sprintf('Code=%s Native_Code=%d Message=%s',$rc->code(),$rc->native_code(),$rc->message())); my @i=$dri->get_info_keys(); diag('Successfully got information about: '.join(' ',@i)); }; diag('Caught unexpected exception: '.(ref($@)? $@->as_string() : $@)) if $@; exit 0; Net-DRI-0.96/t/001load_optional.t0000755000175000017500000000525711350050115016166 0ustar patrickpatrick#!/usr/bin/perl -w # # Here we test the presence of optional modules, # needed for some registries in Net::DRI but not all of them, # and we warn the user if they are not present use Test::More tests => 11; SKIP: { eval { require Net::SMTP; }; skip 'Module Net::SMTP is not installed, you need it if you want to use Net::DRI for: AFNIC (emails)',1 if $@; require_ok('Net::DRI::Transport::SMTP'); } SKIP: { eval { require MIME::Entity; }; skip 'Module MIME::Entity is not installed, you need it if you want to use Net::DRI for: AFNIC (emails)',2 if $@; require_ok('Net::DRI::Protocol::AFNIC::Email::Message'); require_ok('Net::DRI::Protocol::AFNIC::Email'); ## depends on Message } SKIP: { eval { require XMLRPC::Lite; }; skip 'Module XMLRPC::Lite is not installed, you need it if you want to use Net::DRI for: Gandi (WebServices)',2 if $@; require_ok('Net::DRI::Transport::HTTP::XMLRPCLite'); require_ok('Net::DRI::Protocol::Gandi::WS::Connection'); ## depends on XMLRPC::Data } SKIP: { eval { require SOAP::Lite; }; skip 'Module SOAP::Lite is not installed, you need it if you want to use Net::DRI for: AFNIC (WebServices), BookMyName (WebServices)',1 if $@; require_ok('Net::DRI::Transport::HTTP::SOAPLite'); } SKIP: { eval { require SOAP::WSDL; }; ## also needs SOAP::Lite skip('Module SOAP::WSDL is not installed, you need it if you want to use Net::DRI for: OVH (WebServices)',1) if $@; require_ok('Net::DRI::Transport::HTTP::SOAPWSDL'); } SKIP: { eval { require LWP::UserAgent; }; skip('Module LWP::UserAgent is not installed, you need it if you want to use Net::DRI for: OpenSRS (XCP), .PL (EPP over HTTPS)',1) if $@; require_ok('Net::DRI::Transport::HTTP'); } SKIP: { eval { require HTTP::Request; }; skip('Module HTTP::Request is not installed, you need it if you want to use Net::DRI for: .PL (EPP over HTTPS) .IT (EPP over HTTPS)',1) if $@; require_ok('Net::DRI::Protocol::EPP::Extensions::HTTP'); } SKIP: { eval { require Digest::MD5; }; skip('Module Digest::MD5 is not installed, you need it if you want to use Net::DRI for: OpenSRS (XCP)',1) if $@; eval { require HTTP::Request; }; skip('Module HTTP::Request is not installed, you need it if you want to use Net::DRI for: OpenSRS (XCP)',1) if $@; require_ok('Net::DRI::Protocol::OpenSRS::XCP::Connection'); } SKIP: { eval { require IO::Uncompress::RawInflate; }; skip('Module IO::Uncompress::RawInflate is not installed, you need it if you want to use Net::DRI for: .DE (IRIS DCHK over LWZ)',1) if $@; eval { require Net::DNS; }; skip('Module Net::DNS is not installed, you need it if you want to use Net::DRI for: .DE (IRIS DCHK over LWZ)',1) if $@; require_ok('Net::DRI::Protocol::IRIS::LWZ'); } exit 0; Net-DRI-0.96/t/610vnds_epp_sync.t0000755000175000017500000000351611241325407016226 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 1; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['Net::DRI::Protocol::EPP::Extensions::VeriSign::Sync']}); ######################################################################################################### ## Example taken from draft-hollenbeck-epp-sync-01, updated (removed empty my $toc=$dri->local_object('changes'); $toc->set('sync','05-31'); my $rc=$dri->domain_update('example2.com',$toc); is($R1,$E1.'example2.com--05-31ABC-12345'.$E2,'domain_update build'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/151data_changes.t0000755000175000017500000000526710231215766015766 0ustar patrickpatrick#!/usr/bin/perl -w use strict; use Net::DRI::Data::Changes; use Test::More tests => 40; my $c=Net::DRI::Data::Changes->new(); isa_ok($c,'Net::DRI::Data::Changes'); is_deeply([$c->types()],[],'empty types'); is_deeply([$c->all_defined()],[],'empty all_defined'); $c->add('type1','A'); $c->del('type2','B'); $c->set('type3','C'); is_deeply([$c->types()],['type1','type2','type3'],'3 types'); is_deeply([$c->types('type1')],['add'],'add for one type'); is_deeply([$c->types('type2')],['del'],'del for one type'); is_deeply([$c->types('type3')],['set'],'set for one type'); is_deeply([$c->all_defined('type1')],['A'],'retrieve items 1'); is_deeply([$c->all_defined('type2')],['B'],'retrieve items 2'); is_deeply([$c->all_defined('type3')],['C'],'retrieve items 3'); $c->del('type1','D'); is_deeply([$c->types()],['type1','type2','type3'],'3 types with 4 items'); is_deeply([$c->types('type1')],['add','del'],'2 ops in one type'); is_deeply([$c->all_defined('type1')],['A','D'],'2 items in one type'); is($c->add('type1'),'A','get item/op'); $c=Net::DRI::Data::Changes->new('typeX','add','X'); isa_ok($c,'Net::DRI::Data::Changes'); is_deeply([$c->types()],['typeX'],'new add types()'); is_deeply([$c->types('typeX')],['add'],'new add types(typeX)'); is_deeply([$c->add('typeX')],['X'],'new add add(typeX)'); is($c->del('typeX'),undef,'new add del(typeX)'); is($c->set('typeX'),undef,'new add set(typeX)'); $c=Net::DRI::Data::Changes->new('typeY','del','Y'); isa_ok($c,'Net::DRI::Data::Changes'); is_deeply([$c->types()],['typeY'],'new del types()'); is_deeply([$c->types('typeY')],['del'],'new del types(typeY)'); is_deeply([$c->del('typeY')],['Y'],'new del del(typeY)'); $c=Net::DRI::Data::Changes->new('typeX','add','X'); isa_ok($c,'Net::DRI::Data::Changes'); is_deeply([$c->types()],['typeX'],'new add types()'); is_deeply([$c->types('typeX')],['add'],'new add types(typeX)'); is_deeply([$c->add('typeX')],['X'],'new add add(typeX)'); $c=Net::DRI::Data::Changes->new_add('typeM','M'); isa_ok($c,'Net::DRI::Data::Changes'); is_deeply([$c->types()],['typeM'],'new_add types()'); is_deeply([$c->types('typeM')],['add'],'new_add type(typeM)'); is_deeply([$c->add('typeM')],['M'],'new_add add(typeM)'); $c=Net::DRI::Data::Changes->new_del('typeN','N'); isa_ok($c,'Net::DRI::Data::Changes'); is_deeply([$c->types()],['typeN'],'new_del types()'); is_deeply([$c->types('typeN')],['del'],'new_del type(typeN)'); is_deeply([$c->del('typeN')],['N'],'new_del del(typeN)'); $c=Net::DRI::Data::Changes->new_set('typeO','O'); isa_ok($c,'Net::DRI::Data::Changes'); is_deeply([$c->types()],['typeO'],'new_set types()'); is_deeply([$c->types('typeO')],['set'],'new_set type(typeO)'); is_deeply([$c->set('typeO')],['O'],'new_set set(typeO)'); 1; Net-DRI-0.96/t/634afnic_epp.t0000755000175000017500000007257711241335001015312 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 101; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our ($R1,$R2); sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1;} sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('AFNIC'); $dri->target('AFNIC')->add_current_profile('p1','test=Net::DRI::Protocol::EPP::Extensions::AFNIC',{f_send=>\&mysend,f_recv=>\&myrecv}); my ($rc,$cs,$s,$toc); #################################################################################################### ## §2.2.4 my $ZC=<<'EOF'; ZONE : ndd-de-test-0001.fr. NS : ns1.nic.fr. NS : ns2.nic.fr. NS : ns.ndd-de-test-0001.fr. [192.93.0.1, 2001:660:3005:1::1:1] ==> SUCCESS EOF $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2008-12-25T00:01:00.0Z'.$ZC.'ndd-de-test-0001.frune-reference-client-par-exemplefrnic-000000032008-12-25T00:01:00.0Z'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),50001,'message get_info last_id 1'); is($dri->get_info('last_id','message','session'),50001,'message get_info last_id 2'); is($dri->get_info('id','message',50001),50001,'message get_info id'); is(''.$dri->get_info('qdate','message',50001),'2008-12-25T00:01:00','message get_info qdate'); is($dri->get_info('object_type','message',50001),'domain','message get_info object_type'); is($dri->get_info('object_id','message',50001),'ndd-de-test-0001.fr','message get_info id'); is($dri->get_info('action','message',50001),'review_zonecheck','message get_info action'); ## with this, we know what action has triggered this delayed message is($dri->get_info('result','message',50001),1,'message get_info result'); is($dri->get_info('trid','message',50001),'une-reference-client-par-exemple','message get_info trid'); is($dri->get_info('svtrid','message',50001),'frnic-00000003','message get_info svtrid'); is(''.$dri->get_info('date','message',50001),'2008-12-25T00:01:00','message get_info date'); is($dri->get_info('result','domain','ndd-de-test-0001.fr'),1,'message get_info(result,domain,$DOM)'); is_string($dri->get_info('review_zonecheck','domain','ndd-de-test-0001.fr'),$ZC,'message get_info(review_zonecheck,domain,$DOM)'); #################################################################################################### ## §2.5.1 ## (clTRID changed from example + added xsiSchemaLocation) $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('PR1249'),'registrant'); $cs->set($dri->local_object('contact')->srid('VL'),'admin'); $cs->set($dri->local_object('contact')->srid('AI1'),'tech'); $cs->add($dri->local_object('contact')->srid('PR1249'),'tech'); $R2=$E1.''.r().'ndd-de-test-0001.frpendingBEdemandeurID2009-01-01T00:00:00.0ZPR12492009-01-09T00:00:00.0ZBEactuelIDMM45672009-01-09T00:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_trade_start('ndd-de-test-0001.fr',{contact=>$cs}); is_string($R1,$E1.'ndd-de-test-0001.frPR1249VLAI1PR1249ABC-12345'.$E2,'domain_trade_start build'); is($dri->get_info('trStatus'),'pending','domain_trade_start get_info(trStatus)'); is($dri->get_info('reID'),'BEdemandeurID','domain_trade_start get_info(reID)'); is(''.$dri->get_info('reDate'),'2009-01-01T00:00:00','domain_trade_start get_info(reDate)'); is($dri->get_info('reHldID'),'PR1249','domain_trade_start get_info(reHldID)'); is(''.$dri->get_info('rhDate'),'2009-01-09T00:00:00','domain_trade_start get_info(rhDate)'); is($dri->get_info('acID'),'BEactuelID','domain_trade_start get_info(acID)'); is($dri->get_info('acHldID'),'MM4567','domain_trade_start get_info(acHldID)'); is(''.$dri->get_info('ahDate'),'2009-01-09T00:00:00','domain_trade_start get_info(ahDate)'); #################################################################################################### ## §2.5.2 $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2009-12-25T00:02:00.0ZTrade requested.ndd-de-test-0001.frpendingBEdemandeurID2009-01-01T00:00:00.0Z2009-01-09T00:00:00.0ZBEactuelIDMM45672009-01-09T00:00:00.0Z'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),50010,'message get_info last_id 1'); is($dri->get_info('content','message',50010),'Trade requested.','message get_info message'); is(''.$dri->get_info('qdate','message',50010),'2009-12-25T00:02:00','message get_info qdate'); is($dri->get_info('object_type','message',50010),'domain','retrieve trade get_info object_type'); is($dri->get_info('object_id','message',50010),'ndd-de-test-0001.fr','retrieve trade get_info id'); is($dri->get_info('trStatus','domain','ndd-de-test-0001.fr'),'pending','retrieve trade get_info(trStatus)'); is($dri->get_info('reID','domain','ndd-de-test-0001.fr'),'BEdemandeurID','retrieve trade get_info(reID)'); is(''.$dri->get_info('reDate','domain','ndd-de-test-0001.fr'),'2009-01-01T00:00:00','retrieve trade get_info(reDate)'); is(''.$dri->get_info('rhDate','domain','ndd-de-test-0001.fr'),'2009-01-09T00:00:00','retrieve trade get_info(rhDate)'); is($dri->get_info('acID','domain','ndd-de-test-0001.fr'),'BEactuelID','retrieve trade get_info(acID)'); is($dri->get_info('acHldID','domain','ndd-de-test-0001.fr'),'MM4567','retrieve trade get_info(acHldID)'); is(''.$dri->get_info('ahDate','domain','ndd-de-test-0001.fr'),'2009-01-09T00:00:00','retrieve trade get_info(ahDate)'); ## Other two examples are mostly the same, parsing wise. #################################################################################################### ## §2.5.4 ## domain_trade_query : no example #################################################################################################### ## §2.6.1 ## (clTRID changed from example + added xsiSchemaLocation) $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('PR1249'),'registrant'); $cs->set($dri->local_object('contact')->srid('VL'),'admin'); $cs->set($dri->local_object('contact')->srid('AI1'),'tech'); $cs->add($dri->local_object('contact')->srid('PR1249'),'tech'); $R2=$E1.''.r().'ndd-de-test-0001.frBEdemandeurID2009-01-01T00:00:00.0ZPR1249BEactuelIDMM4567'.$TRID.''.$E2; $rc=$dri->domain_recover_start('ndd-de-test-0001.fr',{contact=>$cs,auth=>{pw=>'NDCR20080229T173000.123456789'}}); is_string($R1,$E1.'ndd-de-test-0001.frNDCR20080229T173000.123456789PR1249VLAI1PR1249ABC-12345'.$E2,'domain_recover_start build'); is($dri->get_info('reID'),'BEdemandeurID','domain_recover_start get_info(reID)'); is(''.$dri->get_info('reDate'),'2009-01-01T00:00:00','domain_recover_start get_info(reDate)'); is($dri->get_info('reHldID'),'PR1249','domain_recover_start get_info(reHldID)'); is($dri->get_info('acID'),'BEactuelID','domain_recover_start get_info(acID)'); is($dri->get_info('acHldID'),'MM4567','domain_recover_start get_info(acHldID)'); #################################################################################################### ## §2.7 $R2=$E1.''.r().'afnic.frIn useaf-1234-nic.frbois-guillaume.frparis.frIn usetrafiquants.frForbidden nametoto.wfZone not openedafnic.fraf-1234-nic.frbois-guillaume.frCity nameparis.frCity nametrafiquants.frLegal issuetoto.wf'.$TRID.''.$E2; $rc=$dri->domain_check_multi(qw/afnic.fr af-1234-nic.fr bois-guillaume.fr paris.fr trafiquants.fr toto.wf/); is_string($R1,$E1.'afnic.fraf-1234-nic.frbois-guillaume.frparis.frtrafiquants.frtoto.wfABC-12345'.$E2,'domain_check build'); is($rc->is_success(),1,'domain_check_multi is_success'); is($dri->get_info('exist','domain','afnic.fr'),1,'domain_check_multi get_info(exist,domain1)'); is($dri->get_info('exist_reason','domain','afnic.fr'),'In use','domain_check_multi get_info(exist_reason,domain1)'); is($dri->get_info('exist','domain','af-1234-nic.fr'),0,'domain_check_multi get_info(exist,domain2)'); is($dri->get_info('exist','domain','bois-guillaume.fr'),0,'domain_check_multi get_info(exist,domain3)'); is($dri->get_info('exist','domain','paris.fr'),1,'domain_check_multi get_info(exist,domain4)'); is($dri->get_info('exist_reason','domain','paris.fr'),'In use','domain_check_multi get_info(exist_reason,domain4)'); is($dri->get_info('exist','domain','trafiquants.fr'),1,'domain_check_multi get_info(exist,domain5)'); is($dri->get_info('exist_reason','domain','trafiquants.fr'),'Forbidden name','domain_check_multi get_info(exist_reason,domain5)'); is($dri->get_info('exist','domain','toto.wf'),1,'domain_check_multi get_info(exist,domain6)'); is($dri->get_info('exist_reason','domain','toto.wf'),'Zone not opened','domain_check_multi get_info(exist_reason,domain6)'); is($dri->get_info('reserved_reason','domain','bois-guillaume.fr'),'City name','domain_check_multi get_info(reserved_reason,domain3)'); is($dri->get_info('reserved_reason','domain','paris.fr'),'City name','domain_check_multi get_info(reserved_reason,domain4)'); is($dri->get_info('forbidden_reason','domain','trafiquants.fr'),'Legal issue','domain_check_multi get_info(forbidden_reason,domain5)'); is($dri->get_info('forbidden','domain','afnic.fr'),0,'domain_check_multi get_info(forbidden,domain1)'); is($dri->get_info('reserved','domain','afnic.fr'),0,'domain_check_multi get_info(reserved,domain1)'); is($dri->get_info('reserved','domain','bois-guillaume.fr'),1,'domain_check_multi get_info(reserved,domain3)'); is($dri->get_info('forbidden','domain','trafiquants.fr'),1,'domain_check_multi get_info(forbidden,domain5)'); #################################################################################################### ## §2.8.2 $R2=$E1.''.r().'ndd-de-test-0001.frDOM000000456987-FRNICMM4567NFC1NFC1VLns1.nic.frns2.nic.frns.ndd-de-test-0001.fr192.93.0.12001:660:3005:1::1:1ns.ndd-de-test-0001.frns1234.ndd-de-test-0001.frBEactuelID2008-12-25T00:00:00.0Z2009-12-25T00:00:00.0Z2009-01-10T00:00:00.0ZWarlordZ666'.$TRID.''.$E2; $rc=$dri->domain_info('ndd-de-test-0001.fr'); is($rc->is_success(),1,'domain_info is_success'); $s=$dri->get_info('status'); is_deeply([$s->list_status()],[qw/serverRecoverProhibited serverTradeProhibited/],'domain_info get_info(status) list_status'); #################################################################################################### ## §3.1 ## corrected misplacement of contact:id $R2=$E1.''.r().'VL999992008-11-20T00:00:00.0Zno'.$TRID.''.$E2; $co=$dri->local_object('contact'); $co->name('Levigneron'); $co->firstname('Vincent'); $co->org('AFNIC'); $co->street(['immeuble international','2, rue Stephenson','Montigny le Bretonneux']); $co->city('Saint Quentin en Yvelines Cedex'); $co->pc('78181'); $co->cc('FR'); $co->voice('+33.0139308333'); $co->fax('+33.0139308301'); $co->email('vincent.levigneron@nic.fr'); $co->auth({pw=>'UnusedPassword'}); $co->disclose('N'); $co->birth({date=>'1968-07-20',place=>'76000, Rouen'}); $rc=$dri->contact_create($co); is_string($R1,$E1.'AUTOLevigneronAFNICimmeuble international2, rue StephensonMontigny le BretonneuxSaint Quentin en Yvelines Cedex78181FR+33.0139308333+33.0139308301vincent.levigneron@nic.frUnusedPasswordrestrictedPublication1968-07-20Rouen76000FRVincentABC-12345'.$E2,'contact_create PP build'); is($rc->is_success(),1,'contact_create is_success'); is($dri->get_info('id'),'VL99999','contact_create get_info(id)'); is($dri->get_info('action','contact','VL99999'),'create','contact_create get_info(action)'); is($dri->get_info('exist','contact','VL99999'),1,'contact_create get_info(exist)'); is($dri->get_info('new_handle','contact','VL99999'),1,'contact_create get_info(new_handle)'); is($dri->get_info('identification','contact','VL99999'),'no','contact_create get_info(identification)'); $R2=''; $co=$dri->local_object('contact'); $co->name('Service des Réclamations'); $co->org('AFNIC Corp'); $co->street(['immeuble international','2, rue Stephenson','Montigny le Bretonneux']); $co->city('Saint Quentin en Yvelines Cedex'); $co->pc('78181'); $co->cc('FR'); $co->voice('+33.0139308333'); $co->fax('+33.0139308301'); $co->email('vincent.levigneron@nic.fr'); $co->auth({pw=>'UnusedPassword'}); $co->legal_form('company'); $co->legal_id(123456789); $co->trademark('27YOUPLA2345678'); $co->jo({date_declaration=>'1999-05-19',number=>5, page=>2, date_publication=>'1999-06-01'}); $rc=$dri->contact_create($co); is_string($R1,$E1.'AUTOService des RéclamationsAFNIC Corpimmeuble international2, rue StephensonMontigny le BretonneuxSaint Quentin en Yvelines Cedex78181FR+33.0139308333+33.0139308301vincent.levigneron@nic.frUnusedPassword12345678927YOUPLA23456781999-05-191999-06-01ABC-12345'.$E2,'contact_create PM build'); #################################################################################################### ## §3.2 $co=$dri->local_object('contact')->srid('VL99999'); $toc=$dri->local_object('changes'); $toc->del('disclose','restrictedPublication'); $dri->contact_update($co,$toc); is_string($R1,$E1.'VL99999restrictedPublicationABC-12345'.$E2,'contact_update build'); #################################################################################################### ## §3.5 $R2=$E1.''.r().'VL99999VL9999-FRNICLevigneronAFNICimmeuble international2, rue StephensonMontigny le BretonneuxSaint Quentin en Yvelines Cedex78181FR+33.0139308333+33.0139308301vincent.levigneron@nic.frBEactuelIDBEcreateurID2008-11-20T00:00:00.0Z2008-12-25T00:00:00.0ZVincentrestrictedPublicationok1968-07-20Rouen76000FR'.$TRID.''.$E2; $dri->contact_info($co); is($rc->is_success(),1,'contact_info is_success'); is($dri->get_info('action'),'info','contact_info get_info(action)'); is($dri->get_info('exist'),1,'contact_info get_info(exist)'); is($dri->get_info('identification'),'ok','contact_info get_info(identification)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::Contact::AFNIC','contact_info get_info(self)'); is($co->name(),'Levigneron','contact_info get_info(self) name'); is($co->firstname(),'Vincent','contact_info get_info(self) firstname'); is($co->disclose(),'N','contact_info get_info(self) disclose'); ## means restrictedPublication my $b=$co->birth(); is($b->{date},'1968-07-20','contact_info get_info(self) birth date'); is($b->{place},'76000, Rouen','contact_info get_info(self) birth place'); #################################################################################################### ## Identification $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2009-05-05T07:52:47.0ZIdentification process begins.ET1323deprecated123456789FR123456789027YOUPLA2345678'.$TRID.''.$E2; $rc=$dri->message_retrieve(); my $msgid=$rc->get_data('message','session','last_id'); my $oid=$rc->get_data('message',$msgid,'object_id'); is($rc->get_data('message',$msgid,'object_type'),'contact','message object_type'); is($rc->get_data('contact',$oid,'process'),'start','contact process'); my $c=$rc->get_data('contact',$oid,'self'); isa_ok($c,'Net::DRI::Data::Contact::AFNIC','contact self'); is($c->srid(),'ET1323','contact srid()'); is($c->id_status(),'deprecated','contact id_status()'); is($c->legal_form(),'company','contact legal_form()'); is($c->legal_id(),'123456789','contact legal_id()'); is($c->vat(),'FR1234567890','contact vat()'); is($c->trademark(),'27YOUPLA2345678','contact trademark()'); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2009-05-05T07:52:49.0ZIdentification process finished.ET1323okNEW-TRADEMARK-ID'.$TRID.''.$E2; $rc=$dri->message_retrieve(); $msgid=$rc->get_data('message','session','last_id'); $oid=$rc->get_data('message',$msgid,'object_id'); is($rc->get_data('contact',$oid,'process'),'finished','contact process'); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2009-05-05T07:52:48.0ZIdentification process in progress.ET1323problem123456789FR123456789027YOUPLA2345678VAT number not found in public basessiren number not found in public basestrademark ID not found in public bases'.$TRID.''.$E2; $rc=$dri->message_retrieve(); $msgid=$rc->get_data('message','session','last_id'); $oid=$rc->get_data('message',$msgid,'object_id'); is($rc->get_data('contact',$oid,'process'),'pending','contact process'); $c=$rc->get_data('contact',$oid,'self'); is($c->id_status(),'problem','contact id_status()'); is_deeply($rc->get_data('contact',$oid,'reasons'),['VAT number not found in public bases','siren number not found in public bases','trademark ID not found in public bases'],'contact reasons'); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2009-05-05T07:52:50.0ZHolder identification prevents DNS announcement.nic.frXXX1234'.$TRID.''.$E2; $rc=$dri->message_retrieve(); $msgid=$rc->get_data('message','session','last_id'); is($rc->get_data('message',$msgid,'object_type'),'domain','message object_type'); $oid=$rc->get_data('message',$msgid,'object_id'); is($oid,'nic.fr','domain name'); $s=$rc->get_data('domain',$oid,'status'); isa_ok($s,'Net::DRI::Protocol::EPP::Core::Status','domain status'); is_deeply([$s->list_status()],['serverHold'],'domain status list_status()'); $cs=$rc->get_data('domain',$oid,'contact'); isa_ok($cs,'Net::DRI::Data::ContactSet','domain contact'); is_deeply([$cs->types()],['registrant'],'domain contact types'); $c=$cs->get('registrant'); isa_ok($c,'Net::DRI::Data::Contact::AFNIC','domain contact registrant'); is($c->srid(),'XXX1234','domain contact srid()'); exit 0; Net-DRI-0.96/t/621centralnic_epp.t0000755000175000017500000002257011241325453016346 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 13; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('CentralNic'); $dri->target('CentralNic')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); #################################################################################################### ## DNS TTL extension $R2=$E1.''.r().'example2.eu.comCNIC-DO302520C11480C11480C11480ns0.example.comns1.example.com1995-01-01T00:00:00.0Z2020-01-01T23:59:59.0Z2005-05-14T11:15:19.0Z3600'.$TRID.''.$E2; $rc=$dri->domain_info('example2.eu.com'); $s=$dri->get_info('ttl'); isa_ok($s,'DateTime::Duration','TTL extension : ttl key'); is($s->in_units('seconds'),3600,'TTL extension : value'); $R2=''; my $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('C11480'),'registrant'); $cs->set($dri->local_object('contact')->srid('C11480'),'tech'); $rc=$dri->domain_create('example2.eu.com',{pure_create=>1,contact=>$cs,auth=>{pw=>'2fooBAR'},ttl=>DateTime::Duration->new(seconds => 300)}); is_string($R1,$E1.'example2.eu.comC11480C114802fooBAR300ABC-12345'.$E2,'TTL extension : domain_create build with DateTime::Duration'); $R2=''; $rc=$dri->domain_create('example3.eu.com',{pure_create=>1,contact=>$cs,auth=>{pw=>'2fooBAR'},ttl=>600}); is_string($R1,$E1.'example3.eu.comC11480C114802fooBAR600ABC-12345'.$E2,'TTL extension : domain_create build with integer'); $R2=''; my $toc=$dri->local_object('changes'); $toc->set('ttl',300); $rc=$dri->domain_update('example4.eu.com',$toc); is_string($R1,$E1.'example4.eu.com300ABC-12345'.$E2,'TTL extension : domain_update build'); #################################################################################################### ## Web Forwarding extension $R2=$E1.''.r().'example5.eu.comCNIC-DO302520C11480C11480C114801995-01-01T00:00:00.0Z2020-01-01T23:59:59.0Z2005-05-14T11:15:19.0Zhttp://www.example.com/'.$TRID.''.$E2; $rc=$dri->domain_info('example5.eu.com'); $s=$dri->get_info('web_forwarding'); is($s,'http://www.example.com/','WebForwarding extension : value'); $R2=''; $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('C11480'),'registrant'); $cs->set($dri->local_object('contact')->srid('C11480'),'tech'); $rc=$dri->domain_create('example6.eu.com',{pure_create=>1,contact=>$cs,auth=>{pw=>'2fooBAR'},web_forwarding=>'http://www.example.com/'}); is_string($R1,$E1.'example6.eu.comC11480C114802fooBARhttp://www.example.com/ABC-12345'.$E2,'WebForwarding extension : domain_create build'); $R2=''; $toc=$dri->local_object('changes'); $toc->set('web_forwarding','http://www.example.com/'); $rc=$dri->domain_update('example7.eu.com',$toc); is_string($R1,$E1.'example7.eu.comhttp://www.example.com/ABC-12345'.$E2,'WebForwarding extension: domain_update build'); $R2=''; $toc=$dri->local_object('changes'); $toc->set('web_forwarding',''); $rc=$dri->domain_update('example8.eu.com',$toc); is_string($R1,$E1.'example8.eu.comABC-12345'.$E2,'WebForwarding extension: domain_update build with empty url'); #################################################################################################### ## Release extension $R2=$E1.''.r(1001,'Command completed successfully.').'example9.eu.comapproved'.$TRID.''.$E2; $rc=$dri->domain_release('example9.eu.com',{clID=>'H12345'}); is_string($R1,$E1.'example9.eu.comH12345ABC-12345'.$E2,'Release extension: domain_release build'); is($rc->is_success(),1,'Release extension: domain_release is_success'); is($rc->is_pending(),1,'Release extension: domain_release is_pending'); is($dri->get_info('trStatus'),'approved','Release extension: domain_release get_info(trStatus)'); #################################################################################################### exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/607pl_epp.t0000755000175000017500000002737711350046265014657 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 28; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; eval { $dri->add_registry('PL'); $dri->target('PL')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); }; if ($@) { if (ref($@)) { die($@->as_string()); } else { die($@); } } my ($rc,$d,$co,$dh,@c); #################################################################################################### ## Examples taken from draft-zygmuntowicz-epp-pltld-02.txt §4 ## Example 1, CORRECTED (domain:hostObj) ## + Example 2 CORRECTED (invalid date in exDate) $R2=$E1.''.r().'przyklad44.pl1999-04-03T22:00:00.0Z2000-04-03T22:00:00.0Z'.$TRID.''.$E2; $dh=$dri->local_object('hosts'); $dh->add('ns.przyklad2.pl'); $dh->add('ns5.przyklad.pl'); eval { $rc=$dri->domain_create('przyklad44.pl',{pure_create=>1,ns=>$dh,auth=>{pw=>'authinfo_of_d97'},book=>1,reason=>'nice name'}); }; if ($@) { if (ref($@)) { die($@->as_string()); } else { die($@); } } is($R1,'przyklad44.plns.przyklad2.plns5.przyklad.plauthinfo_of_d97nice nameABC-12345','domain_create build with book'); is($rc->is_success(),1,'domain_create is_success'); $d=$dri->get_info('crDate'); is(''.$d,'1999-04-03T22:00:00','domain_create get_info(crDate)'); $d=$dri->get_info('exDate'); is(''.$d,'2000-04-03T22:00:00','domain_create get_info(exDate)'); ## Examples 3,4,5,6,7,8 are standard EPP, thus not tested here ## Example 9 + Example 10, CORRECTED (type=loc instead of type=int) $R2=$E1.''.r().'sh80131999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('sh8013'); $co->name('11John Doe'); $co->org('Example Inc.'); $co->street(['123 Example Dr.','Suite 100']); $co->city('Dulles'); $co->sp('VA'); $co->pc('20166-6503'); $co->cc('US'); $co->voice('+1.7035555555x1234'); $co->fax('+1.7035555556'); $co->email('jdoe@example.tld'); $co->auth({pw=>'2fooBAR'}); $co->individual(1); $co->consent_for_publishing(1); $rc=$dri->contact_create($co); is($R1,'sh801311John DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+1.7035555555+1.7035555556jdoe@example.tld2fooBAR11ABC-12345','contact_create build'); is($rc->is_success(),1,'contact_create is_success'); $d=$dri->get_info('id'); is($d,'sh8013','contact_create get_info(id)'); $d=$dri->get_info('crDate'); is(''.$d,'1999-04-03T22:00:00','contact_create get_info(crDate)'); ## Example 11 $rc=$dri->contact_info($dri->local_object('contact')->srid('666666'),{auth=>{pw=>'2fooBAR'}}); is($R1,'6666662fooBARABC-12345','contact_info build'); is($rc->is_success(),1,'contact_info is_success'); ## Example 12 is standard EPP, thus not tested here ## Example 13, CORRECTED (type=loc instead of type=int) $co=$dri->local_object('contact')->srid('sh8013'); $toc=$dri->local_object('changes'); my $co2=$dri->local_object('contact'); $co2->org(''); $co2->street(['124 Example Dr.','Suite 200']); $co2->city('Dulles'); $co2->sp('VA'); $co2->pc('20166-6503'); $co2->cc('US'); $co2->voice('+1.7034444444'); $co2->fax(''); $co2->consent_for_publishing(1); $toc->set('info',$co2); $toc->add('status',$dri->local_object('status')->no('delete')); $rc=$dri->contact_update($co,$toc); is($R1,'sh8013124 Example Dr.Suite 200DullesVA20166-6503US+1.70344444441ABC-12345','contact_update build'); is($rc->is_success(),1,'contact_update is_success'); ## Example 14 is standard EPP, thus not tested here #################################################################################################### ## Bugs which turned up during production $R2=$E1.'Command completed successfullyns1.rawr.com'.$TRID.''.$E2; my $host = $dri->local_object('hosts')->add('ns1.rawr.com'); eval { $rc = $dri->host_check($host); }; if ($@) { if (ref($@)) { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'host_check is_success'); is($dri->get_info('exist', 'host', 'ns1.rawr.com'), 0, 'host does not exist'); ## .PL message polling $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-04-07T09:28:40.163Zdomain authInfotest.com.plJuhIFbrKfX4xReybrUe1pZs' . $TRID . '' . $E2; eval { $rc = $dri->message_retrieve(); }; if ($@) { if (ref($@)) { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'message_retrieve'); is($dri->get_info('last_id'), 27389, 'message get_info last_id 1'); is_deeply([$dri->get_info('auth', 'domain', 'test.com.pl')], [{ pw => 'JuhIFbrKfX4xReybrUe1pZs' }], 'message get_info auth pw'); is($dri->get_info('exist', 'domain', 'test.com.pl'), 1, 'Domain exists'); is($dri->get_info('name', 'domain', 'test.com.pl'), 'test.com.pl', 'Domain name is correct'); is($dri->get_info('action', 'message', 27389), 'pollAuthInfo', 'Action is pollAuthInfo'); ## more .PL message polling $R2=$E1.'Command completed successfully; ack to dequeue2008-04-18T07:03:35.880Zdomain transfer requestedsyhosting.plpendingtheuser2008-04-18T07:03:35.487Zirgendwas2008-05-18T07:03:35.487Z'.$TRID.''.$E2; eval { $rc = $dri->message_retrieve(); }; if ($@) { if (ref($@)) { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'message_retrieve'); is($dri->get_info('last_id'), 8308, 'message get_info last_id 1'); is($dri->get_info('action', 'message', 8308), 'transfer', 'Action is correct'); is($dri->get_info('content','message', 8308), 'domain transfer requested', 'Content is correct'); is($dri->get_info('object_id', 'message', 8308), 'syhosting.pl', 'Object ID is correct'); is($dri->get_info('object_type', 'message', 8308), 'domain', 'Object type is correct'); ## Multiple level domain registration is($dri->verify_name_domain('sygroup.com.pl', 'info'), '', 'third.com.pl registrability'); is($dri->verify_name_domain('sygroup.net.pl', 'info'), '', 'third.net.pl registrability'); exit 0; Net-DRI-0.96/t/704opensrs_xcp_live.t0000755000175000017500000000514611137716740016753 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Test::More; unless ($ENV{TEST_OPENSRS_XCP_LIVE_CLIENTID} && $ENV{TEST_OPENSRS_XCP_LIVE_CLIENTPASS}) { plan skip_all => 'Set $ENV{TEST_OPENSRS_XCP_LIVE_CLIENTID} and $ENV{TEST_OPENSRS_XCP_LIVE_CLIENTPASS} (the key) if you want (normally harmless) *live* tests for OpenSRS'; } else { plan tests => 3; } my $dri=Net::DRI::TrapExceptions->new(10); $dri->add_registry('OpenSRS'); $dri->target('OpenSRS')->add_current_profile('p1','xcp',{client_login=>$ENV{TEST_OPENSRS_XCP_LIVE_CLIENTID},client_password=>$ENV{TEST_OPENSRS_XCP_LIVE_CLIENTPASS},remote_url=>'https://rr-n1-tor.opensrs.net:55443/resellers/',verify_response => \&verify_response}); eval { my $rc=$dri->account_list_domains(); is($rc->is_success(),1,'account_list_domains() is_success') or diag(sprintf('Code=%d Native_Code=%s Message=%s',$rc->code(),$rc->native_code(),$rc->message())); my $rd=$dri->get_info('list','account','domains'); is(ref($rd),'ARRAY','get_info(list,account,domains)'); diag('Successfully retrieved list of '.scalar(@$rd).' domain names: '.join(' ',@$rd)) if ($rd && ref($rd) eq 'ARRAY'); my $rd2=$dri->get_info('list'); is_deeply($rd2,$rd,'get_info(list,account,domains) and get_info(list) give the same results'); ## If you have a domain name, you could get back information like that: ## (it seems username and password are mandatory for domain_info, and they have nothing to do with reseller login/key) # $rc=$dri->domain_info('DOMAIN',{username => 'USERNAME', password => 'PASSWORD'}); # diag('Nameservers: '.$dri->get_info('ns')->as_string()); # diag('Expiration: '.$dri->get_info('exDate')); # diag('Auto Renew: '.$dri->get_info('auto_renew')); # diag('Owner Contact: '.$dri->get_info('contact')->get('registrant')->as_string()); # diag('Admin Contact: '.$dri->get_info('contact')->get('admin')->as_string()); # diag('Tech Contact: '.$dri->get_info('contact')->get('tech')->as_string()); }; diag('Caught unexpected exception: '.(ref($@)? $@->as_string() : $@)) if $@; exit 0; sub verify_response { my ($to,$phase,$count,$req,$ans)=@_; ## Transport object, Phase (1=login,2=normal operations,3=logout), Count (number of times we tried sending that message), HTTP::Request and HTTP::Response objects ## If you need to verify SSL stuff right at the beginning before sending anything, use header If-SSL-Cert-Subject (see LWP::Protocol::https) diag('Got SSL Cert Issuer: '.$ans->header('Client-SSL-Cert-Issuer')); diag('Got SSL Cert Subject: '.$ans->header('Client-SSL-Cert-Subject')); diag('Got SSL Cipher: '.$ans->header('Client-SSL-Cipher')); diag('Got SSL Warning: '.$ans->header('Client-SSL-Warning')); } Net-DRI-0.96/t/102util.t0000755000175000017500000002452110442634643014333 0ustar patrickpatrick#!/usr/bin/perl -w use Test::More tests => 340; use Net::DRI::Util; is(defined(%Net::DRI::Util::CCA2),1,'%CCA2 defined'); isa_ok(\%Net::DRI::Util::CCA2,'HASH','%CCA2 hash'); is(keys(%Net::DRI::Util::CCA2),243,'%CCA2 number of elements'); is_deeply([grep { ! /^[A-Z]{2}$/ } keys(%Net::DRI::Util::CCA2)],[],'%CCA2 keys'); is(exists($Net::DRI::Util::CCA2{'FR'}),1,'%CCA2 FR exists'); is(!exists($Net::DRI::Util::CCA2{'ZZ'}),1,'%CCA2 ZZ not exists'); is(Net::DRI::Util::all_valid(undef,1,'A'),0,'all_valid() with one undef'); is(Net::DRI::Util::all_valid('B',undef,2,undef),0,'all_valid() with two undef'); is(Net::DRI::Util::all_valid(),1,'all_valid() empty'); is(Net::DRI::Util::all_valid(67,'AB'),1,'all_valid() not empty'); is(Net::DRI::Util::isint(-6),0,'isint(-6)'); is(Net::DRI::Util::isint(6),1,'isint(6)'); is(Net::DRI::Util::isint(67886),1,'isint(67886)'); is(Net::DRI::Util::isint('A'),0,'isint(A)'); is(Net::DRI::Util::check_equal(),undef,'check_equal()'); is(Net::DRI::Util::check_equal('A','A'),'A','check_equal(A,A)'); is(Net::DRI::Util::check_equal('A',['A']),'A','check_equal(A,[A])'); is(Net::DRI::Util::check_equal('A',['B','A']),'A','check_equal(A,[B,A])'); is(Net::DRI::Util::check_equal('A','C','def'),'def','check_equal(A,C,def)'); is(Net::DRI::Util::check_equal('A','C'),undef,'check_equal(A,C)'); eval { Net::DRI::Util::check_isa(bless({},'FooBar'),'FooBuz'); }; isa_ok($@,'Net::DRI::Exception','check_isa(FooBar,FooBuz)'); is(Net::DRI::Util::check_isa(bless({},'FooBar'),'FooBar'),1,'check_isa(FooBar,FooBuz)'); like(Net::DRI::Util::microtime(),qr/^\d{16}$/,'microtime()'); like(Net::DRI::Util::create_trid_1('name'),qr/^NAME-\d+-\d{16}$/,'create_trid_1(name)'); is(Net::DRI::Util::is_hostname(),0,'is_hostname()'); is(Net::DRI::Util::is_hostname('.'),0,'is_hostname(.)'); is(Net::DRI::Util::is_hostname('a.'),0,'is_hostname(a.)'); is(Net::DRI::Util::is_hostname('.a'),0,'is_hostname(.a)'); is(Net::DRI::Util::is_hostname('a..b'),0,'is_hostname(a..b)'); is(Net::DRI::Util::is_hostname('a.foo'),1,'is_hostname(a.foo)'); is(Net::DRI::Util::is_hostname('0.foo'),1,'is_hostname(0.foo)'); is(Net::DRI::Util::is_hostname('a.0.foo'),1,'is_hostname(a.0.foo)'); is(Net::DRI::Util::is_hostname('abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijk.foo'),1,'is_hostname(abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyabcdefghijk.foo)'); is(Net::DRI::Util::is_hostname('abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijkl.foo'),0,'is_hostname(abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyabcdefghijkl.foo)'); is(Net::DRI::Util::is_hostname('-a.foo'),0,'is_hostname(-a.foo)'); is(Net::DRI::Util::is_hostname('a-.foo'),0,'is_hostname(a-.foo)'); is(Net::DRI::Util::is_hostname('a-b.foo'),1,'is_hostname(a-b.foo)'); is(Net::DRI::Util::is_hostname('a_b.foo'),0,'is_hostname(a_b.foo)'); is(Net::DRI::Util::is_hostname('a b.foo'),0,'is_hostname(a b.foo)'); foreach (0..255) { next if ($_==45) || ($_==46) || (($_>=48) && ($_<=57)) || (($_>=65) && ($_<=90)) || (($_>=97) && ($_<=122)); my $d='a'.chr($_).'b.foo'; is(Net::DRI::Util::is_hostname($d),0,"is_hostname($d)"); } is(Net::DRI::Util::is_ipv4(),0,'is_ipv4()'); is(Net::DRI::Util::is_ipv4('ab'),0,'is_ipv4(ab)'); is(Net::DRI::Util::is_ipv4('256.1.2.3'),0,'is_ipv4(256.1.2.3)'); is(Net::DRI::Util::is_ipv4('1.2.3'),0,'is_ipv4(1.2.3)'); is(Net::DRI::Util::is_ipv4('1.2.3.7.8'),0,'is_ipv4(1.2.3.7.8)'); is(Net::DRI::Util::is_ipv4('1.ab.6.7'),0,'is_ipv4(1.ab.6.7)'); is(Net::DRI::Util::is_ipv4('1.2.3.4'),1,'is_ipv4(1.2.3.4)'); is(Net::DRI::Util::is_ipv4('1.2.3.4',1),1,'is_ipv4(1.2.3.4,1)'); is(Net::DRI::Util::is_ipv4('0.1.2.3',1),0,'is_ipv4(0.1.2.3,1)'); is(Net::DRI::Util::is_ipv4('10.1.2.3',1),0,'is_ipv4(10.1.2.3,1)'); is(Net::DRI::Util::is_ipv4('127.1.2.3',1),0,'is_ipv4(127.1.2.3,1)'); is(Net::DRI::Util::is_ipv4('169.254.6.7',1),0,'is_ipv4(169.254.6.7,1)'); is(Net::DRI::Util::is_ipv4('172.16.1.2',1),0,'is_ipv4(172.16.1.2,1)'); is(Net::DRI::Util::is_ipv4('172.33.1.2',1),1,'is_ipv4(172.33.1.2,1)'); is(Net::DRI::Util::is_ipv4('192.0.2.6',1),0,'is_ipv4(192.0.2.6,1)'); is(Net::DRI::Util::is_ipv4('192.168.1.3',1),0,'is_ipv4(192.168.1.3)'); is(Net::DRI::Util::is_ipv4('230.0.0.0',1),0,'is_ipv4(230.0.0.0,1)'); TODO: { local $TODO="tests on is_ipv6(), compare_duration()"; ok(0); } is(Net::DRI::Util::xml_is_normalizedstring("A\tB"),0,'xml_is_normalizedstring() 1'); is(Net::DRI::Util::xml_is_normalizedstring("A",1),1,'xml_is_normalizedstring() 2'); is(Net::DRI::Util::xml_is_normalizedstring("A",2),0,'xml_is_normalizedstring() 3'); is(Net::DRI::Util::xml_is_normalizedstring("A",undef,1),1,'xml_is_normalizedstring() 4'); is(Net::DRI::Util::xml_is_normalizedstring("AB",undef,1),0,'xml_is_normalizedstring() 5'); is(Net::DRI::Util::xml_is_normalizedstring("A",1,2),1,'xml_is_normalizedstring() 6'); is(Net::DRI::Util::xml_is_normalizedstring("A",1,1),1,'xml_is_normalizedstring() 7'); is(Net::DRI::Util::xml_is_normalizedstring("AB",1,2),1,'xml_is_normalizedstring() 8'); is(Net::DRI::Util::xml_is_normalizedstring("ABC",1,2),0,'xml_is_normalizedstring() 9'); is(Net::DRI::Util::xml_is_normalizedstring(),0,'xml_is_normalizedstring() 10'); is(Net::DRI::Util::xml_is_token("A\tB"),0,'xml_is_token() 1'); is(Net::DRI::Util::xml_is_token(" AB"),0,'xml_is_token() 2'); is(Net::DRI::Util::xml_is_token("AB "),0,'xml_is_token() 3'); is(Net::DRI::Util::xml_is_token("A B"),0,'xml_is_token() 4'); is(Net::DRI::Util::xml_is_token("A",1),1,'xml_is_token() 5'); is(Net::DRI::Util::xml_is_token("A",2),0,'xml_is_token() 6'); is(Net::DRI::Util::xml_is_token("A",undef,1),1,'xml_is_token() 7'); is(Net::DRI::Util::xml_is_token("AB",undef,1),0,'xml_is_token() 8'); is(Net::DRI::Util::xml_is_token("A",1,2),1,'xml_is_token() 9'); is(Net::DRI::Util::xml_is_token("A",1,1),1,'xml_is_token() 10'); is(Net::DRI::Util::xml_is_token("AB",1,2),1,'xml_is_token() 11'); is(Net::DRI::Util::xml_is_token("ABC",1,2),0,'xml_is_token() 12'); is(Net::DRI::Util::xml_is_token(),0,'xml_is_token() 13'); is(Net::DRI::Util::verify_ushort(),0,'verify_ushort() 1'); is(Net::DRI::Util::verify_ushort("A"),0,'verify_ushort() 2'); is(Net::DRI::Util::verify_ushort(123),1,'verify_ushort() 3'); is(Net::DRI::Util::verify_ushort(1000000),0,'verify_ushort() 4'); is(Net::DRI::Util::verify_ushort(-1000),0,'verify_ushort() 5'); is(Net::DRI::Util::verify_ubyte(),0,'verify_ubyte() 1'); is(Net::DRI::Util::verify_ubyte("A"),0,'verify_ubyte() 2'); is(Net::DRI::Util::verify_ubyte(123),1,'verify_ubyte() 3'); is(Net::DRI::Util::verify_ubyte(1000),0,'verify_ubyte() 4'); is(Net::DRI::Util::verify_ubyte(-1000),0,'verify_ubyte() 5'); is(Net::DRI::Util::verify_hex(),0,'verify_hex() 1'); is(Net::DRI::Util::verify_hex("G"),0,'verify_hex() 2'); is(Net::DRI::Util::verify_hex("AF65"),1,'verify_hex() 3'); is(Net::DRI::Util::verify_hex("af65"),1,'verify_hex() 4'); is(Net::DRI::Util::verify_int(),0,'verify_int() 1'); is(Net::DRI::Util::verify_int("A"),0,'verify_int() 2'); is(Net::DRI::Util::verify_int(1000),1,'verify_int() 3'); is(Net::DRI::Util::verify_int(-1000),1,'verify_int() 4'); is(Net::DRI::Util::verify_int(-2147483649),0,'verify_int() 5'); is(Net::DRI::Util::verify_int(2147483648),0,'verify_int() 6'); is(Net::DRI::Util::verify_int(-1000,-999),0,'verify_int() 7'); is(Net::DRI::Util::verify_int(-1000,-1001),1,'verify_int() 8'); is(Net::DRI::Util::verify_int(1000,undef,1001),1,'verify_int() 9'); is(Net::DRI::Util::verify_int(1000,undef,999),0,'verify_int() 10'); is(Net::DRI::Util::verify_int(1000,999,1001),1,'verify_int() 11'); is(Net::DRI::Util::verify_int(1000,1002,1004),0,'verify_int() 12'); is(Net::DRI::Util::verify_int(1000,996,998),0,'verify_int() 13'); is(Net::DRI::Util::verify_base64('Z'),0,'verify_base64() 1'); is(Net::DRI::Util::verify_base64('AAAA'),1,'verify_base64() 2'); is(Net::DRI::Util::verify_base64('A AAA'),1,'verify_base64() 3'); is(Net::DRI::Util::verify_base64('A A AA'),1,'verify_base64() 4'); is(Net::DRI::Util::verify_base64('A A A A'),1,'verify_base64() 5'); is(Net::DRI::Util::verify_base64('A A A A '),0,'verify_base64() 6'); is(Net::DRI::Util::verify_base64('BBE='),1,'verify_base64() 7'); is(Net::DRI::Util::verify_base64('BBB='),0,'verify_base64() 8'); is(Net::DRI::Util::verify_base64('B BE='),1,'verify_base64() 9'); is(Net::DRI::Util::verify_base64('B B E='),1,'verify_base64() 10'); is(Net::DRI::Util::verify_base64('B B E ='),1,'verify_base64() 11'); is(Net::DRI::Util::verify_base64('CA=='),1,'verify_base64() 12'); is(Net::DRI::Util::verify_base64('CC=='),0,'verify_base64() 13'); is(Net::DRI::Util::verify_base64('C A=='),1,'verify_base64() 14'); is(Net::DRI::Util::verify_base64('C A =='),1,'verify_base64() 15'); is(Net::DRI::Util::verify_base64('C A = ='),1,'verify_base64() 16'); is(Net::DRI::Util::verify_base64('AAAABBBB'),1,'verify_base64() 17'); is(Net::DRI::Util::verify_base64('A AAABBBB'),1,'verify_base64() 18'); is(Net::DRI::Util::verify_base64('A A AABBBB'),1,'verify_base64() 19'); is(Net::DRI::Util::verify_base64('A A A ABBBB'),1,'verify_base64() 20'); is(Net::DRI::Util::verify_base64('A A A A BBBB'),1,'verify_base64() 21'); is(Net::DRI::Util::verify_base64('FPucA9l+'),1,'verify_base64() 22'); ## From RFC3548 is(Net::DRI::Util::verify_base64('FPucA9k='),1,'verify_base64() 23'); is(Net::DRI::Util::verify_base64('FPucAw=='),1,'verify_base64() 24'); is(Net::DRI::Util::verify_base64('AAAABBBB',4),1,'verify_base64() 25'); is(Net::DRI::Util::verify_base64('AAAABBBB',10),0,'verify_base64() 26'); is(Net::DRI::Util::verify_base64('AAAABBBB',undef,4),0,'verify_base64() 27'); is(Net::DRI::Util::verify_base64('AAAABBBB',undef,10),1,'verify_base64() 28'); is(Net::DRI::Util::verify_base64('AAAABBBB',10,12),0,'verify_base64() 29'); is(Net::DRI::Util::verify_base64('AAAABBBB',4,13),1,'verify_base64() 30'); is(Net::DRI::Util::verify_base64('AAAABBBB',15,20),0,'verify_base64() 31'); is(Net::DRI::Util::xml_is_boolean('0'),1,'xml_is_boolean() 1'); is(Net::DRI::Util::xml_is_boolean('1'),1,'xml_is_boolean() 2'); is(Net::DRI::Util::xml_is_boolean('true'),1,'xml_is_boolean() 3'); is(Net::DRI::Util::xml_is_boolean('false'),1,'xml_is_boolean() 4'); is(Net::DRI::Util::xml_is_boolean('t'),0,'xml_is_boolean() 5'); is(Net::DRI::Util::xml_is_boolean('f'),0,'xml_is_boolean() 6'); is(Net::DRI::Util::xml_is_language('fr'),1,'xml_is_language() 1'); is(Net::DRI::Util::xml_is_language('0fr'),0,'xml_is_language() 2'); is(Net::DRI::Util::xml_is_language('fr-FR'),1,'xml_is_language() 3'); TODO: { local $TODO="tests on hash_merge()"; ok(0); } exit 0; Net-DRI-0.96/t/638switch_epp.t0000755000175000017500000000466511350045715015543 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 3; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context = 50; }; *{'main::is_string'} = \&main::is if $@; our $E1 = ''; our $E2 = ''; our $TRID = 'ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport, $count, $msg) = @_; $R1 = $msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2 ? $R2 : $E1 . '' . r() . $TRID . '' . $E2); } my $dri = Net::DRI->new(10); $dri->{trid_factory} = sub { return 'ABC-12345'; }; $dri->add_registry('SWITCH'); $dri->target('SWITCH')->add_current_profile('p1', 'test=epp', {f_send => \&mysend, f_recv => \&myrecv}); my $rc; my $s; my $d; my ($dh, @c); $R2 = $E1 . 'SWITCH_EPP_Server2008-07-04T16:06:23+02:001.0enurn:ietf:params:xml:ns:domain-1.0urn:ietf:params:xml:ns:contact-1.0urn:ietf:params:xml:ns:host-1.0' . $E2; $rc = $dri->process('session', 'connect', []); is($R1, $E1 . '' . $E2, 'session connect build (hello command)'); is($rc->is_success(), 1, 'session connect is_success'); is_deeply($dri->protocol->server_greeting(), { svID => 'SWITCH_EPP_Server', svDate => '2008-07-04T16:06:23+02:00', version => ['1.0'], lang => ['en'], svcs => [ 'urn:ietf:params:xml:ns:domain-1.0', 'urn:ietf:params:xml:ns:contact-1.0', 'urn:ietf:params:xml:ns:host-1.0' ], dcp => '', }, 'session connect server_greeting parse'); exit 0; sub r { my ($c, $m) = @_; return '' . ($m || 'Command completed successfully') . ''; } Net-DRI-0.96/t/705adamsnames_ws_live.t0000755000175000017500000000146311241155376017227 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Test::More; unless ($ENV{TEST_ADAMSNAMES_WS_LIVE}) { plan skip_all => 'Set $ENV{TEST_ADAMSNAMES_WS_LIVE} if you want harmless *live* tests for AdamsNames'; } else { plan tests => 4; } eval { my $dri=Net::DRI->new(10); $dri->add_registry('AdamsNames'); $dri->target('AdamsNames')->add_current_profile('p1','ws'); my $rc=$dri->domain_info('adamsnames.tc'); is($rc->is_success(),1,'domain_info(adamsnames.tc) is_success'); is($rc->get_data('exist'),1,'domain_info(adamsnames.tc) get_data(exist)'); is($rc->get_data('crDate').'','1998-08-28T00:00:00','domain_info(adamsnames.tc) get_data(crDate)'); is($rc->get_data('roid'),'ada4404.tc','domain_info(adamsnames.tc) get_data(roid)'); }; diag('Caught unexpected exception: '.(ref($@)? $@->as_string() : $@)) if $@; exit 0; Net-DRI-0.96/t/221afnicws_message.t0000755000175000017500000000207411023313434016501 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::Protocol::AFNIC::WS::Message; use Test::More tests=>13; my $n; ## Creation $n=Net::DRI::Protocol::AFNIC::WS::Message->new(); is($n->service(),undef,'new empty service()'); is($n->method(),undef,'new empty method()'); is_deeply($n->params(),[],'new empty params()'); is($n->errcode(),undef,'new empty errcode()'); $n->method('example'); is($n->method(),'example','method() get/set'); $n->method('check_domain'); $n->params(['toto.fr']); ## Parse $n=Net::DRI::Protocol::AFNIC::WS::Message->new(); $r={free=>1}; $n->parse($r); is($n->errcode(),undef,'parse free=1'); is_deeply($n->result(),$r,'parse set result()'); is($n->is_success(),1,'parse is_success'); my $rs=$n->result_status(); is($rs->code(),1000,'result_status code'); $r={free=>0,reason=>1,message=>'whatever'}; $n=Net::DRI::Protocol::AFNIC::WS::Message->new(); $n->parse($r); is($n->errcode(),1,'parse free=0'); is_deeply($n->result(),$r,'parse set result()'); is($n->is_success(),0,'parse is_success'); $rs=$n->result_status(); is($rs->code(),2302,'result_status code'); exit 0; Net-DRI-0.96/t/620lu_epp.t0000755000175000017500000007676211241325474014662 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Net::DRI::Protocol::EPP::Connection; use DateTime; use Test::More tests => 65; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=substr(Net::DRI::Protocol::EPP::Connection->write_message(undef,$msg),4); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('LU'); $dri->target('LU')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); #################################################################################################### ## Registry Messages $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2005-10-03T07:55:13ZD123-DNSLUmydomain.lu89ABCDEF138683892005-10-05T07:37:10ZTest failedBecause!some extra informationABC-123454516E89-DNSLU'; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),1,'message get_info last_id 1'); is($dri->get_info('last_id','message','session'),1,'message get_info last_id 2'); is($dri->get_info('id','message',1),1,'message get_info id'); is(''.$dri->get_info('qdate','message',1),'2005-10-03T07:55:13','message get_info qdate'); is($dri->get_info('lang','message',1),'en','message get_info lang'); is($dri->get_info('type','message',1),1234,'message get_info type'); is($dri->get_info('roid','message',1),'D123-DNSLU','message get_info roid'); is($dri->get_info('object','message',1),'mydomain.lu','message get_info object'); is($dri->get_info('clTRID','message',1),'89ABCDEF','message get_info clTRID'); is($dri->get_info('svTRID','message',1),'13868389','message get_info svTRID'); is(''.$dri->get_info('exDate','message',1),'2005-10-05T07:37:10','message get_info exDate'); is_deeply($dri->get_info('ns','message',1),{'ns.domain.lu'=>'Test failed'},'message get_info ns'); is($dri->get_info('reason','message',1),'Because!','message get_info reason'); is_deeply($dri->get_info('extra','message',1),{'field'=>'some extra information'},'message get_info extra'); ################################################################################################### ## Contact commands $R2=$E1.''.r().'H0008H3-DNSLUFondation RESTENA6, rue Coudenhove -KalergiLuxembourg1359LUdummy@dns.lurestena-idrestena-id2005-10-05T07:37:10Zrestena-id2005-11-17T12:59:11Zholder_org'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('H0008'); $rc=$dri->contact_info($co); is($rc->is_success(),1,'contact_info is_success'); is($dri->get_info('action'),'info','contact_info get_info(action)'); is($dri->get_info('exist'),1,'contact_info get_info(exist)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::Contact','contact_info get_info(self)'); is($co->type(),'holder_org','contact->type()'); is_deeply($co->disclose(),{name_loc=>1,addr_loc=>0},'contact->disclose()'); $R2=$E1.''.r().'th1domainTest1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('H100'); $co->name('Fondation RESTENA'); $co->street(['6, rue Coudenhove -Kalergi']); $co->city('Luxembourg'); $co->pc(1359); $co->cc('LU'); $co->email('dummy@dnslu.lu'); $co->auth({pw=>'dummy'}); $co->type('holder_org'); $co->disclose({name_loc=>1,addr_loc=>0}); $rc=$dri->contact_create($co); is_string($R1,$E1.'H100Fondation RESTENA6, rue Coudenhove -KalergiLuxembourg1359LUdummy@dnslu.ludummyholder_orgABC-12345'.$E2,'contact_create build 1'); $R2=$E1.''.r().'th1domainTest1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('C100'); $co->name('Bruno Prémont'); $co->org('Fondation RESTENA'); $co->street(['6, rue Coudenhove -Kalergi']); $co->city('Luxembourg'); $co->pc(1359); $co->cc('LU'); $co->voice('+352.42440928'); $co->fax('+352.42440928'); $co->email('bruno.premont@restena.lu'); $co->auth({pw=>'dummy'}); $co->type('contact'); $co->disclose({name_loc=>1,addr_loc=>0,voice=>0,email=>0}); $rc=$dri->contact_create($co); is_string($R1,$E1.'C100Bruno PrémontFondation RESTENA6, rue Coudenhove -KalergiLuxembourg1359LU+352.42440928+352.42440928bruno.premont@restena.ludummycontactABC-12345'.$E2,'contact_create build 2'); $R2=''; $co=$dri->local_object('contact')->srid('H100'); $toc=$dri->local_object('changes'); my $co2=$dri->local_object('contact'); $co2->name('Gilles Massen'); $co2->street(['Building A','Department X','rue de Luxembourg 10']); $co2->city('Luxembourg'); $co2->pc('1359'); $co2->cc('LU'); $toc->set('info',$co2); $toc->add('disclose',{name_loc=>0,addr_loc=>1}); $toc->del('disclose',{name_loc=>1,addr_loc=>1}); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'H100Gilles MassenBuilding ADepartment Xrue de Luxembourg 10Luxembourg1359LUABC-12345'.$E2,'contact_update build 1'); ##################################################################################### ## Domain commands $R2=$E1.''.r().'lycee.luD0-DNSLUH100C100C100ns.restena.luns1.xn--lyce-dpa.luns6.xn--lyce-dpa.lurestena-idrestena-id2005-10-03T17:22:31Zrestena-id2006-06-27T11:10:46Z2006-10-03T17:22:31Zlycée.luserverTradeProhibitedrestena-id2005-10-03T11:37:22Z2006-07-03T11:12:12Z2006-07-21T17:37:54Z'.$TRID.''.$E2; $rc=$dri->domain_info('lycee.lu'); is_deeply([$dri->get_info('status')->list_status()],['inactive','pendingCreate','serverTradeProhibited'],'domain_info get_info(status)'); is($dri->get_info('crReqID'),'restena-id','domain_info get_info(crReqID)'); is(''.$dri->get_info('crReqDate'),'2005-10-03T11:37:22','domain_info get_info(crReqDate)'); is(''.$dri->get_info('delReqDate'),'2006-07-03T11:12:12','domain_info get_info(delReqDate)'); is(''.$dri->get_info('delDate'),'2006-07-21T17:37:54','domain_info get_info(delDate)'); ## (we do not handle idn for now) $R2=''; my $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('H_rest'),'registrant'); $cs->set($dri->local_object('contact')->srid('CA_rest'),'admin'); $cs->set($dri->local_object('contact')->srid('CT_rest'),'tech'); $rc=$dri->domain_create('lycee.lu',{pure_create=>1,ns=>$dri->local_object('hosts')->set(['ns1.restena.lu'],['ns2.restena.lu']),contact=>$cs,auth=>{pw=>'dummy'},status=>$dri->local_object('status')->add('inactive','clientTradeProhibited')}); is_string($R1,$E1.'lycee.luns1.restena.luns2.restena.luH_restCA_restCT_restdummyABC-12345'.$E2,'domain_create build'); $R2=''; my $toc=$dri->local_object('changes'); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('C100'),'admin'); $cs->set($dri->local_object('contact')->srid('C100'),'tech'); $toc->add('contact',$cs); $toc->del('contact',$cs); $toc->add('ns',$dri->local_object('hosts')->set(['ns1.restena.lu'],['ns2.restena.lu'],['ns3.restena.lu'])); $toc->add('status',$dri->local_object('status')->add('clientUpdateProhibited','clientTradeProhibited')); $toc->del('ns',$dri->local_object('hosts')->set(['ns1.restena.lu'],['ns2.restena.lu'],['ns3.restena.lu'])); $toc->del('status',$dri->local_object('status')->add('clientDeleteProhibited','clientTransferProhibited2')); ## last status changed because otherwise in core $rc=$dri->domain_update('lycee.lu',$toc); is_string($R1,$E1.'lycee.luns1.restena.luns2.restena.luns3.restena.luC100C100ns1.restena.luns2.restena.luns3.restena.luC100C100ABC-12345'.$E2,'domain_update build'); $R2=''; $rc=$dri->domain_delete('domain.lu',{delDate=>'immediate'}); is_string($R1,$E1.'domain.luimmediateABC-12345'.$E2,'domain_delete immediate'); $R2=''; $rc=$dri->domain_delete('domain.lu',{delDate=>DateTime->new(year=>2005,month=>11,day=>8)}); is_string($R1,$E1.'domain.lusetDate2005-11-08T00:00:00ZABC-12345'.$E2,'domain_delete setDate'); $R2=''; $rc=$dri->domain_delete('domain.lu',{delDate=>'cancel'}); is_string($R1,$E1.'domain.lucancelABC-12345'.$E2,'domain_delete cancel'); ## clTRID seems wrong in example $R2=''; $rc=$dri->domain_restore('domain.lu'); is_string($R1,$E1.'domain.lu'.$E2,'domain_restore'); ## example seems wrong: wrong namespace (dnslu instead of domain) in non extension part $R2=$E1.''.r(1001,'Command completed successfully ; action pending').'cafe.lupendingrestena-id2004-09-08T11:39:41Z2004-09-15T11:39:41Z2004-09-18T10:00:00Z'.$TRID.''.$E2; $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('H100'),'registrant'); $cs->set($dri->local_object('contact')->srid('C100'),'admin'); $cs->set($dri->local_object('contact')->srid('C100'),'tech'); $rc=$dri->domain_transfer_start('cafe.lu',{ns=>$dri->local_object('hosts')->set(['ns1.restena.lu'],['ns2.restena.lu'],['ns3.restena.lu']),contact=>$cs,status=>$dri->local_object('status')->no('publish'),trDate=>DateTime->new(year=>2004,month=>6,day=>30)}); is_string($R1,$E1.'cafe.luns1.restena.luns2.restena.luns3.restena.luH100C100C1002004-06-30ABC-12345'.$E2,'domain_transfer_request build'); is(''.$dri->get_info('trDate'),'2004-09-18T10:00:00','domain_transfer_request get_info(trDate)'); $R2=''; $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('H100'),'registrant'); $cs->set($dri->local_object('contact')->srid('C100'),'admin'); $cs->set($dri->local_object('contact')->srid('C100'),'tech'); $rc=$dri->domain_trade_start('cafe.lu',{ns=>$dri->local_object('hosts')->set(['ns1.restena.lu'],['ns2.restena.lu'],['ns3.restena.lu']),contact=>$cs,status=>$dri->local_object('status')->no('publish'),trDate=>DateTime->new(year=>2004,month=>6,day=>30)}); is_string($R1,$E1.'cafe.luns1.restena.luns2.restena.luns3.restena.luH100C100C1002004-06-30'.$E2,'domain_trade_request build'); $R2=$E1.''.r().'cafe.lupendingrestena-id2004-09-08T11:39:41Z2004-09-15T11:39:41Z2004-09-18T10:00:00Z'.$TRID.''.$E2; $rc=$dri->domain_trade_query('cafe.lu'); is_string($R1,$E1.'cafe.lu'.$E2,'domain_trade_query build'); is($dri->get_info('trStatus'),'pending','domain_trade_query get_info(trStatus)'); is($dri->get_info('reID'),'restena-id','domain_trade_query get_info(reID)'); is(''.$dri->get_info('reDate'),'2004-09-08T11:39:41','domain_trade_query get_info(reDate)'); is(''.$dri->get_info('acDate'),'2004-09-15T11:39:41','domain_trade_query get_info(acDate)'); is(''.$dri->get_info('trDate'),'2004-09-18T10:00:00','domain_trade_query get_info(trDate)'); $R2=''; $rc=$dri->domain_trade_stop('domain.lu'); is_string($R1,$E1.'domain.lu'.$E2,'domain_trade_cancel build'); $R2=''; $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('H100'),'registrant'); $cs->set($dri->local_object('contact')->srid('C100'),'admin'); $cs->set($dri->local_object('contact')->srid('C100'),'tech'); $rc=$dri->domain_transfer_trade_start('cafe.lu',{ns=>$dri->local_object('hosts')->set(['ns1.restena.lu'],['ns2.restena.lu'],['ns3.restena.lu']),contact=>$cs,status=>$dri->local_object('status')->no('publish'),trDate=>DateTime->new(year=>2004,month=>6,day=>30)}); is_string($R1,$E1.'cafe.luns1.restena.luns2.restena.luns3.restena.luH100C100C1002004-06-30'.$E2,'domain_transfer_trade_request build'); $R2=$E1.''.r().'cafe.lupendingrestena-id2004-09-08T11:39:41Z2004-09-15T11:39:41Z2004-09-18T10:00:00Z'.$TRID.''.$E2; $rc=$dri->domain_transfer_trade_query('cafe.lu'); is_string($R1,$E1.'cafe.lu'.$E2,'domain_transfer_trade_query build'); is($dri->get_info('trStatus'),'pending','domain_transfer_trade_query get_info(trStatus)'); is($dri->get_info('reID'),'restena-id','domain_transfer_trade_query get_info(reID)'); is(''.$dri->get_info('reDate'),'2004-09-08T11:39:41','domain_transfer_trade_query get_info(reDate)'); is(''.$dri->get_info('acDate'),'2004-09-15T11:39:41','domain_transfer_trade_query get_info(acDate)'); is(''.$dri->get_info('trDate'),'2004-09-18T10:00:00','domain_transfer_trade_query get_info(trDate)'); $R2=''; $rc=$dri->domain_transfer_trade_stop('domain.lu'); is_string($R1,$E1.'domain.lu'.$E2,'domain_transfer_trade_cancel build'); $R2=''; $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('H100'),'registrant'); $cs->set($dri->local_object('contact')->srid('C100'),'admin'); $cs->set($dri->local_object('contact')->srid('C100'),'tech'); $rc=$dri->domain_transfer_restore_start('cafe.lu',{ns=>$dri->local_object('hosts')->set(['ns1.restena.lu'],['ns2.restena.lu'],['ns3.restena.lu']),contact=>$cs,status=>$dri->local_object('status')->no('publish'),trDate=>DateTime->new(year=>2004,month=>6,day=>30)}); is_string($R1,$E1.'cafe.luns1.restena.luns2.restena.luns3.restena.luH100C100C1002004-06-30'.$E2,'domain_transfer_restore_request build'); $R2=$E1.''.r().'cafe.lupendingrestena-id2004-09-08T11:39:41Z2004-09-15T11:39:41Z2004-09-18T10:00:00Z'.$TRID.''.$E2; $rc=$dri->domain_transfer_restore_query('cafe.lu'); is_string($R1,$E1.'cafe.lu'.$E2,'domain_transfer_restore_query build'); is($dri->get_info('trStatus'),'pending','domain_transfer_restore_query get_info(trStatus)'); is($dri->get_info('reID'),'restena-id','domain_transfer_restore_query get_info(reID)'); is(''.$dri->get_info('reDate'),'2004-09-08T11:39:41','domain_transfer_restore_query get_info(reDate)'); is(''.$dri->get_info('acDate'),'2004-09-15T11:39:41','domain_transfer_restore_query get_info(acDate)'); is(''.$dri->get_info('trDate'),'2004-09-18T10:00:00','domain_transfer_restore_query get_info(trDate)'); $R2=''; $rc=$dri->domain_transfer_restore_stop('domain.lu'); is_string($R1,$E1.'domain.lu'.$E2,'domain_transfer_restore_cancel build'); ## Registry uses an extra status « inactive » $R2=''; $toc=$dri->local_object('changes'); $toc->del('status',$dri->local_object('status')->no('active')); $rc=$dri->domain_update('registryviolatingepp.lu',$toc); is_string($R1,$E1.'registryviolatingepp.luABC-12345','domain_update with status inactive (registry specific not in EPP)'); ## From http://www.bsdprojects.net/cgi-bin/archzoom.cgi/tonnerre@bsdprojects.net--2006/Net-DRI--tonnerre--0.81.1--patch-34/t/999epp_bugs.t.diff?diff $R2 = $E1.'[1301] Command completed successfully; ack to dequeue2008-01-24T12:41:03.000ZD41231-DNSLUblafasel.luDNSLU-4123-1342324575404832CAFEBABE:002A-DNSLU2009-01-24T12:41:03.000ZNameserver test succeeded'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($rc->is_success(),1,'message polled successfully'); is($dri->get_info('last_id'),104574, 'message get_info last_id'); is($dri->get_info('type','message', 104574),13,'message get_info type'); is($dri->get_info('roid','message', 104574),'D41231-DNSLU','message get_info roid'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/615mobi_epp.t0000755000175000017500000001414211241325410015142 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 3; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('MOBI'); $dri->target('MOBI')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my ($rc,$s,$d,$dh,@c,$co); #################################################################################################### ## Domains $R2=''; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $cs->set($c2,'billing'); $rc=$dri->domain_create('whatever.mobi',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns1.example.net']),contact=>$cs,auth=>{pw=>'2fooBAR'},maintainer_url=>'http://www.afilias.info'}); is_string($R1,$E1.'whatever.mobi2ns1.example.comns1.example.netjd1234sh8013sh8013sh80132fooBARhttp://www.afilias.infoABC-12345'.$E2,'domain_create build'); $R2=''; $toc=$dri->local_object('changes'); $toc->add('ns',$dri->local_object('hosts')->set('ns2.example.com')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('mak21'),'tech'); $toc->add('contact',$cs); $toc->add('status',$dri->local_object('status')->no('publish','Payment overdue.')); $toc->del('ns',$dri->local_object('hosts')->set('ns1.example.com')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('sh8013'),'tech'); $toc->del('contact',$cs); $toc->del('status',$dri->local_object('status')->no('update')); $toc->set('registrant',$dri->local_object('contact')->srid('sh8013')); $toc->set('auth',{pw=>'2BARfoo'}); $toc->set('maintainer_url','http://www.afilias.info'); $rc=$dri->domain_update('whatever.mobi',$toc); is_string($R1,$E1.'whatever.mobins2.example.commak21Payment overdue.ns1.example.comsh8013sh80132BARfoohttp://www.afilias.infoABC-12345'.$E2,'domain_update build'); $R2=$E1.''.r().'whatever.mobiBARCA-REPjd1234sh8013sh8013sh8013ns1.example.comns1.example.netns1.barca.catns2.barca.catClientXClientY2006-04-03T22:00:00.0ZClientX2006-12-03T09:00:00.0Z2007-04-03T22:00:00.0Z2006-04-08T09:00:00.0Z2fooBARhttp://www.afilias.infoABC-1234554322-XYZ'.$E2; $rc=$dri->domain_info('whatever.mobi',{auth=>{pw=>'2fooBAR'}}); is($dri->get_info('maintainer_url'),'http://www.afilias.info','domain_info parse'); #################################################################################################### exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/618vnds_epp_pollrgp.t0000755000175000017500000000536311241325474016747 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 13; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2004-05-03T20:06:17.0002ZRestore Request Pendingfoobar.com2004-05-03T20:06:17.0002Z2004-05-03T20:06:17.0002Z'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info last_id'); is(''.$dri->get_info('qdate','message',12345),'2004-05-03T20:06:17','message get_info qdate'); is($dri->get_info('content','message',12345),'Restore Request Pending','message get_info msg'); is($dri->get_info('lang','message',12345),'en','message get_info lang'); is($dri->get_info('object_type','message',12345),'domain','message get_info object_type'); is($dri->get_info('action','message',12345),'rgp_notification','message get_info rgp_notification'); is($dri->get_info('name','message',12345),'foobar.com','message get_info name'); $s=$dri->get_info('status','message',12345); isa_ok($s,'Net::DRI::Data::StatusList','message get_info status'); is_deeply([$s->list_status()],['pendingDelete'],'message get_info status list'); is($s->is_active(),0,'message get_info status is_active'); is($s->is_pending(),1,'message get_info status is_pending'); is(''.$dri->get_info('req_date','message',12345),'2004-05-03T20:06:17','message get_info req_date'); is(''.$dri->get_info('report_due_date','message',12345),'2004-05-03T20:06:17','message get_info report_due_date'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/609us_epp.t0000755000175000017500000001405411241325407014656 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 5; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new({cache_ttl=>10,trid_factory => sub { return 'coricopat-9978-1002'}}); $dri->add_registry('US'); $dri->target('US')->add_current_profile('p1','test=Net::DRI::Protocol::EPP::Extensions::US',{f_send=>\&mysend,f_recv=>\&myrecv}); ######################################################################################################### ## Examples taken from draft-liu-epp-usTLD-00 + updates to current EPP my $c=$dri->local_object('contact'); $c->srid('abcde')->name('abc')->org('abc.org')->street(['123 d street'])->city('reston')->pc(20194)->sp('VA')->cc('US')->fax('+1.2345678901x1234')->email('xxx@yyy.com'); $c->auth({pw => 123456}); $c->application_purpose('P1'); $c->nexus_category('C31/DE'); my $rc=$dri->contact_create($c); is_string($R1,$E1.'abcdeabcabc.org123 d streetrestonVA20194USabcabc.org123 d streetrestonVA20194US+1.2345678901xxx@yyy.com123456AppPurpose=P1 NexusCategory=C31/DEcoricopat-9978-1002'.$E2,'contact_create with nexus info build'); $R2=$E1.''.r().'abcdeABCDE-USabcabc.org123 d streetrestonVA20194US+1.2345678901xxx@yyy.comClientYClientX2002-04-03T22:00:00.0ZClientX2002-12-03T09:00:00.0Z2000-04-08T09:00:00.0Z123456AppPurpose=P1 NexusCategory=C11coricopat-9978-100354322-XYZ'.$E2; $co=$dri->local_object('contact')->srid('abcde')->auth({pw=>'123456'}); $rc=$dri->contact_info($co); $c=$dri->get_info('self','contact','abcde'); is($c->application_purpose(),'P1','contact_info parse AppPurpose'); is($c->nexus_category(),'C11','contact_info parse NexusCategory'); $R2=''; my $co=$dri->local_object('contact')->srid('abc'); my $toc=$dri->local_object('changes'); my $co2=$dri->local_object('contact'); $co2->voice('+1.2345678910'); $co2->application_purpose('P3'); $co2->nexus_category('C11'); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'abc+1.2345678910AppPurpose=P3 NexusCategory=C11coricopat-9978-1002'.$E2,'contact_update build 1'); $co2=$dri->local_object('contact'); $co2->application_purpose(''); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'abcAppPurpose=coricopat-9978-1002'.$E2,'contact_update build 2'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/701ovh_ws_live.t0000755000175000017500000000271211137716740015706 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Test::More; unless ($ENV{TEST_OVH_WS_LIVE_CLIENTID} && $ENV{TEST_OVH_WS_LIVE_CLIENTPASS}) { plan skip_all => 'Set $ENV{TEST_OVH_WS_LIVE_CLIENTID} and $ENV{TEST_OVH_WS_LIVE_CLIENTPASS} if you want (normally harmless) *live* tests for OVH'; } else { plan tests => 4; } my $dri=Net::DRI->new(10); $dri->add_registry('OVH'); $dri->target('OVH')->add_current_profile('p1','ws',{client_login=>$ENV{TEST_OVH_WS_LIVE_CLIENTID},client_password=>$ENV{TEST_OVH_WS_LIVE_CLIENTPASS}}); eval { my $rc=$dri->account_list_domains(); diag('Got session ID '.$dri->transport()->session_data()->{id}); is($rc->is_success(),1,'account_list_domains() is_success') or diag(sprintf('Code=%s Native_Code=%d Message=%s',$rc->code(),$rc->native_code(),$rc->message())); my $rd=$dri->get_info('list','account','domains'); is(ref($rd),'ARRAY','get_info(list,account,domains)'); diag('Successfully retrieved list of '.scalar(@$rd).' domain names: '.join(' ',@$rd)); my $rd2=$dri->get_info('list'); is_deeply($rd2,$rd,'get_info(list,account,domains) and get_info(list) give the same results'); $rc=$dri->domain_info($rd->[0]); is($rc->is_success(),1,'domain_info() is_success') or diag(sprintf('Code=%s Native_Code=%d Message=%s',$rc->code(),$rc->native_code(),$rc->message())); my @i=$dri->get_info_keys(); diag('Successfully got information about: '.join(' ',@i)); }; diag('Caught unexpected exception: '.(ref($@)? $@->as_string() : $@)) if $@; exit 0; Net-DRI-0.96/t/642cira_epp.t0000755000175000017500000002512011352527737015153 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 17; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our ($R1,$R2); sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1;} sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('CIRA'); $dri->target('CIRA')->add_current_profile('p1','test=Net::DRI::Protocol::EPP::Extensions::CIRA',{f_send=>\&mysend,f_recv=>\&myrecv}); print $@->as_string() if $@; my ($rc,$co,$h,$toc); #################################################################################################### ## Notifications $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2010-01-20T16:58:17.0Zomain example.ca has been transferred to another Registrar3027example.ca'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($rc->get_data('message',1901,'msg_id'),'3027','notification parsing msg_id'); is($rc->get_data('message',1901,'domain_name'),'example.ca','notification parsing domain_name'); #################################################################################################### ## Contacts $R2=$E1.''.r().'11aabbroid1Contact Middle-name LastName123 Everywhere StreetOttawaONK1R7S8CAcontact1@domain.ca1234562010-01-07T18:18:53.0ZenCCTY2.02010-01-26T18:18:53.0Z192.168.45.59PRIVATE>'.$TRID.''.$E2; $rc=$dri->contact_info($dri->local_object('contact')->srid('11aabb')); $co=$rc->get_data('contact','11aabb','self'); is($co->lang(),'en','contact_info lang'); is($co->legal_form(),'CCT','contact_info legal_form'); is($co->is_individual(),1,'contact_info is_individual'); is_deeply($co->agreement(),{signed=>1,version=>'2.0',timestamp=>'2010-01-26T18:18:53'},'contact_info agreement'); is($co->ip_address(),'192.168.45.59','contact_info ip_address'); is($co->whois_display(),'PRIVATE','contact_info whois_display'); $R2=''; $co=$dri->local_object('contact'); $co->srid('sh8021'); $co->name('John Doe'); $co->org('Example Inc.'); $co->street(['350 Sparks Street','Suite 306']); $co->city('Ottawa'); $co->sp('ON'); $co->pc('K1R 7S8'); $co->cc('CA'); $co->voice('+1.6132375335x1234'); $co->fax('+1.6132370534'); $co->email('jdoe@cira20.ca'); $co->lang('en'); $co->ip_address('192.118.22.26'); $co->legal_form('CCT'); $co->agreement({version => '1.9', signed => 1}); $co->reseller_id('12345'); $rc=$dri->contact_create($co); is_string($R1,$E1.'sh8021John DoeExample Inc.350 Sparks StreetSuite 306OttawaONK1R 7S8CA+1.6132375335+1.6132370534jdoe@cira20.caen192.118.22.26CCT1.9Y12345ABC-12345'.$E2,'contact_create build'); $R2=''; $co=$dri->local_object('contact')->srid('flaguse19'); $toc=$dri->local_object('changes'); $toc->add('status',$dri->local_object('status')->no('delete')); my $co2=$dri->local_object('contact'); $co2->name('Updated Name Field'); $co2->org(''); $co2->street(['32 Wish Bone Avenue']); $co2->city('Ottawa'); $co2->sp('ON'); $co2->pc('K4M 1N6'); $co2->voice('+1.6134952324'); $co2->fax('+1.6134952323'); $co2->legal_form('CCT'); $co2->lang('fr'); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'flaguse19Updated Name Field32 Wish Bone AvenueOttawaONK4M 1N6+1.6134952324+1.6134952323CCTfrABC-12345'.$E2,'contact_update build'); #################################################################################################### ## Domain commands $R2=$E1.''.r().'pc-case3.caCIRA-lifecycle-00122allrant003admin003tech003automatedRARsprint3automatedRARsprint32009-12-08T16:25:01.0Z2010-12-08T16:25:01.0Zpassword2pending delete2009-12-16T16:29:05.0Z'.$TRID.''.$E2; $rc=$dri->domain_info('pc-case3.ca',{auth=>{pw=>'password2'}}); is($rc->get_data('stage_of_life'),'pending delete','domain_info get_data(stage_of_life)'); is(''.$rc->get_data('stage_of_life_end'),'2009-12-16T16:29:05','domain_info get_data(stage_of_life_end)'); my $cs=$dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('transferrant'),'registrant'); $cs->add($dri->local_object('contact')->srid('transferadmin'),'admin'); $cs->add($dri->local_object('contact')->srid('transfertech1'),'tech'); $rc=$dri->domain_transfer_start('onetech.ca',{auth=>{pw=>'password'},contact=>$cs}); is_string($R1,$E1.'onetech.capasswordtransferranttransferadmintransfertech1ABC-12345'.$E2,'domain_transfer_request build'); #################################################################################################### ## Agreement $R2=$E1.''.r().'en2.0REGISTRANT AGREEMENT...complete agreement here'.$TRID.''.$E2; $rc=$dri->agreement_get('en'); is_string($R1,$E1.'get CIRA latest agreementen'.$E2,'agreement_get build'); is($rc->get_data('lang'),'en','agreement_get get_data(lang)'); is($rc->get_data('version'),'2.0','agreement_get get_data(version)'); is($rc->get_data('content'),'REGISTRANT AGREEMENT...complete agreement here','agreement_get get_data(content)'); exit 0; Net-DRI-0.96/t/635br_epp.t0000755000175000017500000007171411241325755014645 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use Test::More tests => 75; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our ($R1,$R2); sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1;} sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('BR'); $dri->target('BR')->add_current_profile('p1','test=Net::DRI::Protocol::EPP::Extensions::BR',{f_send=>\&mysend,f_recv=>\&myrecv}); print $@->as_string() if $@; my ($rc,$s,$d,$dh,@c,$co); ## Domain commands $R2=$E1.''.r().'e-xample.net.brIn useexample.org.brexample.com.brexample.ind.bre-xample.net.brexample.net.br043.828.151/0001-45example.org.br043.828.151/0001-45example.com.br123456example.ind.br'.$TRID.''.$E2; $rc=$dri->domain_check_multi('e-xample.net.br','example.org.br','example.com.br','example.ind.br',{orgid => '005.506.560/0001-36'}); is_string($R1,$E1.'e-xample.net.brexample.org.brexample.com.brexample.ind.br005.506.560/0001-36ABC-12345'.$E2,'domain_check build'); is($rc->is_success(),1,'domain_check_multi is_success'); is($dri->get_info('exist','domain','e-xample.net.br'),1,'domain_check_multi get_info(exist) 1/4'); is($dri->get_info('exist','domain','example.org.br'),1,'domain_check_multi get_info(exist) 2/4'); is($dri->get_info('exist','domain','example.com.br'),0,'domain_check_multi get_info(exist) 3/4'); is($dri->get_info('exist','domain','example.ind.br'),0,'domain_check_multi get_info(exist) 4/4'); is($dri->get_info('equivalent_name','domain','e-xample.net.br'),'example.net.br','domain_check_multi get_info(equivalent_name)'); is($dri->get_info('orgid','domain','e-xample.net.br'),'043.828.151/0001-45','domain_check_multi get_info(orgid) 1'); is($dri->get_info('orgid','domain','example.org.br'),'043.828.151/0001-45','domain_check_multi get_info(orgid) 2'); is($dri->get_info('has_concurrent','domain','example.com.br'),1,'domain_check_multi get_info(has_concurrent) 1'); is($dri->get_info('in_release_process','domain','example.com.br'),0,'domain_check_multi get_info(in_release_process) 1'); is_deeply($dri->get_info('ticket','domain','example.com.br'),[123456],'domain_check_multi get_info(ticket)'); is($dri->get_info('has_concurrent','domain','example.ind.br'),0,'domain_check_multi get_info(has_concurrent) 2'); is($dri->get_info('in_release_process','domain','example.ind.br'),1,'domain_check_multi get_info(in_release_process) 2'); $R2=$E1.''.r().'example.com.brEXAMPLE1-REPfanfanfanns1.example.com.br192.0.2.1ns1.example.net.brClientXClientX2006-01-30T22:00:00.0ZClientX2006-01-31T09:00:00.0Z123456005.506.560/0001-36ns1.example.com.br2006-02-13T22:00:00.0ZCNPJ2006-03-01T22:00:00.0ZCadastro Nacional da Pessoa Juridica2006-02-01T22:00:00.0Z123451123455'.$TRID.''.$E2; $rc=$dri->domain_info('example.com.br',{ticket => 123456}); is_string($R1,$E1.'example.com.br123456ABC-12345'.$E2,'domain_info build'); is($rc->is_success(),1,'domain_info 1 is_success'); is($dri->get_info('ticket'),123456,'domain_info 1 get_info(ticket)'); is($dri->get_info('orgid'),'005.506.560/0001-36','domain_info 1 get_info(orgid)'); is_deeply($dri->get_info('release_process'),{flag1=>1},'domain_info 1 get_info(release_process)'); my $p=$dri->get_info('pending'); is_deeply($p->{dns},[{status=>'queryTimeOut',hostname=>'ns1.example.com.br',limit=>'2006-02-13T22:00:00'}],'domain_info 1 get_info(pending) dns'); is_deeply($p->{doc},[{status=>'notReceived',type=>'CNPJ',limit=>'2006-03-01T22:00:00',description=>'Cadastro Nacional da Pessoa Juridica',lang=>'pt'}],'domain_info 1 get_info(pending) doc'); is_deeply($p->{release},{status => 'waiting', limit => '2006-02-01T22:00:00'},'domain_info 1 get_info(pending) release'); is_deeply($dri->get_info('ticket_concurrent'),[123451,123455],'domain_info 1 get_info(ticket_concurrent)'); $dri->cache_clear(); $R2=$E1.''.r().'example.com.brEXAMPLE1-REPfanfanfanns1.example.com.br192.0.2.1ns1.example.net.brClientXClientX2006-02-03T12:00:00.0ZClientX2006-02-03T12:00:00.0Z005.506.560/0001-36billing'.$TRID.''.$E2; $rc=$dri->domain_info('example.com.br',{ticket => 123456}); is($rc->is_success(),1,'domain_info 2 is_success'); is($dri->get_info('orgid'),'005.506.560/0001-36','domain_info 2 get_info(orgid)'); is_deeply($dri->get_info('publication'),{flag=>'onHold',onhold_reason=>['billing']},'domain_info 2 get_info(publication)'); is($dri->get_info('auto_renew'),1,'domain_info 2 get_info(auto_renew)'); $R2=$E1.''.r().'example.com.br2006-01-30T22:00:00.0Z123456ns1.example.com.br2006-02-13T22:00:00.0ZCNPJ2006-03-01T22:00:00.0ZCadastro Nacional da Pessoa Juridica123451123455'.$TRID.''.$E2; $cs=$dri->local_object('contactset'); $co=$dri->local_object('contact')->srid('fan'); $cs->set($co,'admin'); $cs->set($co,'tech'); $cs->set($co,'billing'); $rc=$dri->domain_create('example.com.br',{pure_create=>1,ns=>$dri->local_object('hosts')->add('ns1.example.com.br',['92.0.2.1'])->add('ns1.example.net.br'),contact=>$cs,auth=>{pw=>'2fooBAR'},orgid=>'005.506.560/0001-36',release=>{flag1=>1},auto_renew=>0}); is_string($R1,$E1.'example.com.brns1.example.com.br92.0.2.1ns1.example.net.brfanfanfan2fooBAR005.506.560/0001-36ABC-12345'.$E2,'domain_create build'); is($dri->get_info('ticket'),123456,'domain_create get_info(ticket)'); $p=$dri->get_info('pending'); is_deeply($p->{dns},[{status=>'queryTimeOut',hostname=>'ns1.example.com.br',limit=>'2006-02-13T22:00:00'}],'domain_create get_info(pending) dns'); is_deeply($p->{doc},[{status=>'notReceived',type=>'CNPJ',limit=>'2006-03-01T22:00:00',description=>'Cadastro Nacional da Pessoa Juridica',lang=>'pt'}],'domain_create get_info(pending) doc'); is_deeply($dri->get_info('ticket_concurrent'),[123451,123455],'domain_create get_info(ticket_concurrent)'); $dri->cache_clear(); $R2=$E1.''.r().'example.com.br2007-04-03T00:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_renew('example.com.br',{current_expiration => DateTime->new(year=>2005,month=>4,day=>9)}); is_deeply($dri->get_info('publication'),{flag=>'published'},'domain_renew get_info(publication)'); $R2=$E1.''.r().'123456CNPJ2006-03-01T22:00:00.0ZCadastro Nacional da Pessoa Juridica'.$TRID.''.$E2; my $toc=$dri->local_object('changes'); $cs=$dri->local_object('contactset'); $co=$dri->local_object('contact'); $co->srid('hkk'); $cs->set($co,'tech'); $toc->add('contact',$cs); $cs=$dri->local_object('contactset'); $co=$dri->local_object('contact'); $co->srid('fan'); $cs->set($co,'tech'); $toc->del('contact',$cs); $dh=$dri->local_object('hosts'); $dh->add('ns2.example.com'); $toc->add('ns',$dh); $dh=$dri->local_object('hosts'); $dh->add('ns1.example.com.br'); $toc->del('ns',$dh); $toc->set('ticket',123456); $toc->set('release',{flag2=>1}); $toc->set('auto_renew',1); $rc=$dri->domain_update('example.com.br',$toc); is_string($R1,$E1.'example.com.brns2.example.comhkkns1.example.com.brfan123456ABC-12345'.$E2,'domain_update_build'); is($rc->is_success(),1,'domain_update is_success'); $p=$dri->get_info('pending'); is_deeply($p->{doc},[{status=>'notReceived',type=>'CNPJ',limit=>'2006-03-01T22:00:00',description=>'Cadastro Nacional da Pessoa Juridica',lang=>'pt'}],'domain_update get_info(pending) doc'); $dri->cache_clear(); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'1999-04-04T22:01:00.0ZPending action completed successfully.example.com.brABC-1234554321-XYZ2006-02-13T22:30:00.0Z123456Nao obtivemos uma resposta adequada durante o prazo fixado do servidor de DNS (ns1.example.com.br) para o presente dominio.'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info last_id'); is($dri->get_info('object_type','message','12345'),'domain','message get_info object_type'); is($dri->get_info('object_id','message','12345'),'example.com.br','message get_info id'); ## Information retrieved is available through the message ID we got back... is($dri->get_info('ticket','message','12345'),123456,'message_retrieve message get_info(ticket)'); is($dri->get_info('reason','message','12345'),'Nao obtivemos uma resposta adequada durante o prazo fixado do servidor de DNS (ns1.example.com.br) para o presente dominio.','message_retrieve message get_info(reason)'); is($dri->get_info('reason_lang','message','12345'),'pt','message_retrieve message get_info(reason_lang)'); ## ... and also through the object queried is($dri->get_info('ticket','domain','example.com.br'),123456,'message_retrieve domain get_info(ticket)'); is($dri->get_info('reason','domain','example.com.br'),'Nao obtivemos uma resposta adequada durante o prazo fixado do servidor de DNS (ns1.example.com.br) para o presente dominio.','message_retrieve domain get_info(reason)'); is($dri->get_info('reason_lang','domain','example.com.br'),'pt','message_retrieve domain get_info(reason_lang)'); ######################################################################################################### ## Contact commands $R2=$E1.''.r().'e12345005.506.560/0001-361234exemplo.com.br'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('e12345')->orgid('005.506.560/0001-36'); $rc=$dri->contact_check($co); is_string($R1,$E1.'e12345e12345005.506.560/0001-36ABC-12345'.$E2,'contact_check build'); is($dri->get_info('exist'),1,'contact_check get_info(exist)'); is($dri->get_info('ticket','orgid','005.506.560/0001-36'),1234,'contact_check get_info(ticket,orgid,$id)'); is($dri->get_info('domain','orgid','005.506.560/0001-36'),'exemplo.com.br','contact_check get_info(domain,orgid,$id)'); is($dri->get_info('ticket','domain','exemplo.com.br'),1234,'contact_check get_info(ticket,domain,$domain)'); is($dri->get_info('orgid','domain','exemplo.com.br'),'005.506.560/0001-36','contact_check get_info(orgid,domain,$domain)'); $R2=$E1.''.r().'e654321e654321-REPExample Inc.Av. Nacoes Unidas, 115417o. andarSao PauloSP04578-000BR+55.1155093500+55.1155093501jdoe@example.com.brClientYClientX2005-12-05T12:00:00.0ZClientX2005-12-05T12:00:00.0Z005.506.560/0001-36fanJohn Doeantispam.brcert.brdns.brnic.brptt.brregistro.br'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('e654321')->orgid('005.506.560/0001-36'); $rc=$dri->contact_info($co); is_string($R1,$E1.'e654321005.506.560/0001-36ABC-12345'.$E2,'contact_info build'); $co=$dri->get_info('self'); is($co->orgid(),'005.506.560/0001-36','contact_info get_info(self)->orgid'); $cs=$co->associated_contacts(); isa_ok($cs,'Net::DRI::Data::ContactSet','contact_info get_info(self)->associated_contacts'); is_deeply([$cs->types()],['admin'],'contact_info get_info(self)->associated_contacts->types'); isa_ok($cs->get('admin'),'Net::DRI::Data::Contact::BR','contact_info get_info(self)->associated_contacts->get(admin)'); is($cs->get('admin')->srid(),'fan','contact_info get_info(self)->associated_contacts->get(admin)->srid'); is($cs->get('admin')->orgid(),'005.506.560/0001-36','contact_info get_info(self)->associated_contacts->get(admin)->orgid'); is($co->responsible(),'John Doe','contact_info get_info(self)->responsible'); is_deeply($co->associated_domains(),[qw/antispam.br cert.br dns.br nic.br ptt.br registro.br/],'contact_info get_info(self)->associated_domains'); $R2=$E1.''.r().'e1234561999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('e123456'); $co->name('Example Inc.'); $co->street(['Av. Nacoes Unidas, 11541','7o. andar']); $co->city('Sao Paulo'); $co->sp('SP'); $co->pc('04578-000'); $co->cc('BR'); $co->voice('+55.1155093500x1234'); $co->fax('+55.1155093501'); $co->email('jdoe@example.com'); $co->auth({pw=>'2fooBAR'}); $co->disclose({voice=>0,email=>0}); $co->orgid('005.506.560/0001-36'); $co->associated_contacts($dri->local_object('contactset')->add($dri->local_object('contact')->srid('fan'),'admin')); $co->responsible('John Doe'); $rc=$dri->contact_create($co); is_string($R1,$E1.'e123456Example Inc.Av. Nacoes Unidas, 115417o. andarSao PauloSP04578-000BR+55.1155093500+55.1155093501jdoe@example.com2fooBAR005.506.560/0001-36fanJohn DoeABC-12345'.$E2,'contact_create build'); is($rc->is_success(),1,'contact_create is_success'); is($dri->get_info('action'),'create','contact_create get_info(action)'); is($dri->get_info('exist'),1,'contact_create get_info(exist)'); $R2=''; $co=$dri->local_object('contact')->srid('e654321')->orgid('005.506.560/0001-36'); $toc=$dri->local_object('changes'); $toc->add('associated_contacts',$dri->local_object('contactset')->add($dri->local_object('contact')->srid('hkk'),'admin')); $toc->del('associated_contacts',$dri->local_object('contactset')->add($dri->local_object('contact')->srid('fan'),'admin')); $toc->set('responsible','John Joe'); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'e654321005.506.560/0001-36hkkfanJohn JoeABC-12345'.$E2,'contact_update build'); is($rc->is_success(),1,'contact_update is_success'); $dri->cache_clear(); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'1999-04-04T22:01:00.0ZPending action completed successfully.e123450ABC-1234554321-XYZ2005-12-05T12:00:00.0Z004.857.383/6000-10Este documento nao existe na base de dados da SRF.'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info last_id'); is($dri->get_info('object_type','message','12345'),'contact','message get_info object_type'); is($dri->get_info('object_id','message','12345'),'e123450','message get_info id'); ## Information retrieved is available through the message ID we got back... is($dri->get_info('orgid','message','12345'),'004.857.383/6000-10','message_retrieve message get_info(orgid)'); is($dri->get_info('reason','message','12345'),'Este documento nao existe na base de dados da SRF.','message_retrieve message get_info(reason)'); is($dri->get_info('reason_lang','message','12345'),'pt','message_retrieve message get_info(reason_lang)'); ## ... and also through the object queried is($dri->get_info('orgid','contact','e123450'),'004.857.383/6000-10','message_retrieve domain get_info(orgid)'); is($dri->get_info('reason','contact','e123450'),'Este documento nao existe na base de dados da SRF.','message_retrieve domain get_info(reason)'); is($dri->get_info('reason_lang','contact','e123450'),'pt','message_retrieve domain get_info(reason_lang)'); exit 0; Net-DRI-0.96/t/633norid_epp.t0000755000175000017500000016432111350045740015342 0ustar patrickpatrick#!/usr/bin/perl -w use DateTime::Duration; use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 287; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('NO'); $dri->target('NO')->add_current_profile('p1','test=Net::DRI::Protocol::EPP::Extensions::NO',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); ## Domain commands my %facetsh = ( 'skip-manual-review' =>1, 'impersonate-registrar' => 'reg9094'); my $no_facet = { facets => \%facetsh }; my $NO_FACET= '1reg9094'; my $ddomain = "example3.no"; my $fdomain = "facet-$ddomain"; ###################### # Domain commands # #--- domain_check foreach my $OP ( "", $NO_FACET) { my $facet; my $domain = $ddomain; if ($OP) { $facet = $no_facet; $domain = $fdomain; } $R2=$E1.''.r().''.$domain.''.$TRID.''.$E2; $rc=$dri->domain_check($domain, $facet); is($R1,$E1.''.$domain.''.$OP. 'ABC-12345'.$E2,'domain_check build'); is($rc->is_success(),1,'domain_check is_success'); is($dri->get_info('action'),'check','domain_check get_info(action)'); is($dri->get_info('exist'),0,'domain_check get_info(exist)'); is($dri->get_info('exist','domain',$domain),0,"domain_check $domain get_info(exist) from cache"); } #---- domain_check_multi $R2=$E1.''.r().'example22.noexample2.noIn use'.$TRID.''.$E2; $rc=$dri->domain_check_multi('example22.no','example2.no'); is($R1,$E1.'example22.noexample2.noABC-12345'.$E2,'domain_check_multi build'); is($rc->is_success(),1,'domain_check_multi is_success'); is($dri->get_info('exist','domain','example22.no'),0,'domain_check_multi get_info(exist) 1/2'); is($dri->get_info('exist','domain','example2.no'),1,'domain_check_multi get_info(exist) 2/2'); is($dri->get_info('exist_reason','domain','example2.no'),'In use','domain_check_multi get_info(exist_reason)'); #---- domain_info foreach my $OP ( "", $NO_FACET) { my $facet; my $domain = $ddomain; if ($OP) { $facet = \%facetsh; $domain = $fdomain; } $R2=$E1.''.r().''.$domain.'EXAMPLE1-REPjd1234sh8013sh8013ns1.example.nons2.example.nons1.example.nons2.example.noClientXClientY1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR'.$TRID.''.$E2; $rc=$dri->domain_info($domain, { auth => {pw=>'2fooBAR'}, facets => $facet }); is($R1,$E1.''.$domain.'2fooBAR' . $OP . 'ABC-12345'.$E2,'domain_info build with auth'); is($dri->get_info('action'),'info','domain_info get_info(action)'); is($dri->get_info('exist'),1,'domain_info get_info(exist)'); is($dri->get_info('roid'),'EXAMPLE1-REP','domain_info get_info(roid)'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','domain_info get_info(status)'); is_deeply([$s->list_status()],['ok'],'domain_info get_info(status) list'); is($s->is_active(),1,'domain_info get_info(status) is_active'); $s=$dri->get_info('contact'); isa_ok($s,'Net::DRI::Data::ContactSet','domain_info get_info(contact)'); is_deeply([$s->types()],['admin','registrant','tech'],'domain_info get_info(contact) types'); is($s->get('registrant')->srid(),'jd1234','domain_info get_info(contact) registrant srid'); is($s->get('admin')->srid(),'sh8013','domain_info get_info(contact) admin srid'); is($s->get('tech')->srid(),'sh8013','domain_info get_info(contact) tech srid'); $dh=$dri->get_info('host'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(host)'); @c=$dh->get_names(); is_deeply(\@c,['ns1.example.no','ns2.example.no'],'domain_info get_info(host) get_names'); $dh=$dri->get_info('ns'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(ns)'); @c=$dh->get_names(); is_deeply(\@c,['ns1.example.no','ns2.example.no'],'domain_info get_info(ns) get_names'); is($dri->get_info('clID'),'ClientX','domain_info get_info(clID)'); is($dri->get_info('crID'),'ClientY','domain_info get_info(crID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_info get_info(crDate)'); is("".$d,'1999-04-03T22:00:00','domain_info get_info(crDate) value'); is($dri->get_info('upID'),'ClientX','domain_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','domain_info get_info(upDate)'); is("".$d,'1999-12-03T09:00:00','domain_info get_info(upDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_info get_info(exDate)'); is("".$d,'2005-04-03T22:00:00','domain_info get_info(exDate) value'); $d=$dri->get_info('trDate'); isa_ok($d,'DateTime','domain_info get_info(trDate)'); is("".$d,'2000-04-08T09:00:00','domain_info get_info(trDate) value'); is_deeply($dri->get_info('auth'),{pw=>'2fooBAR'},'domain_info get_info(auth)'); } #--- domain_info without auth $R2=$E1.''.r().'example200.noEXAMPLE1-REPClientX'.$TRID.''.$E2; $rc=$dri->domain_info('example200.no'); is($R1,$E1.'example200.noABC-12345'.$E2,'domain_info build without auth'); is($dri->get_info('exist'),1,'domain_info get_info(exist)'); is($dri->get_info('roid'),'EXAMPLE1-REP','domain_info get_info(roid)'); is($dri->get_info('clID'),'ClientX','domain_info get_info(clID)'); #--- domain_transfer_query $R2=$E1.''.r().'example201.nopendingClientX2000-06-06T22:00:00.0ZClientY2000-06-11T22:00:00.0Z2002-09-08T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_transfer_query('example201.no',{auth=>{pw=>'2fooBAR',roid=>'JD1234-REP'}}); is($R1,$E1.'example201.no2fooBARABC-12345'.$E2,'domain_transfer_query build'); is($dri->get_info('action'),'transfer','domain_transfer_query get_info(action)'); is($dri->get_info('exist'),1,'domain_transfer_query get_info(exist)'); is($dri->get_info('trStatus'),'pending','domain_transfer_query get_info(trStatus)'); is($dri->get_info('reID'),'ClientX','domain_transfer_query get_info(reID)'); $d=$dri->get_info('reDate'); isa_ok($d,'DateTime','domain_transfer_query get_info(reDate)'); is("".$d,'2000-06-06T22:00:00','domain_transfer_query get_info(reDate) value'); is($dri->get_info('acID'),'ClientY','domain_transfer_query get_info(acID)'); $d=$dri->get_info('acDate'); isa_ok($d,'DateTime','domain_transfer_query get_info(acDate)'); is("".$d,'2000-06-11T22:00:00','domain_transfer_query get_info(acDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_transfer_query get_info(exDate)'); is("".$d,'2002-09-08T22:00:00','domain_transfer_query get_info(exDate) value'); $R2=$E1.''.r().'example202.no1999-04-03T22:00:00.0Z2001-04-03T22:00:00.0Z'.$TRID.''.$E2; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $rc=$dri->domain_create('example202.no',{pure_create=>1,duration=>DateTime::Duration->new(months=>12),ns=>$dri->local_object('hosts')->set(['ns1.example.no'],['ns2.example.no']),contact=>$cs,auth=>{pw=>'2fooBAR'}}); is($R1,$E1.'example202.no1ns1.example.nons2.example.nojd1234sh8013sh80132fooBARABC-12345'.$E2,'domain_create build'); is($dri->get_info('action'),'create','domain_create get_info(action)'); is($dri->get_info('exist'),1,'domain_create get_info(exist)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_create get_info(crDate)'); is("".$d,'1999-04-03T22:00:00','domain_create get_info(crDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_create get_info(exDate)'); is("".$d,'2001-04-03T22:00:00','domain_create get_info(exDate) value'); $R2=''; $rc=$dri->domain_delete('example203.no',{pure_delete=>1}); is($R1,$E1.'example203.noABC-12345'.$E2,'domain_delete build'); is($rc->is_success(),1,'domain_delete is_success'); $R2=$E1.''.r().'example204.no2008-02-22T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_renew('example204.no',DateTime::Duration->new(years=>1),DateTime->new(year=>2008,month=>2,day=>22)); is($R1,$E1.'example204.no2008-02-221ABC-12345'.$E2,'domain_renew build'); is($dri->get_info('action'),'renew','domain_renew get_info(action)'); is($dri->get_info('exist'),1,'domain_renew get_info(exist)'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_renew get_info(exDate)'); is("".$d,'2008-02-22T22:00:00','domain_renew get_info(exDate) value'); $R2=$E1.''.r().'example205.nopendingClientX2000-06-08T22:00:00.0ZClientY2000-06-13T22:00:00.0Z2002-09-08T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_transfer_start('example205.no',{auth=>{pw=>'2fooBAR'},duration=>DateTime::Duration->new(years=>1), email=>'reg.test\@ttest.no'}); is($R1,$E1.'example205.no12fooBARreg.test\@ttest.noABC-12345'.$E2,'domain_transfer_start (=request) build'); is($dri->get_info('action'),'transfer','domain_transfer_start get_info(action)'); is($dri->get_info('exist'),1,'domain_transfer_start get_info(exist)'); is($dri->get_info('trStatus'),'pending','domain_transfer_start get_info(trStatus)'); is($dri->get_info('reID'),'ClientX','domain_transfer_start get_info(reID)'); $d=$dri->get_info('reDate'); isa_ok($d,'DateTime','domain_transfer_start get_info(reDate)'); is("".$d,'2000-06-08T22:00:00','domain_transfer_start get_info(reDate) value'); is($dri->get_info('acID'),'ClientY','domain_transfer_start get_info(acID)'); $d=$dri->get_info('acDate'); isa_ok($d,'DateTime','domain_transfer_start get_info(acDate)'); is("".$d,'2000-06-13T22:00:00','domain_transfer_start get_info(acDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_transfer_start get_info(exDate)'); is("".$d,'2002-09-08T22:00:00','domain_transfer_start get_info(exDate) value'); # execute $rc=$dri->domain_transfer_execute('example205.no',{auth=>{pw=>'2fooBAR'},duration=>DateTime::Duration->new(months=>5)}); #eval_it($dri, 'domain_transfer_execute', 'example205.no',{auth=>{pw=>'2fooBAR'},duration=>DateTime::Duration->new(months=>5)}); # hack to substitue ABC-12345 because the trid-factory does not handle the extension $R1 =~s|.+|ABC-12345|g; is($R1,$E1.'example205.no52fooBARABC-12345'.$E2,'domain_transfer_execute build'); is($dri->get_info('action'),'transfer','domain_transfer_execute get_info(action)'); is($dri->get_info('exist'),1,'domain_transfer_execute get_info(exist)'); is($dri->get_info('trStatus'),'pending','domain_transfer_execute get_info(trStatus)'); is($dri->get_info('reID'),'ClientX','domain_transfer_execute get_info(reID)'); $d=$dri->get_info('reDate'); isa_ok($d,'DateTime','domain_transfer_execute get_info(reDate)'); is("".$d,'2000-06-08T22:00:00','domain_transfer_execute get_info(reDate) value'); is($dri->get_info('acID'),'ClientY','domain_transfer_execute get_info(acID)'); $d=$dri->get_info('acDate'); isa_ok($d,'DateTime','domain_transfer_execute get_info(acDate)'); is("".$d,'2000-06-13T22:00:00','domain_transfer_execute get_info(acDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_transfer_execute get_info(exDate)'); is("".$d,'2002-09-08T22:00:00','domain_transfer_execute get_info(exDate) value'); $R2=''; $toc=$dri->local_object('changes'); $toc->add('ns',$dri->local_object('hosts')->set('ns2.example.no')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('mak21'),'tech'); $toc->add('contact',$cs); $toc->add('status',$dri->local_object('status')->no('publish','Payment overdue.')); $toc->del('ns',$dri->local_object('hosts')->set('ns1.example.no')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('sh8013'),'tech'); $toc->del('contact',$cs); $toc->del('status',$dri->local_object('status')->no('update')); $toc->set('registrant',$dri->local_object('contact')->srid('sh8013')); $toc->set('auth',{pw=>'2BARfoo'}); $rc=$dri->domain_update('example206.no',$toc); is($R1,$E1.'example206.nons2.example.nomak21Payment overdue.ns1.example.nosh8013sh80132BARfooABC-12345'.$E2,'domain_update build'); is($rc->is_success(),1,'domain_update is_success'); # The .no withdraw command extension $rc=$dri->domain_withdraw('example206.no'); is($rc->is_success(),1,'domain_withdraw is_success'); ################################################################################################################## ## Host commands $R2=$E1.''.r().'ns2.example2.noIn use'.$TRID.''.$E2; $rc=$dri->host_check('ns2.example2.no'); is($R1,$E1.'ns2.example2.noABC-12345'.$E2,'host_check build'); is($dri->get_info('action'),'check','host_check get_info(action)'); is($dri->get_info('exist'),1,'host_check get_info(exist)'); is($dri->get_info('exist','host','ns2.example2.no'),1,'host_check get_info(exist) from cache'); is($dri->get_info('exist_reason'),'In use','host_check reason'); $R2=$E1.''.r().'ns10.example2.nons20.example2.noIn usens30.example2.no'.$TRID.''.$E2; $rc=$dri->host_check_multi('ns10.example2.no','ns20.example2.no','ns30.example2.no'); is($R1,$E1.'ns10.example2.nons20.example2.nons30.example2.noABC-12345'.$E2,'host_check_multi build'); is($rc->is_success(),1,'host_check_multi is_success'); is($dri->get_info('exist','host','ns10.example2.no'),0,'host_check_multi get_info(exist) 1/3'); is($dri->get_info('exist','host','ns20.example2.no'),1,'host_check_multi get_info(exist) 2/3'); is($dri->get_info('exist_reason','host',,'ns20.example2.no'),'In use','host_check_multi get_info(exist_reason)'); is($dri->get_info('exist','host','ns30.example2.no'),0,'host_check_multi get_info(exist) 3/3'); $R2=$E1.''.r().'ns100.example2.noNS1_EXAMPLE1-REP193.0.2.2193.0.2.29ClientYClientX1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2000-04-08T09:00:00.0ZPEO183P'.$TRID.''.$E2; $rc=$dri->host_info('ns100.example2.no'); is($R1,$E1.'ns100.example2.noABC-12345'.$E2,'host_info build'); is($dri->get_info('action'),'info','host_info get_info(action)'); is($dri->get_info('exist'),1,'host_info get_info(exist)'); is($dri->get_info('roid'),'NS1_EXAMPLE1-REP','host_info get_info(roid)'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','host_info get_info(status)'); is_deeply([$s->list_status()],['clientUpdateProhibited','linked'],'host_info get_info(status) list'); is($s->is_linked(),1,'host_info get_info(status) is_linked'); is($s->can_update(),0,'host_info get_info(status) can_update'); $s=$dri->get_info('self'); isa_ok($s,'Net::DRI::Data::Hosts','host_info get_info(self)'); my ($name,$ip4,$ip6)=$s->get_details(1); is($name,'ns100.example2.no','host_info self name'); is_deeply($ip4,['193.0.2.2','193.0.2.29'],'host_info self ip4'); is($dri->get_info('clID'),'ClientY','host_info get_info(clID)'); is($dri->get_info('crID'),'ClientX','host_info get_info(crID)'); is($dri->get_info('upID'),'ClientX','host_info get_info(upID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','host_info get_info(crDate)'); is($d.'','1999-04-03T22:00:00','host_info get_info(crDate) value'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','host_info get_info(upDate)'); is($d.'','1999-12-03T09:00:00','host_info get_info(upDate) value'); $d=$dri->get_info('trDate'); isa_ok($d,'DateTime','host_info get_info(trDate)'); is($d.'','2000-04-08T09:00:00','host_info get_info(trDate) value'); is($dri->get_info('contact'),'PEO183P','host_info get_info(contact)'); $R2=$E1.''.r().'ns101.example1.no1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->host_create($dri->local_object('hosts')->add('ns101.example1.no',['193.0.2.2','193.0.2.29'],[]), {contact=>'PEO183P'}); is($R1,$E1.'ns101.example1.no193.0.2.2193.0.2.29PEO183PABC-12345'.$E2,'host_create build'); is($dri->get_info('action'),'create','host_create get_info(action)'); is($dri->get_info('exist'),1,'host_create get_info(exist)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','host_create get_info(crDate)'); is($d.'','1999-04-03T22:00:00','host_create get_info(crDate) value'); $R2=$E1.''.r().$TRID.''.$E2; $rc=$dri->host_delete('ns102.example1.no'); is($R1,$E1.'ns102.example1.noABC-12345'.$E2,'host_delete build'); is($rc->is_success(),1,'host_delete is_success'); $R2=$E1.''.r().$TRID.''.$E2; ## host update my $toc=$dri->local_object('changes'); $toc->add('ip',$dri->local_object('hosts')->add('ns1.example1.no',['193.0.2.22'],[])); $toc->add('status',$dri->local_object('status')->no('update')); $toc->del('ip',$dri->local_object('hosts')->add('ns1.example1.no',[],['2000:0:0:0:8:800:200C:417A'])); $toc->set('name','ns104.example2.no'); # .NO contact extension: $toc->add('contact', 'OS103P'); $toc->del('contact', 'PEO183P'); $rc=$dri->host_update('ns103.example1.no',$toc); is($R1,$E1.'ns103.example1.no193.0.2.222000:0:0:0:8:800:200C:417Ans104.example2.noOS103PPEO183PABC-12345'.$E2,'host_update build'); is($rc->is_success(),1,'host_update is_success'); ######################################################################################################### ## Contact commands my $co; $R2=$E1.''.r().'PEO183P'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('PEO183P'); #->auth({pw=>'2fooBAR'}); $rc=$dri->contact_check($co); is($R1,$E1.'PEO183PABC-12345'.$E2,'contact_check build'); is($rc->is_success(),1,'contact_check is_success'); is($dri->get_info('action'),'check','contact_check get_info(action)'); is($dri->get_info('exist'),0,'contact_check get_info(exist)'); is($dri->get_info('exist','contact','PEO183P'),0,'contact_check get_info(exist) from cache'); # contact check is not supported by the registry, bot a local DRI check should work $R2=$E1.''.r().'sh8001sh8002In usesh8003'.$TRID.''.$E2; $rc=$dri->contact_check_multi(map { $dri->local_object('contact')->srid($_) } ('sh8001','sh8002','sh8003')); is($R1,$E1.'sh8001sh8002sh8003ABC-12345'.$E2,'contact_check_multi build'); is($rc->is_success(),1,'contact_check_multi is_success'); is($dri->get_info('exist','contact','sh8001'),0,'contact_check_multi get_info(exist) 1/3'); is($dri->get_info('exist','contact','sh8002'),1,'contact_check_multi get_info(exist) 2/3'); is($dri->get_info('exist_reason','contact','sh8002'),'In use','contact_check_multi get_info(exist_reason)'); is($dri->get_info('exist','contact','sh8003'),0,'contact_check_multi get_info(exist) 3/3'); $R2=$E1.''.r().'sh8013SH8013-REPJohn DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+47.7035555555+47.7035555556jdoe@example.noClientYClientX1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('sh8013')->auth({pw=>'2fooBAR'}); $rc=$dri->contact_info($co); is($R1,$E1.'sh80132fooBARABC-12345'.$E2,'contact_info build'); is($rc->is_success(),1,'contact_info is_success'); is($dri->get_info('action'),'info','contact_info get_info(action)'); is($dri->get_info('exist'),1,'contact_info get_info(exist)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::Contact','contact_info get_info(self)'); is($co->srid(),'sh8013','contact_info get_info(self) srid'); is($co->roid(),'SH8013-REP','contact_info get_info(self) roid'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','contact_info get_info(status)'); is_deeply([$s->list_status()],['clientDeleteProhibited','linked'],'contact_info get_info(status) list_status'); is($s->can_delete(),0,'contact_info get_info(status) can_delete'); is($co->name(),'John Doe','contact_info get_info(self) name'); is($co->org(),'Example Inc.','contact_info get_info(self) org'); is_deeply($co->street(),['123 Example Dr.','Suite 100'],'contact_info get_info(self) street'); is($co->city(),'Dulles','contact_info get_info(self) city'); is($co->sp(),'VA','contact_info get_info(self) sp'); is($co->pc(),'20166-6503','contact_info get_info(self) pc'); is($co->cc(),'US','contact_info get_info(self) cc'); is($co->voice(),'+47.7035555555x1234','contact_info get_info(self) voice'); is($co->fax(),'+47.7035555556','contact_info get_info(self) fax'); is($co->email(),'jdoe@example.no','contact_info get_info(self) email'); is($dri->get_info('clID'),'ClientY','contact_info get_info(clID)'); is($dri->get_info('crID'),'ClientX','contact_info get_info(crID)'), $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','contact_info get_info(crDate)'); is("".$d,'1999-04-03T22:00:00','contact_info get_info(crDate) value'); is($dri->get_info('upID'),'ClientX','contact_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','contact_info get_info(upDate)'); is("".$d,'1999-12-03T09:00:00','contact_info get_info(upDate) value'); $d=$dri->get_info('trDate'); isa_ok($d,'DateTime','contact_info get_info(trDate)'); is("".$d,'2000-04-08T09:00:00','contact_info get_info(trDate) value'); is_deeply($co->auth(),{pw=>'2fooBAR'},'contact_info get_info(self) auth'); is_deeply($co->disclose(),{voice=>0,email=>0},'contact_info get_info(self) disclose'); $R2=$E1.''.r().'JD12P1999-04-03T22:00:00.0Z'.$TRID.''.$E2; # # create a contact person $co=$dri->local_object('contact')->new(); $co->name('John Doe'); #$co->org('Example Inc.'); $co->street(['123 Example Dr.','Suite 100']); $co->city('Dulles'); $co->sp('VA'); $co->pc('20166-6503'); $co->cc('US'); $co->voice('+47.7035555555x1234'); $co->fax('+47.7035555556'); $co->email('jdoe@example.no'); $co->auth({pw=>'2fooBAR'}); $co->disclose({voice=>0,email=>0}); # .NO extensions $co->type('person'); $co->xemail(['xtra1@example.no', 'xtra2@example.no']); $co->mobilephone('+47.123456780'); #eval_it($dri, 'contact_create', $co); $rc=$dri->contact_create($co); is($R1,$E1.'autoJohn Doe123 Example Dr.Suite 100DullesVA20166-6503US+47.7035555555+47.7035555556jdoe@example.no2fooBARperson+47.123456780xtra1@example.noxtra2@example.noABC-12345'.$E2,'contact_create build person'); is($dri->get_info('id'),'JD12P','contact_create person with registry contact:id get_info(id)'); is($dri->get_info('exist'),undef,'contact_create person with registry contact:id get_info(exist)'); is($dri->get_info('id','contact','JD12P'),'JD12P','contact_create person with registry contact:id get_info(JD12P,id)'); is($dri->get_info('exist','contact','JD12P'),1,'contact_create person with registry contact:id get_info(JD12P,exist)'); # # create a contact organization $R2=$E1.''.r().'JD12O1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->new(); $co->name('John Doe'); #$co->org('Example Inc.'); $co->street(['123 Example Dr.','Suite 100']); $co->city('Dulles'); $co->sp('VA'); $co->pc('20166-6503'); $co->cc('US'); $co->voice('+47.7035555555x1234'); $co->fax('+47.7035555556'); $co->email('jdoe@example.no'); $co->auth({pw=>'2fooBAR'}); $co->disclose({voice=>0,email=>0}); # .NO extensions $co->type('organization'); $co->identity({type=>'organizationNumber', value=>'932080506'}); $co->xemail(['xtra1@example.no', 'xtra2@example.no']); $co->mobilephone('+47.123456780'); #eval_it($dri, 'contact_create', $co); $rc=$dri->contact_create($co); is($R1,$E1.'autoJohn Doe123 Example Dr.Suite 100DullesVA20166-6503US+47.7035555555+47.7035555556jdoe@example.no2fooBARorganization932080506+47.123456780xtra1@example.noxtra2@example.noABC-12345'.$E2,'contact_create build organization'); is($dri->get_info('id'),'JD12O','contact_create organization with registry contact:id get_info(id)'); is($dri->get_info('exist'),undef,'contact_create organization with registry contact:id get_info(exist)'); is($dri->get_info('id','contact','JD12O'),'JD12O','contact_create organization with registry contact:id get_info(JD12P,id)'); is($dri->get_info('exist','contact','JD12O'),1,'contact_create organization with registry contact:id get_info(JD12O,exist)'); # create a contact role $R2=$E1.''.r().'JD12R1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->new(); $co->name('John Doe'); #$co->org('Example Inc.'); $co->street(['123 Example Dr.','Suite 100']); $co->city('Dulles'); $co->sp('VA'); $co->pc('20166-6503'); $co->cc('US'); $co->voice('+47.7035555555x1234'); $co->fax('+47.7035555556'); $co->email('jdoe@example.no'); $co->auth({pw=>'2fooBAR'}); $co->disclose({voice=>0,email=>0}); # .NO extensions $co->type('role'); $co->rolecontact(['JD12P', 'JD13P']); $co->xemail(['xtra1@example.no', 'xtra2@example.no']); $co->mobilephone('+47.123456780'); $co->xdisclose({mobilePhone=>0}); $rc=$dri->contact_create($co); #eval_it($dri, 'contact_create', $co); is($R1,$E1.'autoJohn Doe123 Example Dr.Suite 100DullesVA20166-6503US+47.7035555555+47.7035555556jdoe@example.no2fooBARrole+47.123456780xtra1@example.noxtra2@example.noJD12PJD13PABC-12345'.$E2,'contact_create build role'); is($dri->get_info('id'),'JD12R','contact_create organization with registry contact:id get_info(id)'); is($dri->get_info('exist'),undef,'contact_create organization with registry contact:id get_info(exist)'); is($dri->get_info('id','contact','JD12R'),'JD12R','contact_create organization with registry contact:id get_info(JD12P,id)'); is($dri->get_info('exist','contact','JD12R'),1,'contact_create organization with registry contact:id get_info(JD12R,exist)'); ## Some registries do not permit the registrar to set the contact:id, and will just set one ## Here is how to deal with this case ## Note that contact:id is mandatory in EPP, and hence we will always send one ## (handled transparently by Contact::*::init() $R2=$E1.''.r().'NEWREGID1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co->srid('sh8015'); $rc=$dri->contact_create($co); is($dri->get_info('id'),'NEWREGID','contact_create with registry contact:id get_info(id)'); is($dri->get_info('exist'),undef,'contact_create with registry contact:id get_info(exist)'); is($dri->get_info('id','contact','NEWREGID'),'NEWREGID','contact_create with registry contact:id get_info(NEWREGID,id)'); is($dri->get_info('exist','contact','NEWREGID'),1,'contact_create with registry contact:id get_info(NEWREGID,exist)'); $R2=''; $co=$dri->local_object('contact')->srid('sh8016')->auth({pw=>'2fooBAR'}); $rc=$dri->contact_delete($co); is($R1,$E1.'sh8016ABC-12345'.$E2,'contact_delete build'); is($rc->is_success(),1,'contact_delete is_success'); $R2=''; $co=$dri->local_object('contact')->srid('sh8018')->auth({pw=>'2fooBAR'}); $toc=$dri->local_object('changes'); $toc->add('status',$dri->local_object('status')->no('delete')); my $co2=$dri->local_object('contact'); $co2->org(''); $co2->street(['124 Example Dr.','Suite 200']); $co2->city('Dulles'); $co2->sp('VA'); $co2->pc('20166-6503'); $co2->cc('US'); $co2->voice('+47.7034444444'); $co2->fax(''); $co2->auth({pw=>'2fooBAR'}); $co2->disclose({voice=>1,email=>1}); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is($R1,$E1.'sh8018124 Example Dr.Suite 200DullesVA20166-6503US+47.70344444442fooBARABC-12345'.$E2,'contact_update build'); is($rc->is_success(),1,'contact_update is_success'); ## Session commands $R2=''; $rc=$dri->process('session','noop',[]); is($R1,$E1.''.$E2,'session noop build'); is($rc->is_success(),1,'session noop is_success'); $R2=$E1.''.r(1500).$TRID.''.$E2; $rc=$dri->process('session','logout',[]); is($R1,$E1.'ABC-12345'.$E2,'session logout build'); is($rc->is_success(),1,'session logout is_success'); $R2=$E1.'Example EPP server epp.example.no2000-06-08T22:00:00.0Z1.0enfrurn:ietf:params:xml:ns:obj1urn:ietf:params:xml:ns:obj2urn:ietf:params:xml:ns:obj3http://custom/obj1ext-1.0'.$E2; $rc=$dri->process('session','connect',[]); is($R1,$E1.''.$E2,'session connect build (hello command)'); is($rc->is_success(),1,'session connect is_success'); is_deeply($dri->protocol->server_greeting(),{svID=>'Example EPP server epp.example.no',svDate=>'2000-06-08T22:00:00.0Z',version=>['1.0'],lang=>['en','fr'],svcext=>['http://custom/obj1ext-1.0'],svcs=>['urn:ietf:params:xml:ns:obj1','urn:ietf:params:xml:ns:obj2','urn:ietf:params:xml:ns:obj3'],dcp=>''},'session connect server_greeting parse'); $R2=''; $rc=$dri->process('session','login',['ClientX','foo-BAR2','bar-FOO2']); is($R1,$E1.'ClientXfoo-BAR2bar-FOO21.0enurn:ietf:params:xml:ns:obj1urn:ietf:params:xml:ns:obj2urn:ietf:params:xml:ns:obj3http://custom/obj1ext-1.0ABC-12345'.$E2,'session login build'); is($rc->is_success(),1,'session login is_success'); #################################################################################################### ## Registry Messages, normal $R2=$E1.''.r().''.$TRID.''.$E2; $rc=$dri->process('session','noop',[]); is($dri->get_info('count','message','info'),5,'message count'); is($dri->get_info('id','message','info'),12345,'message id'); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'1999-04-04T22:01:00.0ZPending action completed successfully.example.noABC-1234554321-XYZ1999-04-04T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info last_id 1'); is($dri->get_info('last_id','message','session'),12345,'message get_info last_id 2'); is($dri->get_info('id','message',12345),12345,'message get_info id'); is(''.$dri->get_info('qdate','message',12345),'1999-04-04T22:01:00','message get_info qdate'); is($dri->get_info('content','message',12345),'Pending action completed successfully.','message get_info msg'); is($dri->get_info('lang','message',12345),'en','message get_info lang'); is($dri->message_waiting(),1,'message_waiting'); is($dri->message_count(),5,'message_count'); $R2=$E1.''.r(1300,'Command completed successfully; no messages').$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),undef,'message get_info last_id (no message)'); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2006-09-25T09:09:11.0ZCome to the registry office for some beer on friday'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),2,'message get_info last_id (pure text message)'); is($dri->message_count(),1,'message_count (pure text message)'); is(''.$dri->get_info('qdate','message',2),'2006-09-25T09:09:11','message get_info qdate (pure text message)'); is($dri->get_info('content','message',2),'Come to the registry office for some beer on friday','message get_info msg (pure text message)'); is($dri->get_info('lang','message',2),'en','message get_info lang (pure text message)'); #################################################################################################### ## Registry Messages with .NO specific layout $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-02-04T09:23:04.63ZEPP response to a transaction executed on your behalf: objecttype [domain] command [transfer-execute] objectname [mydomain.no]EPP response to a transaction executed on your behalf: objecttype [domain] command [transfer-execute] objectname [mydomain.no]domaintransfer-executemydomain.noObject status prohibits operationRegistry::NORID::Exception::Policy::Domain::Locked
Domain mydomain.no: domain is locked.
NORID-1234-43412342465353432008020412454356454273-9-NORID
' . $TRID . '
' . $E2; $rc = $dri->message_retrieve(); is($rc->is_success(), 1, 'message polled successfully'); is($dri->get_info('last_id'), 374185914, 'message get_info last_id 1'); is($dri->get_info('last_id', 'message', 'session'), 374185914,'message get_info last_id 2'); is($dri->get_info('id', 'message', 374185914), 374185914,'message get_info id'); is('' . $dri->get_info('qdate', 'message', 374185914), '2008-02-04T09:23:04','message get_info qdate'); is($dri->get_info('lang', 'message', 374185914), 'en', 'message get_info lang'); is($dri->get_info('roid', 'message', 374185914), undef,'message get_info roid'); is($dri->get_info('content', 'message', 374185914), 'EPP response to a '. 'transaction executed on your behalf: objecttype [domain] ' . 'command [transfer-execute] objectname [mydomain.no]', 'message get_info content'); is($dri->get_info('action', 'message', 374185914), 'transfer-execute','message get_info action'); is($dri->get_info('object_type', 'message', 374185914), 'domain','message get_info object_type'); is($dri->get_info('object_id', 'message', 374185914), 'mydomain.no','message get_info object_id'); my $conds = $dri->get_info('conditions', 'message', 374185914); is($conds->[0]->{msg}, 'Registry::NORID::Exception::Policy::Domain::Locked','message condition message'); is($conds->[0]->{code}, 'NC20077', 'message condition code'); is($conds->[0]->{severity}, 'error', 'message condition severity'); is($conds->[0]->{details}, 'Domain mydomain.no: domain is locked.','message condition details'); $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-02-06T10:18:19.70ZReg losing: blafasel.noReg losing: blafasel.noblafasel.no' . $TRID . '' . $E2; $rc = $dri->message_retrieve(); is($rc->is_success(), 1, 'message polled successfully'); is($dri->get_info('last_id'), 375338309, 'message get_info last_id 1'); is($dri->get_info('object_type', 'message', 375338309), 'domain','message get_info object_type'); is($dri->get_info('object_id', 'message', 375338309), 'blafasel.no','message get_info object_id'); is($dri->get_info('action', 'message', 375338309), 'domain-transferred-away','message get_info action'); $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-02-06T13:37:59.63ZATTENTION: domain weingeist.no is marked to be locked SKW - lock customer request.ATTENTION: domain weingeist.no is marked to be locked SKW - lock customer request.weingeist.no' . $TRID . '' . $E2; $rc = $dri->message_retrieve(); is($rc->is_success(), 1, 'message polled successfully'); is($dri->get_info('last_id'), 375424692, 'message get_info last_id 1'); is($dri->get_info('object_type', 'message', 375424692), 'domain','message get_info object_type'); is($dri->get_info('object_id', 'message', 375424692), 'weingeist.no','message get_info object_id'); is($dri->get_info('action', 'message', 375424692), 'domain-info-lock-customer','message get_info action'); $R2=$E1.'Command completed successfully; ack to dequeue2008-07-03T10:00:07.00ZEPP response to command with clTRID [NORID-3748-1215079064192782] and svTRID [200807031157442264480D-reg9091-NORID]EPP response to command with clTRID [NORID-3748-1215079064192782] and svTRID [200807031157442264480D-reg9091-NORID]Command completed successfullytrond-transfer.nopendingreg90912008-07-03T09:57:48.00Zreg90912008-08-02T09:57:48.00ZNORID-3748-1215079064192782200807031157442264480D-reg9091-NORIDNORID-6828-12150851980226322008070313395805604613-reg9091-NORID'.$E2; $rc=$dri->message_retrieve(); my @t=$rc->trid(); is($t[0],'NORID-6828-1215085198022632','Correct parse of outer trID/clTRID block'); is($t[1],'2008070313395805604613-reg9091-NORID','Correct parse of outer trID/svTRID block'); $rc=$rc->next(); is($rc,undef,'Correct parse of trID, without touching any trID node inside response'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } # # Neat function to use to dump stuf on errors, see use above # sub eval_it { my $dri = shift; my $f = shift; my $p1 = shift; my $p2 = shift; eval { $dri->$f($p1, $p2); }; if ($@) { print "\n\nAn EXCEPTION happened !\n"; if (ref($@)) { print "FAILURE: Error descriptions: ", ref($@), "\n"; $@->print(); print "\n"; dump_conditions($dri); } else { print "FAILURE: No extra info: "; print($@); } } else { print "\n\nSUCCESS"; } print "\n"; } Net-DRI-0.96/t/002pod.t0000755000175000017500000000022510442634572014133 0ustar patrickpatrick#!/usr/bin/perl -w use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Net-DRI-0.96/t/602vnds_epp_graceperiod.t0000755000175000017500000001420111241325017017525 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Net::DRI::Data::Changes; use DateTime; use Test::More tests => 8; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['GracePeriod']}); my ($rc,$s,$toc); ######################################################################################################### ## Extension: GracePeriod $R2=$E1.''.r().'example50.comEXAMPLE1-REPjd1234sh8013sh8013ns1.example.comns1.example.netns1.example.comns2.example.comClientXClientY1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR'.$TRID.''.$E2; $rc=$dri->domain_info('example50.com',{auth=>{pw=>'2fooBAR'}}); is($R1,$E1.'example50.com2fooBARABC-12345'.$E2,'domain_info build with auth +RGP'); is($dri->get_info('exist'),1,'domain_info get_info(exist) +RGP'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','domain_info get_info(status) +RGP'); is_deeply([$s->list_status()],['addPeriod','ok'],'domain_info get_info(status) list +RGP'); $R2=''; $toc=Net::DRI::Data::Changes->new(); $toc->set('rgp',{ op => 'request'}); $rc=$dri->domain_update('example51.com',$toc); is($R1,$E1.'example51.comABC-12345'.$E2,'domain_update build +RGP/restore_request'); is($rc->is_success(),1,'domain_update is_success +RGP'); $R2=''; $toc=Net::DRI::Data::Changes->new(); $toc->set('rgp',{ op => 'report', report => {predata=>'Pre-delete registration data goes here. Both XML and free text are allowed.', postdata=>'Post-restore registration data goes here. Both XML and free text are allowed.',deltime=>DateTime->new(year=>2003,month=>7,day=>10,hour=>22),restime=>DateTime->new(year=>2003,month=>7,day=>20,hour=>22),reason=>'Registrant error.',statement1=>'This registrar has not restored the Registered Name in order to assume the rights to use or sell the Registered Name for itself or for any third party.',statement2=>'The information in this report is true to best of this registrar\'s knowledge, and this registrar acknowledges that intentionally supplying false information in this report shall constitute an incurable material breach of the Registry-Registrar Agreement.',other=>'Supporting information goes here.' }}); $rc=$dri->domain_update('example52.com',$toc); is($R1,$E1.'example52.comPre-delete registration data goes here. Both XML and free text are allowed.Post-restore registration data goes here. Both XML and free text are allowed.2003-07-10T22:00:00.0Z2003-07-20T22:00:00.0ZRegistrant error.This registrar has not restored the Registered Name in order to assume the rights to use or sell the Registered Name for itself or for any third party.The information in this report is true to best of this registrar\'s knowledge, and this registrar acknowledges that intentionally supplying false information in this report shall constitute an incurable material breach of the Registry-Registrar Agreement.Supporting information goes here.ABC-12345'.$E2,'domain_update build +RGP/restore_report'); is($rc->is_success(),1,'domain_update is_success +RGP'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/608afnic_email.t0000755000175000017500000000721211350046250015604 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Test::More; eval { require MIME::Entity; MIME::Entity->import(); }; if ($@) { plan skip_all => 'Module MIME::Entity is needed to test AFNIC email handling'; } else { plan tests => 8; } eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $R1=''; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } sub munge_xmailer { my $in=shift; $in=~s!MIME-tools \d\.\d+ \(Entity \d\.\d+\)!MIME-tools!; return $in; } my $dri=Net::DRI::TrapExceptions->new({cache_ttl=>10}); $dri->{trid_factory}=sub { return 'TRID-12345'; }; $dri->add_registry('AFNIC'); $dri->target('AFNIC')->add_current_profile('profile1','test=email',{f_send=>\&mysend, f_recv=> sub {}},{username=>'CLIENTID',password=>'CLIENTPW',email_from=>'test@localhost'}); $dri->transport->is_sync(0); my $cs=$dri->local_object('contactset'); my $co=$dri->local_object('contact'); my $ns=$dri->local_object('hosts'); my $rc; #################################################################################################### ## FULL PM $co->name('MyORG'); $co->street(['Whatever street 35','éçp àô']); $co->city('Alphaville'); $co->pc('99999'); $co->cc('FR'); $co->legal_form('S'); $co->legal_id('111222333'); $co->voice('+33.123456789'); $co->email('test@example.com'); $co->disclose('N'); $cs->set($co,'registrant'); $co=$dri->local_object('contact'); $co->srid('TEST'); $cs->set($co,'tech'); $ns->add('ns.toto.fr',['123.45.67.89']); $ns->add('ns.toto.com'); $rc=$dri->domain_create('toto.fr',{pure_create=>1, contact => $cs, maintainer => 'ABCD', ns => $ns, auth => { pw=> 'nowmandatory!'} }); is($rc->code(),1001,'domain_create PM code'); is($rc->is_success(),1,'domain_create PM is_success'); is($rc->is_pending(),1,'domain_create PM is_pending'); my $E1=<<'EOF'; Content-Type: text/plain; charset="iso-8859-15" Content-Disposition: inline Content-Transfer-Encoding: 8bit MIME-Version: 1.0 X-Mailer: Net::DRI 0.96/1.03 via MIME-tools 5.417 (Entity 5.417) From: test@localhost To: domain@nic.fr Subject: CLIENTID domain_create [TRID-12345] 1a..: C 1b..: CLIENTID 1c..: CLIENTPW 1e..: TRID-12345 1f..: 2.5.0 2a..: toto.fr 2z..: nowmandatory! 3a..: MyORG 3b..: Whatever street 35 3c..: éçp àô 3e..: Alphaville 3f..: 99999 3g..: FR 3h..: S 3j..: 111222333 3t..: +33 1 23 45 67 89 3v..: test@example.com 3w..: PM 3y..: ABCD 3z..: N 5a..: TEST-FRNIC 6a..: ns.toto.fr 6b..: 123.45.67.89 7a..: ns.toto.com 8a..: A 9a..: E EOF is_string(munge_xmailer($R1),munge_xmailer($E1),'domain_create build'); ## REDUCED PP $co=$dri->local_object('contact'); $co->srid('JOHN'); $co->disclose('N'); $co->key('ABCDEFGH-100'); $cs->set($co,'registrant'); $rc=$dri->domain_create('toto.fr',{pure_create=>1, contact => $cs, maintainer => 'ABCD', ns => $ns, auth => { pw => 'nowmandatory!'} }); is($rc->code(),1001,'domain_create PPreduced code'); is($rc->is_success(),1,'domain_create PPreduced is_success'); is($rc->is_pending(),1,'domain_create PPreduced is_pending'); my $E2=<<'EOF'; Content-Type: text/plain; charset="iso-8859-15" Content-Disposition: inline Content-Transfer-Encoding: 8bit MIME-Version: 1.0 X-Mailer: Net::DRI 0.96/1.03 via MIME-tools 5.417 (Entity 5.417) From: test@localhost To: domain@nic.fr Subject: CLIENTID domain_create [TRID-12345] 1a..: C 1b..: CLIENTID 1c..: CLIENTPW 1e..: TRID-12345 1f..: 2.5.0 2a..: toto.fr 2z..: nowmandatory! 3q..: ABCDEFGH-100 3w..: PP 3x..: JOHN-FRNIC 5a..: TEST-FRNIC 6a..: ns.toto.fr 6b..: 123.45.67.89 7a..: ns.toto.com 8a..: A 9a..: E EOF is_string(munge_xmailer($R1),munge_xmailer($E2),'domain_create PPreduced build'); exit 0; Net-DRI-0.96/t/702bookmyname_ws_live.t0000755000175000017500000000301111137716740017245 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Test::More; unless ($ENV{TEST_BOOKMYNAME_WS_LIVE_CLIENTID} && $ENV{TEST_BOOKMYNAME_WS_LIVE_CLIENTPASS}) { plan skip_all => 'Set $ENV{TEST_BOOKMYNAME_WS_LIVE_CLIENTID} and $ENV{TEST_BOOKMYNAME_WS_LIVE_CLIENTPASS} if you want (normally harmless) *live* tests for BookMyName'; } else { plan tests => 4; } my $dri=Net::DRI->new(10); $dri->add_registry('BookMyName'); $dri->target('BookMyName')->add_current_profile('p1','ws',{client_login=>$ENV{TEST_BOOKMYNAME_WS_LIVE_CLIENTID},client_password=>$ENV{TEST_BOOKMYNAME_WS_LIVE_CLIENTPASS}}); eval { my $rc=$dri->account_list_domains(); diag('Got session ID '.$dri->transport()->session_data()->{id}); is($rc->is_success(),1,'account_list_domains() is_success') or diag(sprintf('Code=%s Native_Code=%d Message=%s',$rc->code(),$rc->native_code(),$rc->message())); my $rd=$dri->get_info('list','account','domains'); is(ref($rd),'ARRAY','get_info(list,account,domains)'); diag('Successfully retrieved list of '.scalar(@$rd).' domain names: '.join(' ',@$rd)); my $rd2=$dri->get_info('list'); is_deeply($rd2,$rd,'get_info(list,account,domains) and get_info(list) give the same results'); $rc=$dri->domain_info($rd->[0]); is($rc->is_success(),1,'domain_info() is_success') or diag(sprintf('Code=%s Native_Code=%d Message=%s',$rc->code(),$rc->native_code(),$rc->message())); my @i=$dri->get_info_keys(); diag('Successfully got information about: '.join(' ',@i)); }; diag('Caught unexpected exception: '.(ref($@)? $@->as_string() : $@)) if $@; exit 0; Net-DRI-0.96/t/604vnds_epp_secdns.t0000755000175000017500000002657711241325176016553 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 10; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['SecDNS']}); my ($rc,$e,$toc); ######################################################################################################### ## Extension: SecDNS $R2=$E1.''.r().'example2.comEXAMPLE1-REPjd1234sh8013sh8013ns1.example.comns2.example.comns1.example.comns2.example.comClientXClientY1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR123453149FD46E6C4B45C55D4AC'.$TRID.''.$E2; $rc=$dri->domain_info('example2.com'); is($dri->get_info('exist'),1,'domain_info get_info(exist) +SecDNS 1'); $e=$dri->get_info('secdns'); is_deeply($e,[{keyTag=>'12345',alg=>3,digestType=>1,digest=>'49FD46E6C4B45C55D4AC'}],'domain_info get_info(secdns) +SecDNS 1'); $R2=$E1.''.r().'example3.comEXAMPLE1-REPjd1234sh8013sh8013ns1.example.comns2.example.comns1.example.comns2.example.comClientXClientY1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR123453149FD46E6C4B45C55D4AC60480025631AQPJ////4Q=='.$TRID.''.$E2; $rc=$dri->domain_info('example3.com'); is($dri->get_info('exist'),1,'domain_info get_info(exist) +SecDNS 2'); $e=$dri->get_info('secdns'); is_deeply($e,[{keyTag=>'12345',alg=>3,digestType=>1,digest=>'49FD46E6C4B45C55D4AC',maxSigLife=>604800,key_flags=>256,key_protocol=>3,key_alg=>1,key_pubKey=>'AQPJ////4Q=='}],'domain_info get_info(secdns) +SecDNS 2'); $R2=''; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $rc=$dri->domain_create('example4.com',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns2.example.com']),contact=>$cs,auth=>{pw=>'2fooBAR'},secdns=>[{keyTag=>'12345',alg=>3,digestType=>1,digest=>'49FD46E6C4B45C55D4AC'}]}); is($R1,$E1.'example4.com2ns1.example.comns2.example.comjd1234sh8013sh80132fooBAR123453149FD46E6C4B45C55D4ACABC-12345'.$E2,'domain_create build +SecDNS 1'); $rc=$dri->domain_create('example5.com',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns2.example.com']),contact=>$cs,auth=>{pw=>'2fooBAR'},secdns=>[{keyTag=>'12345',alg=>3,digestType=>1,digest=>'49FD46E6C4B45C55D4AC',maxSigLife=>604800,key_flags=>256,key_protocol=>3,key_alg=>1,key_pubKey=>'AQPJ////4Q=='}]}); is($R1,$E1.'example5.com2ns1.example.comns2.example.comjd1234sh8013sh80132fooBAR123453149FD46E6C4B45C55D4AC60480025631AQPJ////4Q==ABC-12345'.$E2,'domain_create build +SecDNS 2'); $R2=''; $toc=$dri->local_object('changes'); $toc->add('secdns',[{keyTag=>'12346',alg=>3,digestType=>1,digest=>'38EC35D5B3A34B44C39B'}]); $rc=$dri->domain_update('example10.com',$toc); is($R1,$E1.'example10.com123463138EC35D5B3A34B44C39BABC-12345'.$E2,'domain_update build +SecDNS 1'); $toc=$dri->local_object('changes'); $toc->del('secdns',[{keyTag=>'12345'}]); $rc=$dri->domain_update('example11.com',$toc); is($R1,$E1.'example11.com12345ABC-12345'.$E2,'domain_update build +SecDNS 2'); $toc=$dri->local_object('changes'); $toc->set('secdns',[{keyTag=>'12345',alg=>3,digestType=>1,digest=>'49FD46E6C4B45C55D4AC'}]); $toc->set('secdns_urgent',1); $rc=$dri->domain_update('example12.com',$toc); is($R1,$E1.'example12.com123453149FD46E6C4B45C55D4ACABC-12345'.$E2,'domain_update build +SecDNS 3'); $toc=$dri->local_object('changes'); $toc->set('secdns',[{keyTag=>'12345',alg=>3,digestType=>1,digest=>'49FD46E6C4B45C55D4AC',maxSigLife=>604800,key_flags=>256,key_protocol=>3,key_alg=>1,key_pubKey=>'AQPJ////4Q=='}]); $rc=$dri->domain_update('example13.com',$toc); is($R1,$E1.'example13.com123453149FD46E6C4B45C55D4AC60480025631AQPJ////4Q==ABC-12345'.$E2,'domain_update build +SecDNS 4'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/211rrp_message.t0000755000175000017500000001465111023313454015657 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::Protocol::RRP::Message; use Encode; use Test::More tests=>28; my $n; ## Creation $n=Net::DRI::Protocol::RRP::Message->new()->command('add')->entities('EntityName','Domain')->entities('DomainName','example.com')->options('Period',10); is($n->as_string(),"add\r\nEntityName:Domain\r\nDomainName:example.com\r\n-Period:10\r\n.\r\n",'RRP Message create domain add 1 string'); is($n->command(),'add','RRP Message create domain add 1 command'); $n=Net::DRI::Protocol::RRP::Message->new()->command('add')->entities('EntityName','Domain')->entities('DomainName','example.com')->entities('NameServer',['ns1.example.com','ns2.example.com'])->options('Period',10); is($n->as_string(),"add\r\nEntityName:Domain\r\nDomainName:example.com\r\n-Period:10\r\nNameServer:ns1.example.com\r\nNameServer:ns2.example.com\r\n.\r\n",'RRP Message create domain add 2'); $n=Net::DRI::Protocol::RRP::Message->new()->command('add')->entities('EntityName','NameServer')->entities('NameServer','ns1.example.com')->entities('IPAddress','198.41.1.11'); is($n->as_string(),"add\r\nEntityName:NameServer\r\nNameServer:ns1.example.com\r\nIPAddress:198.41.1.11\r\n.\r\n",'RRP Message create nameserver add string'); $n=Net::DRI::Protocol::RRP::Message->new()->command('check')->entities('EntityName','Domain')->entities('DomainName','example.com'); is($n->as_string(),"check\r\nEntityName:Domain\r\nDomainName:example.com\r\n.\r\n",'RRP Message create domain check'); $n=Net::DRI::Protocol::RRP::Message->new()->command('check')->entities('EntityName','NameServer')->entities('NameServer','ns1.example.com'); is($n->as_string(),"check\r\nEntityName:NameServer\r\nNameServer:ns1.example.com\r\n.\r\n",'RRP Message create nameserver check'); $n=Net::DRI::Protocol::RRP::Message->new()->command('del')->entities('EntityName','Domain')->entities('DomainName','example.com'); is($n->as_string(),"del\r\nEntityName:Domain\r\nDomainName:example.com\r\n.\r\n",'RRP Message create domain del'); $n=Net::DRI::Protocol::RRP::Message->new()->command('del')->entities('EntityName','NameServer')->entities('NameServer','ns1.registrarA.com'); is($n->as_string(),"del\r\nEntityName:NameServer\r\nNameServer:ns1.registrarA.com\r\n.\r\n",'RRP Message create nameserver del'); $n=Net::DRI::Protocol::RRP::Message->new()->command('describe')->options('Target','Protocol'); is($n->as_string(),"describe\r\n-Target:Protocol\r\n.\r\n",'RRP Message create describe'); $n=Net::DRI::Protocol::RRP::Message->new()->command('mod')->entities('EntityName','Domain')->entities('DomainName','example.com')->entities('NameServer',['ns3.registrarA.com','ns1.registrarA.com=']); is($n->as_string(),"mod\r\nEntityName:Domain\r\nDomainName:example.com\r\nNameServer:ns3.registrarA.com\r\nNameServer:ns1.registrarA.com=\r\n.\r\n",'RRP Message create domain mod'); $n=Net::DRI::Protocol::RRP::Message->new()->command('mod')->entities('EntityName','NameServer')->entities('NameServer','ns1.registrarA.com')->entities('NewNameServer','ns2.registrarA.com')->entities('IPAddress',['198.42.1.11','198.41.1.11=']); is($n->as_string(),"mod\r\nEntityName:NameServer\r\nNameServer:ns1.registrarA.com\r\nNewNameServer:ns2.registrarA.com\r\nIPAddress:198.42.1.11\r\nIPAddress:198.41.1.11=\r\n.\r\n",'RRP Message create nameserver mod'); $n=Net::DRI::Protocol::RRP::Message->new()->command('quit'); is($n->as_string(),"quit\r\n.\r\n",'RRP Message create quit'); $n=Net::DRI::Protocol::RRP::Message->new()->command('renew')->entities('EntityName','Domain')->entities('DomainName','example.com')->options('Period',9)->options('CurrentExpirationYear',2001); is($n->as_string(),"renew\r\nEntityName:Domain\r\nDomainName:example.com\r\n-Period:9\r\n-CurrentExpirationYear:2001\r\n.\r\n",'RRP Message create domain renew'); $n=Net::DRI::Protocol::RRP::Message->new()->command('session')->options('Id','registrarA')->options('Password','i-am-registrarA'); is($n->as_string(),"session\r\n-Id:registrarA\r\n-Password:i-am-registrarA\r\n.\r\n",'RRP Message create session'); $n=Net::DRI::Protocol::RRP::Message->new()->command('status')->entities('EntityName','Domain')->entities('DomainName','example.com'); is($n->as_string(),"status\r\nEntityName:Domain\r\nDomainName:example.com\r\n.\r\n",'RRP Message create domain status'); $n=Net::DRI::Protocol::RRP::Message->new()->command('status')->entities('EntityName','NameServer')->entities('NameServer','ns1.registrarA.com'); is($n->as_string(),"status\r\nEntityName:NameServer\r\nNameServer:ns1.registrarA.com\r\n.\r\n",'RRP Message create nameserver status'); $n=Net::DRI::Protocol::RRP::Message->new()->command('transfer')->entities('EntityName','Domain')->entities('DomainName','example.com'); is($n->as_string(),"transfer\r\nEntityName:Domain\r\nDomainName:example.com\r\n.\r\n",'RRP Message create domain transfer'); $n=Net::DRI::Protocol::RRP::Message->new()->command('transfer')->entities('EntityName','Domain')->entities('DomainName','example.com')->options('Approve','Yes'); is($n->as_string(),"transfer\r\n-Approve:Yes\r\nEntityName:Domain\r\nDomainName:example.com\r\n.\r\n",'RRP Message create domain transfer'); ok(!Encode::is_utf8($n->as_string()),'Unicode : string sent on network is bytes not characters'); ### Parse use Net::DRI::Data::Raw; my $R="\r"; my $r; $r=Net::DRI::Data::Raw->new_from_string(<new(); $n->parse($r); ## check result_code is($n->errcode(),200,'RRP Message parse domain add, errcode'); is($n->errmsg(),'Command completed successfully','RRP Message parse domain add, errmsg'); eq_set([$n->entities()],['registration expiration date','status'],'RRP Message parse domain add, entities'); is($n->entities('registration expiration date'),'2009-09-22 10:27:00.0','RRP Message parse domain add, entity 1'); is($n->entities('status'),'ACTIVE','RRP Message parse domain add, entity 2'); is($n->entities('StAtus'),'ACTIVE','RRP Message parse domain add, entity 2 case insensitive'); $r=Net::DRI::Data::Raw->new_from_string(<new(); $n->parse($r); is($n->errcode(),200,'RRP Message parse empty, errcode'); is($n->errmsg(),'Command completed successfully','RRP Message empty, errmsg'); eq_set([$n->entities()],[],'RRP Message parse empty, entities'); is_deeply($n->options(),{},'RRP Message parse empty, options'); is($n->is_success(),1,'RRP Message parse empty, is_success'); exit 0; Net-DRI-0.96/t/627at_epp.t0000755000175000017500000002406511241325564014642 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 36; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('AT'); $dri->target('AT')->add_current_profile('p1','test=Net::DRI::Protocol::EPP::Extensions::AT',{f_send => \&mysend, f_recv => \&myrecv}); my $rc; my $s; my $d; my ($dh, @c); #################################################################################################### ## Registry Messages $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-02-04T09:23:04.63ZEPP response to a transaction executed on your behalf: objecttype [domain] command [transfer-execute] objectname [mydomain.at]EPP response to a transaction executed on your behalf: objecttype [domain] command [transfer-execute] objectname [mydomain.at]domaintransfer-executemydomain.atObject status prohibits operationRegistry::NICAT::Exception::Policy::Domain::Locked
Domain mydomain.at: domain is locked.
NICAT-1234-43412342465353432008020412454356454273-9-nicat
' . $TRID . '
' . $E2; $rc = $dri->message_retrieve(); is($rc->is_success(), 1, 'message polled successfully'); is($dri->get_info('last_id'), 374185914, 'message get_info last_id 1'); is($dri->get_info('last_id', 'message', 'session'), 374185914,'message get_info last_id 2'); is($dri->get_info('id', 'message', 374185914), 374185914,'message get_info id'); is('' . $dri->get_info('qdate', 'message', 374185914), '2008-02-04T09:23:04','message get_info qdate'); is($dri->get_info('lang', 'message', 374185914), 'en', 'message get_info lang'); is($dri->get_info('roid', 'message', 374185914), undef,'message get_info roid'); is($dri->get_info('content', 'message', 374185914), 'EPP response to a '. 'transaction executed on your behalf: objecttype [domain] ' . 'command [transfer-execute] objectname [mydomain.at]', 'message get_info content'); is($dri->get_info('action', 'message', 374185914), 'transfer-execute','message get_info action'); is($dri->get_info('object_type', 'message', 374185914), 'domain','message get_info object_type'); is($dri->get_info('object_id', 'message', 374185914), 'mydomain.at','message get_info object_id'); my $conds = $dri->get_info('conditions', 'message', 374185914); is($conds->[0]->{msg}, 'Registry::NICAT::Exception::Policy::Domain::Locked','message condition message'); is($conds->[0]->{code}, 'NC20077', 'message condition code'); is($conds->[0]->{severity}, 'error', 'message condition severity'); is($conds->[0]->{details}, 'Domain mydomain.at: domain is locked.','message condition details'); $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-02-06T10:18:19.70ZReg losing: blafasel.atReg losing: blafasel.atblafasel.at' . $TRID . '' . $E2; $rc = $dri->message_retrieve(); is($rc->is_success(), 1, 'message polled successfully'); is($dri->get_info('last_id'), 375338309, 'message get_info last_id 1'); is($dri->get_info('object_type', 'message', 375338309), 'domain','message get_info object_type'); is($dri->get_info('object_id', 'message', 375338309), 'blafasel.at','message get_info object_id'); is($dri->get_info('action', 'message', 375338309), 'domain-transferred-away','message get_info action'); $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-02-06T13:37:59.63ZATTENTION: domain weingeist.at is marked to be locked SKW - lock customer request.ATTENTION: domain weingeist.at is marked to be locked SKW - lock customer request.weingeist.at' . $TRID . '' . $E2; $rc = $dri->message_retrieve(); is($rc->is_success(), 1, 'message polled successfully'); is($dri->get_info('last_id'), 375424692, 'message get_info last_id 1'); is($dri->get_info('object_type', 'message', 375424692), 'domain','message get_info object_type'); is($dri->get_info('object_id', 'message', 375424692), 'weingeist.at','message get_info object_id'); is($dri->get_info('action', 'message', 375424692), 'domain-info-lock-customer','message get_info action'); $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-03-14T11:42:23.64ZTransfer process cancelled for domain: (transfer-request with client-id [NICAT-1234-1242342543566334] and server-id [20080307124235423353F9-4-nicat])Transfer process cancelled for domain: (transfer-request with client-id [NICAT-1234-1242342543566334] and server-id [20080307124235423353F9-4-nicat])NICAT-1234-124234254356633420080307124235423353F9-4-nicat' . $TRID . '' . $E2; $rc = $dri->message_retrieve(); is($rc->is_success(), 1, 'message polled successfully'); is($dri->get_info('last_id'), 390336246, 'message get_info last_id 1'); is($dri->get_info('object_type', 'message', 390336246), 'domain', 'message get_info object_type'); is($dri->get_info('object_id', 'message', 390336246), undef, 'message get_info object_id'); is($dri->get_info('action', 'message', 390336246), 'domain-transfer-aborted', 'message get_info action'); $R2 = $E1 . 'Command completed successfully; ack to dequeue2008-06-19T07:24:58.85ZEPP response to a transaction executed on your behalf: objecttype [domain] command [transfer-execute] objectname [neingeist.at]EPP response to a transaction executed on your behalf: objecttype [domain] command [transfer-execute] objectname [neingeist.at]domaintransfer-executeneingeist.atCommand completed successfullyneingeist.atserverApprovedReg1232009-01-01T01:23:51.00ZReg1232009-01-01T01:01:01.00Z0423ABCD-123123-ABC' . $TRID . '' . $E2; $rc = $dri->message_retrieve(); is($rc->is_success(), 1, 'message polled successfully'); is($dri->get_info('last_id'), 523423542, 'message get_info last_id 1'); is($dri->get_info('object_type', 'message', 523423542), 'domain','message get_info object_type'); is($dri->get_info('object_id', 'message', 523423542), 'neingeist.at','message get_info object_id'); is($dri->get_info('action', 'message', 523423542), 'transfer-execute','message get_info action'); is($dri->get_info('keydate', 'message', 523423542), '0423','message get_info keydate'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/601vnds_epp.t0000755000175000017500000013532711350046346015203 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 261; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new({cache_ttl => 10, trid_factory => sub { return 'ABC-12345'}, logging => 'null' }); $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); ## Domain commands $R2=$E1.''.r().'example3.com'.$TRID.''.$E2; $rc=$dri->domain_check('example3.com'); is($R1,$E1.'example3.comABC-12345'.$E2,'domain_check build'); is($rc->is_success(),1,'domain_check is_success'); is($dri->get_info('action'),'check','domain_check get_info(action)'); is($dri->get_info('exist'),0,'domain_check get_info(exist)'); is($dri->get_info('exist','domain','example3.com'),0,'domain_check get_info(exist) from cache'); $R2=$E1.''.r().'example22.comexample2.netIn use'.$TRID.''.$E2; $rc=$dri->domain_check_multi('example22.com','example2.net'); is($R1,$E1.'example22.comexample2.netABC-12345'.$E2,'domain_check_multi build'); is($rc->is_success(),1,'domain_check_multi is_success'); is($dri->get_info('exist','domain','example22.com'),0,'domain_check_multi get_info(exist) 1/2'); is($dri->get_info('exist','domain','example2.net'),1,'domain_check_multi get_info(exist) 2/2'); is($dri->get_info('exist_reason','domain','example2.net'),'In use','domain_check_multi get_info(exist_reason)'); $R2=$E1.''.r().'example2.comEXAMPLE1-REPjd1234sh8013sh8013ns1.example.comns1.example.netns1.example.comns2.example.comClientXClientY1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR'.$TRID.''.$E2; $rc=$dri->domain_info('example2.com',{auth=>{pw=>'2fooBAR'}}); is($R1,$E1.'example2.com2fooBARABC-12345'.$E2,'domain_info build with auth'); is($dri->get_info('action'),'info','domain_info get_info(action)'); is($dri->get_info('exist'),1,'domain_info get_info(exist)'); is($dri->get_info('roid'),'EXAMPLE1-REP','domain_info get_info(roid)'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','domain_info get_info(status)'); is_deeply([$s->list_status()],['ok'],'domain_info get_info(status) list'); is($s->is_active(),1,'domain_info get_info(status) is_active'); $s=$dri->get_info('contact'); isa_ok($s,'Net::DRI::Data::ContactSet','domain_info get_info(contact)'); is_deeply([$s->types()],['admin','registrant','tech'],'domain_info get_info(contact) types'); is($s->get('registrant')->srid(),'jd1234','domain_info get_info(contact) registrant srid'); is($s->get('admin')->srid(),'sh8013','domain_info get_info(contact) admin srid'); is($s->get('tech')->srid(),'sh8013','domain_info get_info(contact) tech srid'); $dh=$dri->get_info('host'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(host)'); @c=$dh->get_names(); is_deeply(\@c,['ns1.example.com','ns2.example.com'],'domain_info get_info(host) get_names'); $dh=$dri->get_info('ns'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(ns)'); @c=$dh->get_names(); is_deeply(\@c,['ns1.example.com','ns1.example.net'],'domain_info get_info(ns) get_names'); is($dri->get_info('clID'),'ClientX','domain_info get_info(clID)'); is($dri->get_info('crID'),'ClientY','domain_info get_info(crID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_info get_info(crDate)'); is("".$d,'1999-04-03T22:00:00','domain_info get_info(crDate) value'); is($dri->get_info('upID'),'ClientX','domain_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','domain_info get_info(upDate)'); is("".$d,'1999-12-03T09:00:00','domain_info get_info(upDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_info get_info(exDate)'); is("".$d,'2005-04-03T22:00:00','domain_info get_info(exDate) value'); $d=$dri->get_info('trDate'); isa_ok($d,'DateTime','domain_info get_info(trDate)'); is("".$d,'2000-04-08T09:00:00','domain_info get_info(trDate) value'); is_deeply($dri->get_info('auth'),{pw=>'2fooBAR'},'domain_info get_info(auth)'); $R2=$E1.''.r().'example200.comEXAMPLE1-REPClientX'.$TRID.''.$E2; $rc=$dri->domain_info('example200.com'); is($R1,$E1.'example200.comABC-12345'.$E2,'domain_info build without auth'); is($dri->get_info('exist'),1,'domain_info get_info(exist)'); is($dri->get_info('roid'),'EXAMPLE1-REP','domain_info get_info(roid)'); is($dri->get_info('clID'),'ClientX','domain_info get_info(clID)'); $R2=$E1.''.r().'example201.compendingClientX2000-06-06T22:00:00.0ZClientY2000-06-11T22:00:00.0Z2002-09-08T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_transfer_query('example201.com',{auth=>{pw=>'2fooBAR',roid=>'JD1234-REP'}}); is($R1,$E1.'example201.com2fooBARABC-12345'.$E2,'domain_transfer_query build'); is($dri->get_info('action'),'transfer','domain_transfer_query get_info(action)'); is($dri->get_info('exist'),1,'domain_transfer_query get_info(exist)'); is($dri->get_info('trStatus'),'pending','domain_transfer_query get_info(trStatus)'); is($dri->get_info('reID'),'ClientX','domain_transfer_query get_info(reID)'); $d=$dri->get_info('reDate'); isa_ok($d,'DateTime','domain_transfer_query get_info(reDate)'); is("".$d,'2000-06-06T22:00:00','domain_transfer_query get_info(reDate) value'); is($dri->get_info('acID'),'ClientY','domain_transfer_query get_info(acID)'); $d=$dri->get_info('acDate'); isa_ok($d,'DateTime','domain_transfer_query get_info(acDate)'); is("".$d,'2000-06-11T22:00:00','domain_transfer_query get_info(acDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_transfer_query get_info(exDate)'); is("".$d,'2002-09-08T22:00:00','domain_transfer_query get_info(exDate) value'); $R2=$E1.''.r().'example202.com1999-04-03T22:00:00.0Z2001-04-03T22:00:00.0Z'.$TRID.''.$E2; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $rc=$dri->domain_create('example202.com',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns1.example.net']),contact=>$cs,auth=>{pw=>'2fooBAR'}}); is($R1,$E1.'example202.com2ns1.example.comns1.example.netjd1234sh8013sh80132fooBARABC-12345'.$E2,'domain_create build'); is($dri->get_info('action'),'create','domain_create get_info(action)'); is($dri->get_info('exist'),1,'domain_create get_info(exist)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_create get_info(crDate)'); is("".$d,'1999-04-03T22:00:00','domain_create get_info(crDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_create get_info(exDate)'); is("".$d,'2001-04-03T22:00:00','domain_create get_info(exDate) value'); $R2=''; $rc=$dri->domain_delete('example203.com',{pure_delete=>1}); is($R1,$E1.'example203.comABC-12345'.$E2,'domain_delete build'); is($rc->is_success(),1,'domain_delete is_success'); $R2=$E1.''.r().'example204.com2005-04-03T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_renew('example204.com',DateTime::Duration->new(years=>5),DateTime->new(year=>2000,month=>4,day=>3)); is($R1,$E1.'example204.com2000-04-035ABC-12345'.$E2,'domain_renew build'); is($dri->get_info('action'),'renew','domain_renew get_info(action)'); is($dri->get_info('exist'),1,'domain_renew get_info(exist)'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_renew get_info(exDate)'); is("".$d,'2005-04-03T22:00:00','domain_renew get_info(exDate) value'); $R2=$E1.''.r().'example205.compendingClientX2000-06-08T22:00:00.0ZClientY2000-06-13T22:00:00.0Z2002-09-08T22:00:00.0Z'.$TRID.''.$E2; { no warnings; *Net::DRI::DRD::VNDS::verify_duration_transfer=sub { return 0; }; } $rc=$dri->domain_transfer_start('example205.com',{auth=>{pw=>'2fooBAR',roid=>"JD1234-REP"},duration=>DateTime::Duration->new(years=>1)}); is($R1,$E1.'example205.com12fooBARABC-12345'.$E2,'domain_transfer_request build'); is($dri->get_info('action'),'transfer','domain_transfer_start get_info(action)'); is($dri->get_info('exist'),1,'domain_transfer_start get_info(exist)'); is($dri->get_info('trStatus'),'pending','domain_transfer_start get_info(trStatus)'); is($dri->get_info('reID'),'ClientX','domain_transfer_start get_info(reID)'); $d=$dri->get_info('reDate'); isa_ok($d,'DateTime','domain_transfer_start get_info(reDate)'); is("".$d,'2000-06-08T22:00:00','domain_transfer_start get_info(reDate) value'); is($dri->get_info('acID'),'ClientY','domain_transfer_start get_info(acID)'); $d=$dri->get_info('acDate'); isa_ok($d,'DateTime','domain_transfer_start get_info(acDate)'); is("".$d,'2000-06-13T22:00:00','domain_transfer_start get_info(acDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_transfer_start get_info(exDate)'); is("".$d,'2002-09-08T22:00:00','domain_transfer_start get_info(exDate) value'); $R2=''; $toc=$dri->local_object('changes'); $toc->add('ns',$dri->local_object('hosts')->set('ns2.example.com')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('mak21'),'tech'); $toc->add('contact',$cs); $toc->add('status',$dri->local_object('status')->no('publish','Payment overdue.')); $toc->del('ns',$dri->local_object('hosts')->set('ns1.example.com')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('sh8013'),'tech'); $toc->del('contact',$cs); $toc->del('status',$dri->local_object('status')->no('update')); $toc->set('registrant',$dri->local_object('contact')->srid('sh8013')); $toc->set('auth',{pw=>'2BARfoo'}); $rc=$dri->domain_update('example206.com',$toc); is($R1,$E1.'example206.comns2.example.commak21Payment overdue.ns1.example.comsh8013sh80132BARfooABC-12345'.$E2,'domain_update build'); is($rc->is_success(),1,'domain_update is_success'); ################################################################################################################## ## Host commands $R2=$E1.''.r().'ns2.example2.comIn use'.$TRID.''.$E2; $rc=$dri->host_check('ns2.example2.com'); is($R1,$E1.'ns2.example2.comABC-12345'.$E2,'host_check build'); is($dri->get_info('action'),'check','host_check get_info(action)'); is($dri->get_info('exist'),1,'host_check get_info(exist)'); is($dri->get_info('exist','host','ns2.example2.com'),1,'host_check get_info(exist) from cache'); is($dri->get_info('exist_reason'),'In use','host_check reason'); $R2=$E1.''.r().'ns10.example2.comns20.example2.comIn usens30.example2.com'.$TRID.''.$E2; $rc=$dri->host_check_multi('ns10.example2.com','ns20.example2.com','ns30.example2.com'); is($R1,$E1.'ns10.example2.comns20.example2.comns30.example2.comABC-12345'.$E2,'host_check_multi build'); is($rc->is_success(),1,'host_check_multi is_success'); is($dri->get_info('exist','host','ns10.example2.com'),0,'host_check_multi get_info(exist) 1/3'); is($dri->get_info('exist','host','ns20.example2.com'),1,'host_check_multi get_info(exist) 2/3'); is($dri->get_info('exist_reason','host',,'ns20.example2.com'),'In use','host_check_multi get_info(exist_reason)'); is($dri->get_info('exist','host','ns30.example2.com'),0,'host_check_multi get_info(exist) 3/3'); $R2=$E1.''.r().'ns100.example2.comNS1_EXAMPLE1-REP193.0.2.2193.0.2.292000:0:0:0:8:800:200C:417AClientYClientX1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2000-04-08T09:00:00.0Z'.$TRID.''.$E2; $rc=$dri->host_info('ns100.example2.com'); is($R1,$E1.'ns100.example2.comABC-12345'.$E2,'host_info build'); is($dri->get_info('action'),'info','host_info get_info(action)'); is($dri->get_info('exist'),1,'host_info get_info(exist)'); is($dri->get_info('roid'),'NS1_EXAMPLE1-REP','host_info get_info(roid)'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','host_info get_info(status)'); is_deeply([$s->list_status()],['clientUpdateProhibited','linked'],'host_info get_info(status) list'); is($s->is_linked(),1,'host_info get_info(status) is_linked'); is($s->can_update(),0,'host_info get_info(status) can_update'); $s=$dri->get_info('self'); isa_ok($s,'Net::DRI::Data::Hosts','host_info get_info(self)'); my ($name,$ip4,$ip6)=$s->get_details(1); is($name,'ns100.example2.com','host_info self name'); is_deeply($ip4,['193.0.2.2','193.0.2.29'],'host_info self ip4'); is_deeply($ip6,['2000:0:0:0:8:800:200C:417A'],'host_info self ip6'); is($dri->get_info('clID'),'ClientY','host_info get_info(clID)'); is($dri->get_info('crID'),'ClientX','host_info get_info(crID)'); is($dri->get_info('upID'),'ClientX','host_info get_info(upID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','host_info get_info(crDate)'); is($d.'','1999-04-03T22:00:00','host_info get_info(crDate) value'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','host_info get_info(upDate)'); is($d.'','1999-12-03T09:00:00','host_info get_info(upDate) value'); $d=$dri->get_info('trDate'); isa_ok($d,'DateTime','host_info get_info(trDate)'); is($d.'','2000-04-08T09:00:00','host_info get_info(trDate) value'); $R2=$E1.''.r().'ns101.example1.com1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->host_create($dri->local_object('hosts')->add('ns101.example1.com',['193.0.2.2','193.0.2.29'],['2000:0:0:0:8:800:200C:417A'])); is($R1,$E1.'ns101.example1.com193.0.2.2193.0.2.292000:0:0:0:8:800:200C:417AABC-12345'.$E2,'host_create build'); is($dri->get_info('action'),'create','host_create get_info(action)'); is($dri->get_info('exist'),1,'host_create get_info(exist)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','host_create get_info(crDate)'); is($d.'','1999-04-03T22:00:00','host_create get_info(crDate) value'); $R2=$E1.''.r().$TRID.''.$E2; $rc=$dri->host_delete('ns102.example1.com'); is($R1,$E1.'ns102.example1.comABC-12345'.$E2,'host_delete build'); is($rc->is_success(),1,'host_delete is_success'); $R2=$E1.''.r().$TRID.''.$E2; my $toc=$dri->local_object('changes'); $toc->add('ip',$dri->local_object('hosts')->add('ns1.example1.com',['193.0.2.22'],[])); $toc->add('status',$dri->local_object('status')->no('update')); $toc->del('ip',$dri->local_object('hosts')->add('ns1.example1.com',[],['2000:0:0:0:8:800:200C:417A'])); $toc->set('name','ns104.example2.com'); $rc=$dri->host_update('ns103.example1.com',$toc); is($R1,$E1.'ns103.example1.com193.0.2.222000:0:0:0:8:800:200C:417Ans104.example2.comABC-12345'.$E2,'host_update build'); is($rc->is_success(),1,'host_update is_success'); ######################################################################################################### ## Contact commands my $co; $R2=$E1.''.r().'sh8000'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('sh8000'); #->auth({pw=>'2fooBAR'}); $rc=$dri->contact_check($co); is($R1,$E1.'sh8000ABC-12345'.$E2,'contact_check build'); is($rc->is_success(),1,'contact_check is_success'); is($dri->get_info('action'),'check','contact_check get_info(action)'); is($dri->get_info('exist'),0,'contact_check get_info(exist)'); is($dri->get_info('exist','contact','sh8000'),0,'contact_check get_info(exist) from cache'); $R2=$E1.''.r().'sh8001sh8002In usesh8003'.$TRID.''.$E2; $rc=$dri->contact_check_multi(map { $dri->local_object('contact')->srid($_) } ('sh8001','sh8002','sh8003')); is($R1,$E1.'sh8001sh8002sh8003ABC-12345'.$E2,'contact_check_multi build'); is($rc->is_success(),1,'contact_check_multi is_success'); is($dri->get_info('exist','contact','sh8001'),0,'contact_check_multi get_info(exist) 1/3'); is($dri->get_info('exist','contact','sh8002'),1,'contact_check_multi get_info(exist) 2/3'); is($dri->get_info('exist_reason','contact','sh8002'),'In use','contact_check_multi get_info(exist_reason)'); is($dri->get_info('exist','contact','sh8003'),0,'contact_check_multi get_info(exist) 3/3'); $R2=$E1.''.r().'sh8013SH8013-REPJohn DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+1.7035555555+1.7035555556jdoe@example.comClientYClientX1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('sh8013')->auth({pw=>'2fooBAR'}); $rc=$dri->contact_info($co); is($R1,$E1.'sh80132fooBARABC-12345'.$E2,'contact_info build'); is($rc->is_success(),1,'contact_info is_success'); is($dri->get_info('action'),'info','contact_info get_info(action)'); is($dri->get_info('exist'),1,'contact_info get_info(exist)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::Contact','contact_info get_info(self)'); is($co->srid(),'sh8013','contact_info get_info(self) srid'); is($co->roid(),'SH8013-REP','contact_info get_info(self) roid'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','contact_info get_info(status)'); is_deeply([$s->list_status()],['clientDeleteProhibited','linked'],'contact_info get_info(status) list_status'); is($s->can_delete(),0,'contact_info get_info(status) can_delete'); is($co->name(),'John Doe','contact_info get_info(self) name'); is($co->org(),'Example Inc.','contact_info get_info(self) org'); is_deeply($co->street(),['123 Example Dr.','Suite 100'],'contact_info get_info(self) street'); is($co->city(),'Dulles','contact_info get_info(self) city'); is($co->sp(),'VA','contact_info get_info(self) sp'); is($co->pc(),'20166-6503','contact_info get_info(self) pc'); is($co->cc(),'US','contact_info get_info(self) cc'); is($co->voice(),'+1.7035555555x1234','contact_info get_info(self) voice'); is($co->fax(),'+1.7035555556','contact_info get_info(self) fax'); is($co->email(),'jdoe@example.com','contact_info get_info(self) email'); is($dri->get_info('clID'),'ClientY','contact_info get_info(clID)'); is($dri->get_info('crID'),'ClientX','contact_info get_info(crID)'), $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','contact_info get_info(crDate)'); is("".$d,'1999-04-03T22:00:00','contact_info get_info(crDate) value'); is($dri->get_info('upID'),'ClientX','contact_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','contact_info get_info(upDate)'); is("".$d,'1999-12-03T09:00:00','contact_info get_info(upDate) value'); $d=$dri->get_info('trDate'); isa_ok($d,'DateTime','contact_info get_info(trDate)'); is("".$d,'2000-04-08T09:00:00','contact_info get_info(trDate) value'); is_deeply($co->auth(),{pw=>'2fooBAR'},'contact_info get_info(self) auth'); is_deeply($co->disclose(),{voice=>0,email=>0},'contact_info get_info(self) disclose'); $R2=$E1.''.r().'sh8014pendingClientX2000-06-06T22:00:00.0ZClientY2000-06-11T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('sh8014')->auth({pw=>'2fooBAR'}); $rc=$dri->contact_transfer_query($co); is($R1,$E1.'sh80142fooBARABC-12345'.$E2,'contact_transfer_query build'); is($rc->is_success(),1,'contact_transfer_query is_success'); is($dri->get_info('action'),'transfer','contact_transfer_query get_info(action)'); is($dri->get_info('exist'),1,'contact_transfer_query get_info(action)'); is($dri->get_info('trStatus'),'pending','contact_transfer_query get_info(trStatus)'); is($dri->get_info('reID'),'ClientX','contact_transfer_query get_info(reID)'); $d=$dri->get_info('reDate'); isa_ok($d,'DateTime','contact_transfer_query get_info(reDate)'); is("".$d,'2000-06-06T22:00:00','contact_transfer_query get_info(reDate) value'); is($dri->get_info('acID'),'ClientY','contact_transfer_query get_info(acID)'); $d=$dri->get_info('acDate'); isa_ok($d,'DateTime','contact_transfer_query get_info(acDate)'); is("".$d,'2000-06-11T22:00:00','contact_transfer_query get_info(acDate) value'); $R2=$E1.''.r().'sh80151999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('sh8015'); $co->name('John Doe'); $co->org('Example Inc.'); $co->street(['123 Example Dr.','Suite 100']); $co->city('Dulles'); $co->sp('VA'); $co->pc('20166-6503'); $co->cc('US'); $co->voice('+1.7035555555x1234'); $co->fax('+1.7035555556'); $co->email('jdoe@example.com'); $co->auth({pw=>'2fooBAR'}); $co->disclose({voice=>0,email=>0}); $rc=$dri->contact_create($co); is_string($R1,$E1.'sh8015John DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+1.7035555555+1.7035555556jdoe@example.com2fooBARABC-12345'.$E2,'contact_create build'); is($rc->is_success(),1,'contact_create is_success'); is($dri->get_info('action'),'create','contact_create get_info(action)'); is($dri->get_info('exist'),1,'contact_create get_info(exist)'); ## Some registries do not permit the registrar to set the contact:id, and will just set one ## Here is how to deal with this case ## Note that contact:id is mandatory in EPP, and hence we will always send one, ## this is handled transparently by Contact::*::init() $R2=$E1.''.r().'NEWREGID1999-04-03T22:00:00.0Z'.$TRID.''.$E2; $co->srid('sh8015'); $rc=$dri->contact_create($co); is($dri->get_info('id'),'NEWREGID','contact_create with registry contact:id get_info(id)'); is($dri->get_info('exist'),undef,'contact_create with registry contact:id get_info(exist)'); is($dri->get_info('id','contact','NEWREGID'),'NEWREGID','contact_create with registry contact:id get_info(NEWREGID,id)'); is($dri->get_info('exist','contact','NEWREGID'),1,'contact_create with registry contact:id get_info(NEWREGID,exist)'); $R2=''; $co=$dri->local_object('contact')->srid('sh8016')->auth({pw=>'2fooBAR'}); $rc=$dri->contact_delete($co); is($R1,$E1.'sh8016ABC-12345'.$E2,'contact_delete build'); is($rc->is_success(),1,'contact_delete is_success'); $co=$dri->local_object('contact')->srid('sh8017')->auth({pw=>'2fooBAR'}); $R2=$E1.''.r().'sh8017pendingClientX2000-06-08T22:00:00.0ZClientY2000-06-13T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->contact_transfer_start($co); is($R1,$E1.'sh80172fooBARABC-12345'.$E2,'contact_transfer_start build'); is($rc->is_success(),1,'contact_transfer_start is_success'); is($dri->get_info('action'),'transfer','contact_transfer_start get_info(action)'); is($dri->get_info('exist'),1,'contact_transfer_start get_info(exist)'); is($dri->get_info('trStatus'),'pending','contact_transfer_start get_info(trStatus)'); is($dri->get_info('reID'),'ClientX','contact_transfer_start get_info(reID)'); $d=$dri->get_info('reDate'); isa_ok($d,'DateTime','contact_transfer_start get_info(reDate)'); is("".$d,'2000-06-08T22:00:00','contact_transfer_start get_info(reDate) value'); is($dri->get_info('acID'),'ClientY','contact_transfer_start get_info(acID)'); $d=$dri->get_info('acDate'); isa_ok($d,'DateTime','contact_transfer_start get_info(acDate)'); is("".$d,'2000-06-13T22:00:00','contact_transfer_start get_info(acDate) value'); $R2=''; $co=$dri->local_object('contact')->srid('sh8018')->auth({pw=>'2fooBAR'}); $toc=$dri->local_object('changes'); $toc->add('status',$dri->local_object('status')->no('delete')); my $co2=$dri->local_object('contact'); $co2->org(''); $co2->street(['124 Example Dr.','Suite 200']); $co2->city('Dulles'); $co2->sp('VA'); $co2->pc('20166-6503'); $co2->cc('US'); $co2->voice('+1.7034444444'); $co2->fax(''); $co2->auth({pw=>'2fooBAR'}); $co2->disclose({voice=>1,email=>1}); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'sh8018124 Example Dr.Suite 200DullesVA20166-6503US+1.70344444442fooBARABC-12345'.$E2,'contact_update build'); is($rc->is_success(),1,'contact_update is_success'); ## Session commands $R2=''; $rc=$dri->process('session','noop',[]); is($R1,$E1.''.$E2,'session noop build'); is($rc->is_success(),1,'session noop is_success'); $R2=$E1.''.r(1500).$TRID.''.$E2; $rc=$dri->process('session','logout',[]); is($R1,$E1.'ABC-12345'.$E2,'session logout build'); is($rc->is_success(),1,'session logout is_success'); $R2=$E1.'Example EPP server epp.example.com2000-06-08T22:00:00.0Z1.0enfrurn:ietf:params:xml:ns:obj1urn:ietf:params:xml:ns:obj2urn:ietf:params:xml:ns:obj3http://custom/obj1ext-1.0'.$E2; $rc=$dri->process('session','connect',[]); is($R1,$E1.''.$E2,'session connect build (hello command)'); is($rc->is_success(),1,'session connect is_success'); is_deeply($dri->protocol->server_greeting(),{svID=>'Example EPP server epp.example.com',svDate=>'2000-06-08T22:00:00.0Z',version=>['1.0'],lang=>['en','fr'],svcext=>['http://custom/obj1ext-1.0'],svcs=>['urn:ietf:params:xml:ns:obj1','urn:ietf:params:xml:ns:obj2','urn:ietf:params:xml:ns:obj3'],dcp=>''},'session connect server_greeting parse'); $R2=''; $rc=$dri->process('session','login',['ClientX','foo-BAR2','bar-FOO2']); is($R1,$E1.'ClientXfoo-BAR2bar-FOO21.0enurn:ietf:params:xml:ns:obj1urn:ietf:params:xml:ns:obj2urn:ietf:params:xml:ns:obj3http://custom/obj1ext-1.0ABC-12345'.$E2,'session login build'); is($rc->is_success(),1,'session login is_success'); #################################################################################################### ## Registry Messages ## Get information on pending messages with reply to any command $R2=$E1.''.r().'example33.com'.$TRID.''.$E2; $rc=$dri->domain_check('example33.com'); is($dri->get_info('count','message','info'),5,'message count'); is($dri->get_info('id','message','info'),12345,'message id'); is($dri->message_count(),5,'direct message count'); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'1999-04-04T22:01:00.0ZPending action completed successfully.example.comABC-1234554321-XYZ1999-04-04T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info last_id 1'); is($dri->get_info('last_id','message','session'),12345,'message get_info last_id 2'); is($dri->get_info('id','message',12345),12345,'message get_info id'); is(''.$dri->get_info('qdate','message',12345),'1999-04-04T22:01:00','message get_info qdate'); is($dri->get_info('content','message',12345),'Pending action completed successfully.','message get_info msg'); is($dri->get_info('lang','message',12345),'en','message get_info lang'); is($dri->get_info('object_type','message','12345'),'domain','message get_info object_type'); is($dri->get_info('object_id','message','12345'),'example.com','message get_info id'); is($dri->get_info('action','message','12345'),'review','message get_info action'); ## with this, we know what action has triggered this delayed message is($dri->get_info('result','message','12345'),1,'message get_info result'); is($dri->get_info('trid','message','12345'),'ABC-12345','message get_info trid'); is($dri->get_info('svtrid','message','12345'),'54321-XYZ','message get_info svtrid'); is(''.$dri->get_info('date','message','12345'),'1999-04-04T22:00:00','message get_info date'); is($dri->message_waiting(),1,'message_waiting'); is($dri->message_count(),5,'message_count'); $R2=$E1.''.r(1300,'Command completed successfully; no messages').$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),undef,'message get_info last_id (no message)'); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2006-09-25T09:09:11.0ZCome to the registry office for some beer on friday'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),2,'message get_info last_id (pure text message)'); is($dri->message_count(),1,'message_count (pure text message)'); is(''.$dri->get_info('qdate','message',2),'2006-09-25T09:09:11','message get_info qdate (pure text message)'); is($dri->get_info('content','message',2),'Come to the registry office for some beer on friday','message get_info msg (pure text message)'); is($dri->get_info('lang','message',2),'en','message get_info lang (pure text message)'); ## RT#41032 : message IDs are XML token type, not digits only $R2=''; $rc=$dri->message_delete('ABZ32'); is($rc->is_success(),1,'RT41032 message_delete with non numeric message id'); #################################################################################################### ## Uppercases/Lowercases my @ul=qw/ab.com ab.com cd.com CD.com EF.com ef.com GH.com GH.com/; my $c=0; while(@ul) { $c++; my $reg=shift(@ul); ## registry reply my $cmd=shift(@ul); ## our command $R2=$E1.''.r().''.$reg.'EXAMPLE'.$c.'-REPjd1234sh8013sh8013ns1.example.comns1.example.netns1.example.comns2.example.comClientXClientY1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR'.$TRID.''.$E2; $rc=$dri->domain_info($cmd,{auth=>{pw=>'2fooBAR'}}); is_string($R1,$E1.''.$cmd.'2fooBARABC-12345'.$E2,"UL case $c command build"); is($rc->get_data('roid'),"EXAMPLE$c-REP","UL case $c get_data short"); is($rc->get_data('domain',lc($cmd),'roid'),"EXAMPLE$c-REP","UL case $c get_data long lc"); is($rc->get_data('domain',uc($cmd),'roid'),"EXAMPLE$c-REP","UL case $c get_data long uc"); is($dri->get_info('roid'),"EXAMPLE$c-REP","UL case $c get_info short"); is($dri->get_info('roid','domain',lc($cmd)),"EXAMPLE$c-REP","UL case $c get_data long lc"); is($dri->get_info('roid','domain',uc($cmd)),"EXAMPLE$c-REP","UL case $c get_data long uc"); } exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/641sidn_epp.t0000755000175000017500000002734111352025716015166 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 19; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our ($R1,$R2); sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1;} sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('SIDN'); $dri->target('SIDN')->add_current_profile('p1','test=Net::DRI::Protocol::EPP::Extensions::SIDN',{f_send=>\&mysend,f_recv=>\&myrecv}); print $@->as_string() if $@; my ($rc,$co,$h,$toc); #################################################################################################### ## Error messages $R2=$E1.''.r(2400,'Validation of the transaction failed.').'De deelnemer heeft niet de status \'Active\'.'.$TRID.''.$E2; $rc=$dri->domain_check('whatever.nl'); is($rc->is_success(),0,'error is_success'); is($rc->code(),2400,'error code'); is_deeply([$rc->get_extended_results()],[{from=>'sidn',type=>'text',message=>"De deelnemer heeft niet de status 'Active'.",field=>'deelnemernummer',code=>'C0013'}],'error parsing 1'); $R2=$E1.''.r(2303,' The specified contact person is unknown.').'Waarde voldoet niet aan de expressie: [A-Z]{3}[0-9]{6}[-][A-Z0-9]{5}.De opgegeven handle is onbekend.'.$TRID.''.$E2; $rc=$dri->domain_check('whatever2.nl'); is_deeply([$rc->get_extended_results()],[{from=>'sidn',type=>'text',message=>'Waarde voldoet niet aan de expressie: [A-Z]{3}[0-9]{6}[-][A-Z0-9]{5}.',field=>'handle',code=>'F0001'},{from=>'sidn',type=>'text',message=>'De opgegeven handle is onbekend.',field=>'handle',code=>'T0002'}],'error parsing 2'); #################################################################################################### ## Domain commands $R2=$E1.''.r().'doris.nlDNM_700-SIDNTES000079-SL1SLTES000079-SO1SOTES000079-SL1SLns1.doris.nlns2.doris.nlns3.doris.nlns4.doris.nlns1.doris.nlSIDN0SIDN02009-08-10T00:00:00.000+02:00SIDN02009-08-10T00:00:00.000+02:002010-08-12T00:00:00.000+02:00token4556falsefalse'.$TRID.''.$E2; $rc=$dri->domain_info('doris.nl'); is($rc->get_data('opt_out'),0,'domain_info opt_out'); is($rc->get_data('limited'),0,'domain_info limited'); $R2=''; $rc=$dri->domain_undelete('DOMAINdelete37.nl'); is_string($R1,$E1.'DOMAINdelete37.nlABC-12345'.$E2,'domain_undelete build'); #################################################################################################### ## Contact commands $R2=$E1.''.r().'TST000033-DEMEECPN_100134-SIDNlinked, limited, pendingUpdateJan OttenHoofdstraat 126Eindhoven4444EENL+31.0612345678otten@sidn.nl400100DEMEE2009-01-02T00:00:00.000+01:00EENMANSZAAK8764654.0true'.$TRID.''.$E2; $rc=$dri->contact_info($dri->local_object('contact')->srid('TST000033-DEMEE')); $co=$rc->get_data('self'); is($co->legal_form(),'EENMANSZAAK','contact_info legal_form'); is($co->legal_id(),'8764654.0','contact_info legal_id'); is($co->limited(),1,'contact_info limited'); $co=$dri->local_object('contact')->srid('sh8013'); $co->name('Harry Jansen'); $co->org('De Klusjeman BV'); $co->street(['IJsselkade','100']); $co->city('Amsterdam'); $co->sp('Limburg'); $co->pc('1234AA'); $co->cc('NL'); $co->voice('+31.612345678'); $co->fax('+31.204578274'); $co->email('epptestteam@sidn.nl'); $co->auth({pw => '2fooBAR'}); $co->disclose({voice => 0,email => 0}); $co->legal_form('EENMANSZAAK'); $co->legal_id('8764654.0'); $R2=''; $rc=$dri->contact_create($co); is_string($R1,$E1.'sh8013Harry JansenDe Klusjeman BVIJsselkade100AmsterdamLimburg1234AANL+31.612345678+31.204578274epptestteam@sidn.nl2fooBAREENMANSZAAK8764654.0ABC-12345'.$E2,'contact_create build'); $R2=''; $co=$dri->local_object('contact')->srid('TEA000031-GOEDA'); $co->name('Herman Jansen'); $co->org('SIDN'); $co->street(['Street 1','Street 2','Street 3']); $co->city('Arnhem'); $co->pc('1000AA'); $co->cc('NL'); $co->voice('+31.207654321'); $co->fax('+31.201234567'); $co->email('herman@epptestdomein.nl'); $co->legal_form('PERSOON'); $toc=$dri->local_object('changes'); $toc->set('info',$co); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'TEA000031-GOEDAHerman JansenSIDNStreet 1Street 2Street 3Arnhem1000AANL+31.207654321+31.201234567herman@epptestdomein.nlPERSOONABC-12345'.$E2,'contact_update build'); #################################################################################################### ## Host commands $R2=$E1.''.r().'ns1.domain100.nlNSR_100-SIDN1.2.3.01000001000002009-06-10T00:00:00.000+02:001000002009-06-12T00:00:00.000+02:00false'.$TRID.''.$E2; $rc=$dri->host_info('ns1.domain100.nl'); $h=$rc->get_data('self'); @c=$h->get_details(1); is_deeply($c[-1],{limited => 0},'host_info parse limited'); #################################################################################################### ## Notifications $R2=$E1.''.r(1301,'The message has been picked up. Please confirm receipt to remove the message from the queue.').'2009-10-27T10:34:32.000Z1202 Change to name server ns1.bol.nl processedhost:updateThe name server has been changed after consideration.TestWZNMC10T50100012'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($rc->get_data('message',100000,'command'),'host_update','notification host:update command'); is($rc->get_data('message',100000,'object_type'),'host','notification host:update object_type'); is($rc->get_data('message',100000,'result_code'),'1000','notification host:update result_code'); is($rc->get_data('message',100000,'result_msg'),'The name server has been changed after consideration.','notification host:update result_msg'); is($rc->get_data('message',100000,'trid'),'TestWZNMC10T50','notification host:update cltrid'); is($rc->get_data('message',100000,'svtrid'),'100012','notification host:update svtrid'); exit 0; Net-DRI-0.96/t/639opensrs_xcp.t0000755000175000017500000010321411241335132015722 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use DateTime; use Test::More tests => 45; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our (@R1,@R2); sub mysend { my ($transport,$count,$msg)=@_; push @R1,$msg->get_body(); return 1;} sub myrecv { return Net::DRI::Data::Raw->new_from_string(shift(@R2)); } sub munge { my $in=shift; $in=~s/>\s*new(10); $dri->add_registry('OpenSRS'); $dri->target('OpenSRS')->add_current_profile('p1','test=Net::DRI::Protocol::OpenSRS::XCP',{f_send=>\&mysend,f_recv=>\&myrecv,client_login=>'LOGIN',client_password=>'PASSWORD',remote_url=>'http://localhost/'}); my ($r,$rc,$rd,$ns,$cs); push @R2,<<'EOF';
0.9
XCP REPLY DOMAIN 1 Command successful 200 1 2 0 N katarina.biz 2007-12-18 23:59:59 N kristina.cn 2007-12-18 23:59:59 N N
EOF my $yday=DateTime->from_epoch(epoch => time()-60*60*24)->strftime('%F'); $r=<<"EOF";
0.9
get_domains_by_expiredate domain XCP $yday 2030-01-01 1000000
EOF $rc=$dri->account_list_domains(); is_string(munge(shift(@R1)),munge($r),'account_list_domains build'); is($rc->is_success(),1,'account_list_domains is_success'); $rd=$dri->get_info('list','account','domains'); is_deeply($rd,['katarina.biz','kristina.cn'],'account_list_domains get_info(list,account,domains)'); push @R2,<<'EOF';
0.9
XCP REPLY COOKIE Command Successful 1 200 0 24128866:3210384 131 1 1082751795 10.0.11.215 2007-11-25 00:00:00
EOF push @R2,<<'EOF';
0.9
XCP REPLY DOMAIN 1 200 Query Successful 0 2006-12-12 21:27:25 2007-12-12 21:27:25 2006-12-12 21:27:25 1 2007-12-12 21:27:25 0 Owen Owner +1.4165550123x1902 +1.4165550124 owner@catmas.com Catmas Inc. 32 Catmas Street Suite 500 Owner SomeCity CA US 90210 http://www.catmas.com Adler Admin +1.4165550123x1812 +1.4165550125 admin@catmas.com Catmas Inc. 32 Catmas Street Suite 100 Admin SomeCity CA US 90210 http://www.catmas.com Bill Billing +1.4165550123x1248 +1.4165550136 billing@catmas.com Catmas Inc. 32 Catmas Street Suite 200 Billing SomeCity CA US 90210 http://www.catmas.com Tim Tech +1.4165550123x1243 +1.4165550125 techie@catmas.com Catmas Inc. 32 Catmas Street Suite 100 Tech SomeCity CA US 90210 http://www.catmas.com 21.40.33.21 1 ns1.domaindirect.com 207.136.100.142 2 ns2.domaindirect.com 24.22.23.28 3 patrick.mytestingprofile.com 24.22.23.24 4 qa1.mytestingprofile.com 24.22.23.25 5 qa2.mytestingprofile.com
EOF $rc=$dri->domain_info('whatever.com',{username => 'aaaa', password => 'aaaa', registrant_ip => '216.40.46.115'}); is($rc->is_success(),1,'domain_info is_success'); $r=<<'EOF';
0.9
set cookie XCP 216.40.46.115 whatever.com aaaa aaaa
EOF is_string(munge(shift(@R1)),munge($r),'domain_info build 1/2'); $r=<<'EOF';
0.9
get 24128866:3210384 domain XCP 216.40.46.115 all_info
EOF is_string(munge(shift(@R1)),munge($r),'domain_info build 2/2'); is($dri->get_info('value','session','cookie'),'24128866:3210384','domain_info set_cookie value'); is($dri->get_info('auto_renew'),0,'domain_info get_info(auto_renew)'); is($dri->get_info('sponsoring_rsp'),1,'domain_info get_info(sponsoring_rsp)'); is($dri->get_info('let_expire'),0,'domain_info get_info(let_expire)'); is(''.$dri->get_info('crDate'),'2006-12-12T21:27:25','domain_info get_info(crDate)'); is(''.$dri->get_info('exDate'),'2007-12-12T21:27:25','domain_info get_info(exDate)'); is(''.$dri->get_info('upDate'),'2006-12-12T21:27:25','domain_info get_info(upDate)'); is(''.$dri->get_info('exDateLocal'),'2007-12-12T21:27:25','domain_info get_info(exDateLocal)'); $ns=$dri->get_info('ns'); is($ns->count(),5,'domain_info get_info(ns) count'); is_deeply([$ns->get_names()],[qw/ns1.domaindirect.com ns2.domaindirect.com patrick.mytestingprofile.com qa1.mytestingprofile.com qa2.mytestingprofile.com/],'domain_info get_info(ns) get_names'); $cs=$dri->get_info('contact'); is($cs->get('registrant')->firstname(),'Owen','domain_info get_info(contact) get(registrant) firstname'); is($cs->get('registrant')->name(),'Owner','domain_info get_info(contact) get(registrant) name'); is($cs->get('admin')->email(),'admin@catmas.com','domain_info get_info(contact) get(admin) email'); is($cs->get('billing')->cc(),'US','domain_info get_info(contact) get(billing) cc'); is($cs->get('tech')->city(),'SomeCity','domain_info get_info(contact) get(tech) city'); #===Contact sets to test registration=================================== my $admin_co=<<'EOF'; 32 Catmas Street Suite 100 Admin SomeCity US admin@example.com +1.4165550125 Adler Admin Catmas Inc. +1.4165550123x1812 90210 CA http://www.catmas.com EOF my $defcs=<<"EOF"; $admin_co Bill Billing +1.4165550123x1248 +1.4165550136 billing\@example.com Catmas Inc. 32 Catmas Street Suite 200 Billing SomeCity CA US 90210 http://www.catmas.com Owen Owner +1.4165550123x1902 +1.4165550124 owner\@example.com Catmas Inc. 32 Catmas Street Suite 500 Owner SomeCity CA US 90210 http://www.catmas.com Tim Tech +1.4165550123x1243 +1.4165550125 techie\@example.com Catmas Inc. 32 Catmas Street Suite 100 Tech SomeCity CA US 90210 http://www.catmas.com EOF #===Test registration with default name servers=================================== push @R2,<<'EOF';
0.9
XCP REPLY DOMAIN 1 200 Domain registration successfully completed. WHOIS Privacy service cannot be applied to your account. Please contact X for more information. Domain successfully locked. Domain registration successfully completed. WHOIS Privacy service cannot be applied to your account. Please contact X for more information. Domain successfully locked. 200 3735281 3764860 3764861 jsmith@catmas.com WHOIS_Privacy service cannot be applied to your account. Please contact X for more information. 300 0
EOF $cs=$dri->local_object('contactset'); my $co=$dri->local_object('contact'); $co->srid('daniel'); # Portfolio user name for OpenSRS? $co->auth('daniel'); # Portfolio password for OpenSRS? $co->name('Admin'); # Should be firstname, name => lastname. $co->firstname('Adler'); $co->org('Catmas Inc.'); $co->street(['32 Catmas Street','Suite 100','Admin']); $co->city('SomeCity'); $co->sp('CA'); $co->pc('90210'); $co->cc('US'); $co->voice('+1.4165550123x1812'); $co->fax('+1.4165550125'); $co->email('admin@example.com'); $co->url('http://www.catmas.com'); $cs->set($co,'registrant'); $cs->set($co,'admin'); $cs->set($co,'billing'); $r=<<"EOF";
0.9
sw_register domain XCP 10.0.10.19 $admin_co $admin_co $admin_co 0 0 example-nsi.net 10 daniel new daniel
EOF $rc=$dri->domain_create('example-nsi.net',{username => 'daniel', password => 'daniel', contact => $cs, registrant_ip => '10.0.10.19', pure_create => 1, duration => DateTime::Duration->new(years =>10)}); is_string(munge(shift(@R1)),munge($r),'domain_create (default name servers)'); is($rc->is_success(),1,'domain_create is_success (default name servers)'); #is($rc->native_code(),200,'domain_create native_code (default name servers)'); is($rc->code(),1000,'domain_create code (default name servers)'); is($dri->get_info('id'),3735281,'domain_create id'); #is($dri->get_info_keys(),'admin_email','domain_create response keys'); #is($dri->get_info('registration_code'),200,'domain_create get_info(registration_code)'); #is($dri->get_info('domain','example-nsi.net','admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); is($dri->get_info('admin_email'),'jsmith@catmas.com','domain_create get_info(admin_email)'); #===Test registration with default name servers=================================== push @R2,<<'EOF';
0.9
XCP REPLY DOMAIN 0 435 Request failed validation: Name server 'dns1.example.com' is not found at the registry. Please double check the nameserver and re-submit. Name server 'dns2.example.com' is not found at the registry. Please double check the nameserver and re-submit. Request failed validation: Name server 'dns1.example.com' is not found at the registry. Please double check the nameserver and re-submit. Name server 'dns2.example.com' is not found at the registry. Please double check the nameserver and re-submit. 435 3735283 3735283
EOF $r=<<"EOF";
0.9
sw_register domain XCP 216.40.46.115 $admin_co $admin_co $admin_co 1 0 yahoo.com ns1.domaindirect.com 1 ns2.domaindirect.com 2 7 daniel new daniel
EOF $ns=$dri->local_object('hosts'); $ns->add('ns1.domaindirect.com',['123.45.67.89']); $ns->add('ns2.domaindirect.com'); #SKIP: { # skip 'dt_array bug', 3; $rc=$dri->domain_create('yahoo.com',{username => 'daniel', password => 'daniel', contact => $cs, registrant_ip => '216.40.46.115', pure_create => 1, duration => DateTime::Duration->new(years =>7), ns => $ns}); is_string(munge(shift(@R1)),munge($r),'domain_create (custom name servers)'); is($rc->is_success(),0,'domain_create is_success (custom name servers)'); #is($dri->get_info('response_code'),435,'domain_create get_info(response_code)'); #is($dri->get_info('registration_code'),435,'domain_create get_info(registration_code)'); #}; #===Test renew=================================== #pop @R2; push @R2,<<'EOF';
0.9
XCP REPLY DOMAIN 2006-01-08 15:35:00 1 admin1@example.com 3212624 3511417 Command completed successfully 1 200
EOF $r=<<'EOF';
0.9
renew domain XCP 216.40.46.115 1 2009 example.com 5
EOF $rc=$dri->domain_renew('example.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', auto_renew => 1, duration => DateTime::Duration->new(years =>5), current_expiration => DateTime->new( year => 2009, month => 06, day => 27)}); is_string(munge(shift(@R1)),munge($r),'domain_renew'); is($rc->is_success(),1,'domain_renew is_success'); is($dri->get_info('admin_email'),'admin1@example.com','domain_renew get_info(admin_email)'); is(''.$dri->get_info('exDate'),'2006-01-08T15:35:00','domain_info get_info(exDate)'); #is($dri->get_info('registration expiration date'),'2006-12-07 00:00:00','domain_renew get_info(expiration date)'); #===Test revoke=================================== push @R2,<<'EOF';
0.9
XCP REPLY DOMAIN 1 0 undef Domain test.com revoked successfully. 200
EOF $r=<<"EOF";
0.9
revoke domain XCP 216.40.46.115 example.com $RESELLERID
EOF $rc=$dri->domain_delete('example.com',{pure_delete => 1, username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', reseller_id => $RESELLERID}); is_string(munge(shift(@R1)),munge($r),'domain_delete'); is($rc->is_success(),1,'domain_delete is_success'); is($dri->get_info('charge'),0,'domain_renew get_info(charge)'); #===Test transfer initiation=================================== push @R2,<<'EOF';
0.9
XCP REPLY DOMAIN 200 Transfer request has been successfully sent 1 Transfer request has been successfully sent 200 3735288
EOF $r=<<"EOF";
0.9
sw_register domain XCP 10.0.10.19 $admin_co $admin_co $admin_co 0 0 yahoo.com example transfer example
EOF $rc=$dri->domain_transfer_start('yahoo.com',{username => 'example', password => 'example', contact => $cs, registrant_ip => '10.0.10.19'}); is_string(munge(shift(@R1)),munge($r),'domain_transfer_start'); is($rc->is_success(),1,'domain_transfer_start is_success'); is($dri->get_info('id'),3735288,'domain_transfer_start get_info(id)'); #===Test transfer check=================================== push @R2,<<'EOF';
0.9
XCP REPLY DOMAIN 1 Query successful 200 pending_owner 0 Transfer in progress 1115213766 Wed May 4 09:36:06 2005
EOF $r=<<'EOF';
0.9
check_transfer domain XCP 216.40.46.115 1 catmas.com 1
EOF $rc=$dri->domain_transfer_query('catmas.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115'}); is_string(munge(shift(@R1)),munge($r),'domain_transfer_query'); is($rc->is_success(),1,'domain_transfer_query is_success'); is($dri->get_info('transferrable'),0,'domain_transfer_query get_info(transferrable)'); is($dri->get_info('reason'),'Transfer in progress','domain_transfer_query get_info(reason)'); is($dri->get_info('unixtime'),1115213766,'domain_transfer_query get_info(reason)'); #===Test transfer cancel=================================== push @R2,<<'EOF';
0.9
XCP REPLY TRANSFER Transfer with order id: 3533098 has been canceled. 1 200
EOF $r=<<"EOF";
0.9
cancel_transfer transfer XCP 216.40.46.115 example.com $RESELLERID
EOF $rc=$dri->domain_transfer_stop('example.com',{username => 'daniel', password => 'guessthis', registrant_ip => '216.40.46.115', reseller_id => $RESELLERID}); is_string(munge(shift(@R1)),munge($r),'domain_transfer_stop'); is($rc->is_success(),1,'domain_transfer_stop is_success'); exit 0; Net-DRI-0.96/t/003critic.t0000755000175000017500000000062510753730463014634 0ustar patrickpatrick#!/usr/bin/perl -w use strict; use warnings; use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Perl::Critic; }; if ($@) { my $msg='Test::Perl::Critic required to criticise code'; plan( skip_all => $msg ); } Test::Perl::Critic->import(-severity => 'gentle'); all_critic_ok(); Net-DRI-0.96/t/629asia_epp.t0000755000175000017500000003316011241325705015146 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Net::DRI::DRD::ICANN; use Test::More tests => 21; our $E1 = ''; our $E2 = ''; our $TRID = 'ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport, $count, $msg) = @_; $R1 = $msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2 ? $R2 : $E1 . '' . r() . $TRID . '' . $E2); } my $dri = Net::DRI->new(10); $dri->{trid_factory} = sub { return 'ABC-12345'; }; eval { $dri->add_registry('ASIA'); $dri->target('ASIA')->add_current_profile('p1', 'test=Net::DRI::Protocol::EPP::Extensions::ASIA', {f_send => \&mysend, f_recv => \&myrecv}); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } my $rc; my $s; my $d; my ($dh, @c); #################################################################################################### ## CED contact operations ## Contact create $R2 = $E1 . "Command completed successfully" . $TRID . '' . $E2; my $c = $dri->local_object('contact'); $c->srid('TL1-ASIA'); $c->name('Tonnerre Lombard'); $c->org('SyGroup GmbH'); $c->street(['Gueterstrasse 86']); $c->city('Basel'); $c->sp('BS'); $c->pc('4053'); $c->cc('CH'); $c->voice('+41.61338033'); $c->fax('+41.613831467'); $c->email('tonnerre.lombard@sygroup.ch'); $c->auth({pw => 'blablabla'}); $c->cedcc('IN'); $c->cedsp('Bengal'); $c->cedcity('Bangladesh'); $c->cedetype('legalPerson'); $c->cediform('passport'); $c->cedinum('24953w-4545'); eval { $rc = $dri->contact_create($c); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'contact create success'); unless ($rc->is_success()) { die('Error ' . $rc->code() . ': ' . $rc->message()); } is($R1, 'TL1-ASIATonnerre LombardSyGroup GmbHGueterstrasse 86BaselBS4053CH+41.61338033+41.613831467tonnerre.lombard@sygroup.chblablablaINBengalBangladeshlegalPersonpassport24953w-4545ABC-12345', 'contact create xml'); ## Contact query $R2 = $E1 . "Command completed successfullyJD1-ASIAC28909-ASIAJohn DoeExample Corp. Inc123 Example St.AnytownAny ProvA1A1A1FI+1.41565656566jdoe\@valid.asiadocumentdata1documentdata12007-10-18T09:31:04.0Zdocumentdata12007-10-18T09:32:58.0ZpasswordINBengalBangladeshcooperativepassport12-47-AB" . $TRID . '' . $E2; $c = $dri->local_object('contact'); $c->srid('JD1-ASIA'); eval { $rc = $dri->contact_info($c); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'contact query success'); unless ($rc->is_success()) { die('Error ' . $rc->code() . ': ' . $rc->message()); } $c = $dri->get_info('self', 'contact', 'JD1-ASIA'); is($c->srid(), 'JD1-ASIA', 'contact info srid'); is($c->cedcc(), 'IN', 'contact info cedcc'); is($c->cedsp(), 'Bengal', 'contact info cedsp'); is($c->cedcity(), 'Bangladesh', 'contact info cedcity'); is($c->cedetype(), 'cooperative', 'contact info cedetype'); is($c->cediform(), 'passport', 'contact info cediform'); is($c->cedinum(), '12-47-AB', 'contact info cedinum'); #################################################################################################### ## CED domain operations ## Domain create $R2 = $E1 . "Command completed successfully" . $TRID . '' . $E2; my $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('C1-ASIA'), 'registrant'); $cs->add($dri->local_object('contact')->srid('C2-ASIA'), 'admin'); $cs->add($dri->local_object('contact')->srid('C3-ASIA'), 'tech'); $cs->add($dri->local_object('contact')->srid('C4-ASIA'), 'billing'); $cs->add($dri->local_object('contact')->srid('C5-ASIA'), 'opn'); $cs->add($dri->local_object('contact')->srid('C6-ASIA'), 'ced'); $cs->add($dri->local_object('contact')->srid('C7-ASIA'), 'regAgent'); my $ns = $dri->local_object('hosts'); $ns->add('ns1.eppvalid.asia'); $ns->add('ns2.eppvalid.asia'); eval { $rc = $dri->domain_create('epptest.asia', { pure_create => 1, contact => $cs, ns => $ns, url => 'http://www.justgoogleit.com/', auth => { pw => 'bleblubleu' } }); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'domain create success'); is($R1, 'epptest.asians1.eppvalid.asians2.eppvalid.asiaC1-ASIAC2-ASIAC4-ASIAC3-ASIAbleblubleuhttp://www.justgoogleit.com/C6-ASIAC5-ASIAABC-12345', 'domain create xml'); $R2 = $E1 . "Command completed successfully" . $TRID . '' . $E2; $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('C7-ASIA'), 'opn'); $todo = $dri->local_object('changes'); $todo->set('contact', $cs); $todo->set('url', 'http://www.chezmoicamarche.com/'); eval { $rc = $dri->domain_update('epptest.asia', $todo); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'domain update success'); is($R1, 'epptest.asiahttp://www.chezmoicamarche.com/C7-ASIAABC-12345', 'domain update xml'); $R2 = $E1 . "Command completed successfully" . $TRID . '' . $E2; $todo = $dri->local_object('changes'); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('C5-ASIA'), 'opn'); $todo->set('contact', $cs); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('C8-ASIA'), 'tech'); $todo->add('contact', $cs); eval { $rc = $dri->domain_update('epptest.asia', $todo); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'domain update success'); is($R1, 'epptest.asiaC8-ASIAC5-ASIAABC-12345', 'domain update xml'); $R2 = $E1 . "Command completed successfullyepptest23.asiaU13423-ASIATL1-ASIATL1-ASIATL1-ASIAJD1-ASIAns1.eppvalid.asians2.eppvalid.asians3.eppvalid.asiaclient1client12007-11-09T08:48:08.0Zclient12008-04-28T09:45:15.0Z2012-11-09T08:48:08.0Zblablablahttp://www.justgoogleit.com/TL1-ASIAYY1-ASIAJD1-ASIA2007-11-092007-11-09" . $TRID . '' . $E2; eval { $rc = $dri->domain_info('epptest23.asia'); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'domain query success'); $cs = $dri->get_info('contact', 'domain', 'epptest23.asia'); is($cs->get('opn')->srid(), 'TL1-ASIA', 'domain contact opn'); is($cs->get('regAgent')->srid(), 'YY1-ASIA', 'domain contact regAgent'); is($cs->get('ced')->srid(), 'JD1-ASIA', 'domain contact ced'); is($dri->get_info('url', 'domain', 'epptest23.asia'), 'http://www.justgoogleit.com/', 'domain contact url'); exit 0; sub r { my ($c, $m) = @_; return '' . ($m || 'Command completed successfully') . ''; } Net-DRI-0.96/t/603vnds_epp_e164.t0000755000175000017500000001377511350046324015742 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 4; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; use Net::DRI::DRD::VNDS; { no strict; no warnings; sub Net::DRI::DRD::VNDS::tlds { return ('e164.arpa'); }; sub Net::DRI::DRD::VNDS::verify_name_domain { return ''; }; } $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['E164']}); my ($rc,$e,$toc); ######################################################################################################### ## Extension: E164 ## (see Erratum) $R2=$E1.''.r().'3.8.0.0.6.9.2.3.6.1.4.4.e164.arpaEXAMPLE1-REPjd1234sh8013sh8013ns1.example.comns2.example.comClientXClientY1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0Z2fooBAR10100uE2U+sip"!^.*$!sip:info@example.com!"10102uE2U+msg"!^.*$!mailto:info@example.com!"'.$TRID.''.$E2; $rc=$dri->domain_info('3.8.0.0.6.9.2.3.6.1.4.4.e164.arpa',{auth=>{pw=>'2fooBAR'}}); is($dri->get_info('exist'),1,'domain_info get_info(exist) +E164'); $e=$dri->get_info('e164'); is_deeply($e,[{order=>10,pref=>100,flags=>'u',svc=>'E2U+sip',regex=>'"!^.*$!sip:info@example.com!"'},{order=>10,pref=>102,flags=>'u',svc=>'E2U+msg',regex=>'"!^.*$!mailto:info@example.com!"'}],'domain_info get_info(e164) +E164'); $R2=''; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $rc=$dri->domain_create('3.8.0.0.6.9.2.3.6.1.4.4.e164.arpa',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns2.example.com']),contact=>$cs,auth=>{pw=>'2fooBAR'},e164=>[{order=>10,pref=>100,flags=>'u',svc=>'E2U+sip',regex=>'"!^.*$!sip:info@example.com!"'},{order=>10,pref=>102,flags=>'u',svc=>'E2U+msg',regex=>'"!^.*$!mailto:info@example.com!"'}]}); is($R1,$E1.'3.8.0.0.6.9.2.3.6.1.4.4.e164.arpa2ns1.example.comns2.example.comjd1234sh8013sh80132fooBAR10100uE2U+sip"!^.*$!sip:info@example.com!"10102uE2U+msg"!^.*$!mailto:info@example.com!"ABC-12345'.$E2,'domain_create build +E164'); $R2=''; $toc=$dri->local_object('changes'); $toc->del('e164',[{order=>10,pref=>102,flags=>'u',svc=>'E2U+msg',regex=>'"!^.*$!mailto:info@example.com!"'}]); $rc=$dri->domain_update('3.8.0.0.6.9.2.3.6.1.4.4.e164.arpa',$toc); is($R1,$E1.'3.8.0.0.6.9.2.3.6.1.4.4.e164.arpa10102uE2U+msg"!^.*$!mailto:info@example.com!"ABC-12345'.$E2,'domain_update build +E164'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/628de_rri.t0000755000175000017500000006317411241334270014635 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 77; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('DENIC'); $dri->target('DENIC')->add_current_profile('p1','test=RRI',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); #################################################################################################### ## Session Management $R2 = $E1 . '' . $TRID . 'success' . $E2; $rc = $dri->process('session', 'login', ['user','password']); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Login successful'); is($R1, 'userpasswordABC-12345', 'Login XML correct'); #################################################################################################### ## Contact Operations $R2 = $E1 . '' . $TRID . 'success' . 'DENIC-12345-BSPfree' . '' . $E2; $rc = $dri->contact_check($dri->local_object('contact')->srid('DENIC-12345-BSP')); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is(defined($rc) && $rc->is_success(), 1, 'Contact successfully checked'); is($R1, 'DENIC-12345-BSP', 'Check Contact XML correct'); is($dri->get_info('exist', 'contact', 'DENIC-12345-BSP'), 0, 'Contact does not exist'); $R2 = $E1 . '' . $TRID . 'success' . $E2; my $c = $dri->local_object('contact'); $c->srid('DENIC-99990-10240-BSP'); $c->type('PERSON'); $c->name('Theobald Tester'); $c->org('Test-Org'); $c->street(['Kleiner Dienstweg 17']); $c->pc('09538'); $c->city('Gipsnich'); $c->cc('DE'); $c->voice('+49.123456'); $c->fax('+49.123457'); $c->email('email@denic.de'); $c->sip('sip:benutzer@denic.de'); $rc = $dri->contact_create($c); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Contact successfully created'); is($R1, 'DENIC-99990-10240-BSPPERSONTheobald TesterTest-OrgKleiner Dienstweg 1709538GipsnichDE+49.123456+49.123457email@denic.desip:benutzer@denic.deABC-12345', 'Create Contact XML correct'); my $todo = $dri->local_object('changes'); $todo->set('info', $c); $rc = $dri->contact_update($c, $todo); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Contact successfully updated'); is($R1, 'DENIC-99990-10240-BSPPERSONTheobald TesterTest-OrgKleiner Dienstweg 1709538GipsnichDE+49.123456+49.123457email@denic.desip:benutzer@denic.deABC-12345', 'Update Contact XML correct'); $R2 = $E1 . '' . $TRID . 'successDENIC-99990-10240-BSPfailed' . $E2; $rc = $dri->contact_check($c); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is(defined($rc) && $rc->is_success(), 1, 'Contact successfully checked'); is($R1, 'DENIC-99990-10240-BSP', 'Check Contact XML correct'); is($dri->get_info('exist', 'contact', 'DENIC-99990-10240-BSP'), 1, 'Contact exists'); $R2 = $E1 . '' . $TRID . 'success' . 'DENIC-99989-BSP' . 'ROLE' . 'SyGroup GmbH' . 'SyGroup GmbH' . '' . 'Gueterstrasse 86' . 'Basel' . '4053' . 'CH' . '' . '+41.613338033' . '+41.613831467' . 'info@sygroup.ch' . 'sip:secretary@sygroup.ch' . 'Live penguins in the office' . '2007-05-23T22:55:33+02:00' . '' . $E2; $rc = $dri->contact_info($dri->local_object('contact')->srid('DENIC-99989-BSP')); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Contact successfully queried'); is($R1, 'DENIC-99989-BSP', 'Query Contact XML correct'); $c = $dri->get_info('self', 'contact', 'DENIC-99989-BSP'); isa_ok($c, 'Net::DRI::Data::Contact::DENIC'); is($c->name() . '|' . $c->org() . '|' . $c->sip() . '|' . $c->type(), 'SyGroup GmbH|SyGroup GmbH|sip:secretary@sygroup.ch|ROLE', 'Selected info from contact'); my $mod = $dri->get_info('upDate', 'contact', 'DENIC-99989-BSP'); isa_ok($mod, 'DateTime'); is($mod->ymd . 'T' . $mod->hms, '2007-05-23T22:55:33', 'Update Date'); $R2 = $E1 . '' . $TRID . 'success' . 'rritestdomain.de' . 'rritestdomain.defree' . '' . $E2; #################################################################################################### $rc = $dri->domain_check('rritestdomain.de'); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($R1, 'rritestdomain.derritestdomain.de', 'Check Domain XML correct'); is($dri->get_info('exist', 'domain', 'rritestdomain.de'), 0, 'Domain does not exist'); $R2 = $E1 . '' . $TRID . 'success' . $E2; $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('DENIC-99990-10240-BSP'), 'registrant'); $cs->add($dri->local_object('contact')->srid('DENIC-99990-10240-BSP1'), 'admin'); $cs->add($dri->local_object('contact')->srid('DENIC-99990-10240-BSP2'), 'tech'); $rc = $dri->domain_create('rritestdomain.de', { pure_create => 1, contact => $cs, ns => $dri->local_object('hosts')-> add('dns1.syhosting.ch',['193.219.115.46']) }); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully created'); is($R1, 'rritestdomain.derritestdomain.deDENIC-99990-10240-BSP1DENIC-99990-10240-BSPDENIC-99990-10240-BSP2rritestdomain.de.dns1.syhosting.ch.193.219.115.46ABC-12345', 'Create Domain XML correct'); $R2 = $E1 . '' . $TRID . 'successdenic.dedenic.deconnect' . $E2; $rc = $dri->domain_check('denic.de'); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully checked'); is($R1, 'denic.dedenic.de', 'Check Domain XML correct'); is($dri->get_info('exist', 'domain', 'denic.de'), 1, 'Domain exists'); $R2 = $E1 . '' . $TRID . 'success' . 'rritestdomain.de' . 'rritestdomain.de' . 'connect' . 'DENIC-1000006' . '' . 'DENIC-1000006-1' . '' . 'DENIC-1000006-2' . '' . 'DENIC-1000006-SD' . '' . 'DENIC-1000006-OPS' . '' . 'DENIC-1000006-OPS' . '' . 'rritestdomain.de' . 'dns1.rritestdomain.de' . '194.25.2.129' . '' . '2001:4d88:ffff:ffff:2:b345:af62:2' . '' . '2001-09-11T11:45:23-07:00' . '' . $E2; $rc = $dri->domain_info('rritestdomain.de'); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully queried'); is($R1, 'rritestdomain.derritestdomain.de', 'Query Domain XML correct'); $mod = $dri->get_info('upDate', 'domain', 'rritestdomain.de'); isa_ok($mod, 'DateTime'); is($mod->ymd . 'T' . $mod->hms, '2001-09-11T11:45:23', 'Update Date'); is($dri->get_info('contact', 'domain', 'rritestdomain.de')-> get('registrant')->srid(), 'DENIC-1000006-1', 'Random contact is correct'); my $ns = $dri->get_info('ns', 'domain', 'rritestdomain.de'); is(join(',', $ns->get_names()), 'dns1.rritestdomain.de', 'Name server records'); is(join(',', map { my ($name, $v4, $v6) = $ns->get_details($_); $v4->[0] } $ns->get_names()), '194.25.2.129', 'Name server v4 IPs'); is(join(',', map { my ($name, $v4, $v6) = $ns->get_details($_); $v6->[0] } $ns->get_names()), '2001:4d88:ffff:ffff:2:b345:af62:2', 'Name server v6 IPs'); $R2 = $E1 . '' . $TRID . 'success' . 'rritestdomain2.de' . 'rritestdomain2.de' . 'connect' . 'DENIC-1000006' . '' . 'DENIC-1000006-1' . '' . 'DENIC-1000006-2' . '' . 'DENIC-1000006-SD' . '' . 'DENIC-1000006-OPS' . '' . 'DENIC-1000006-OPS' . '' . 'rritestdomain2.de' . 'dns1.rritestdomain2.de' . '194.25.2.129' . '' . '2001:4d88:ffff:ffff:2:b345:af62:2' . '' . 'DENIC-1000002' . '2005-11-20T00:00:00+01:00' . '2005-11-23T00:00:00+01:00' . '2005-11-25T00:00:00+01:00' . 'ACTIVE' . '' . '2001-09-11T11:45:23-07:00' . '' . $E2; $rc = $dri->domain_transfer_query('rritestdomain2.de'); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully transferred'); is($dri->get_info('trStatus', 'domain', 'rritestdomain2.de'), 'pending', 'Transfer status set correctly'); $mod = $dri->get_info('reDate', 'domain', 'rritestdomain2.de'); is($mod->ymd . 'T' . $mod->hms, '2005-11-20T00:00:00', 'Update Date'); is($R1, 'rritestdomain2.derritestdomain2.deABC-12345', 'Accept Transfer XML correct'); $R2 = $E1 . '' . $TRID . 'success' . $E2; $rc = $dri->domain_transfer_start('sygroup.de', { contact => $cs, ns => $dri->local_object('hosts')-> add('dns1.syhosting.ch',['193.219.115.46']) }); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully transferred'); is($R1, 'sygroup.desygroup.deDENIC-99990-10240-BSP1DENIC-99990-10240-BSPDENIC-99990-10240-BSP2sygroup.de.dns1.syhosting.ch.193.219.115.46ABC-12345', 'Transfer Domain XML correct'); $rc = $dri->domain_transfer_refuse('rritestdomain.de'); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain transfer successfully refused'); is($R1, 'rritestdomain.derritestdomain.deABC-12345', 'Refuse Transfer XML correct'); $rc = $dri->domain_transfer_accept('rritestdomain2.de'); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain transfer successfully approved'); is($R1, 'rritestdomain2.derritestdomain2.deABC-12345', 'Accept Transfer XML correct'); $rc = $dri->domain_delete('rritestdomain3.de', { contact => $cs }); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully deleted'); is($R1, 'rritestdomain3.derritestdomain3.deDENIC-99990-10240-BSPABC-12345', 'Delete Domain XML correct'); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('DENIC-99990-10240-BSP5'), 'registrant'); $rc = $dri->domain_trade('rritestdomain2.de', { contact => $cs }); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully traded'); is($R1, 'rritestdomain2.derritestdomain2.deDENIC-99990-10240-BSP5ABC-12345', 'Trade Domain XML correct'); # Pre-cache info $R2 = $E1 . '' . $TRID . 'success' . 'rritestdomain.de' . 'rritestdomain.de' . 'connect' . 'DENIC-1000006' . '' . 'DENIC-1000006-1' . '' . 'DENIC-1000006-2' . '' . 'DENIC-1000006-SD' . '' . 'DENIC-1000006-OPS' . '' . 'DENIC-1000006-OPS' . '' . 'rritestdomain.de' . 'dns1.rritestdomain.de' . '194.25.2.129' . '' . '2001:4d88:ffff:ffff:2:b345:af62:2' . '' . '2001-09-11T11:45:23-07:00' . '' . $E2; $rc = $dri->domain_info('rritestdomain.de'); $R2 = $E1 . '' . $TRID . 'success' . $E2; my $changes = $dri->local_object('changes'); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('ALFRED-RIPE'), 'tech'); $changes->add('contact', $cs); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('DENIC-1000006-OPS'), 'tech'); $changes->del('contact', $cs); $changes->add('ns', $dri->local_object('hosts')->add('dns1.syhosting.ch', ['193.219.115.46'])); $changes->del('ns', $dri->local_object('hosts')->add('dns1.rritestdomain.de')); $rc = $dri->domain_update('rritestdomain.de', $changes); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully updated'); is($R1, 'rritestdomain.derritestdomain.deDENIC-1000006-SDDENIC-1000006-1DENIC-1000006-2ALFRED-RIPEDENIC-1000006-OPSrritestdomain.de.dns1.syhosting.ch.193.219.115.46ABC-12345', 'Update Domain XML correct'); #################################################################################################### $R2 = $E1 . '' . $TRID . 'successblafasel.deblafasel.deDENIC eGRoedelDoedelCorp2007-12-27T14:52:13+02:002007-12-31T14:52:13+02:002008-01-02T14:52:13+02:00' . $E2; $rc = $dri->message_retrieve(); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Message successfully deleted'); my $msgid = $dri->get_info('last_id', 'message', 'session'); is($msgid, 423, 'Message ID parsed successfully'); is($dri->get_info('id', 'message', $msgid), $msgid, 'Message ID correct'); is($dri->get_info('action', 'message', $msgid), 'chprov', 'Message type correct'); is($dri->get_info('objid', 'message', $msgid), 'blafasel.de', 'Message domain correct'); $mod = $dri->get_info('qdate', 'message', $msgid); is($mod->ymd . 'T' . $mod->hms, '2007-12-27T14:52:13', 'Update Date'); is($R1, '', 'Retrieve Message XML correct'); $R2 = $E1 . '' . $TRID . 'success' . $E2; $rc = $dri->message_delete($msgid); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Message successfully deleted'); is($R1, 'ABC-12345', 'Delete Message XML correct'); #################################################################################################### exit(0); sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/606eurid_epp.t0000755000175000017500000023540111350046305015333 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 237; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='TRID-0001eurid-488059'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'TRID-0001'; }; $dri->add_registry('EURid'); $dri->target('EURid')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); ######################################################################################################## ## Examples taken from registration_guidelines_v1_0E-epp.pdf ## Contact ## p.22 $R2=$E1.''.r().'sb32492005-09-22T13:28:28.000ZOK'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('sb3249'); $co->name('Smith Bill'); $co->org('EPP Company'); $co->street(['Blue Tower','Main street, 58']); $co->city('Paris'); $co->pc('571234'); $co->cc('FR'); $co->voice('+33.16345656'); $co->fax('+33.16345656'); $co->email('noreply@eurid.eu'); $co->type('registrant'); $co->vat('FR3455345645'); $co->lang('fr'); $rc=$dri->contact_create($co); is($R1,'sb3249Smith BillEPP CompanyBlue TowerMain street, 58Paris571234FR+33.16345656+33.16345656noreply@eurid.euregistrantFR3455345645frTRID-0001','contact_create build 1'); is($rc->is_success(),1,'contact_create is_success 1'); is($dri->get_info('exist'),1,'contact_create get_info(exist) 1'); is($dri->get_info('id'),'sb3249','contact_create get_info(id) 1'); is(''.$dri->get_info('crDate'),'2005-09-22T13:28:28','contact_create get_info(crdate) 1'); ## p.23 $R2=$E1.''.r().'bg20222005-09-22T13:36:45.000ZOK'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('bg2022'); $co->name('Banderas George'); $co->street(['Yellow Tower','Main street, 85']); $co->city('Brussels'); $co->pc('1000'); $co->cc('BE'); $co->voice('+32.16345656'); $co->fax('+32.16345656'); $co->email('noreply@eurid.eu'); $co->type('registrant'); $co->lang('en'); $rc=$dri->contact_create($co); is($R1,'bg2022Banderas GeorgeYellow TowerMain street, 85Brussels1000BE+32.16345656+32.16345656noreply@eurid.euregistrantenTRID-0001','contact_create build 2'); is($rc->is_success(),1,'contact_create is_success 2'); is($dri->get_info('exist'),1,'contact_create get_info(exist) 2'); is($dri->get_info('id'),'bg2022','contact_create get_info(id) 2'); is(''.$dri->get_info('crDate'),'2005-09-22T13:36:45','contact_create get_info(crdate) 2'); ## p.28 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('sb3249'); $toc=$dri->local_object('changes'); my $co2=$dri->local_object('contact'); $co2->org('Newco'); $co2->street(['Green Tower','City Square']); $co2->city('London'); $co2->pc('1111'); $co2->cc('GB'); $co2->voice('+44.1865332156'); $co2->fax('+44.1865332157'); $co2->email('noreply@eurid.eu'); $co2->vat('GB12345678'); $co2->lang('en'); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is($R1,'sb3249NewcoGreen TowerCity SquareLondon1111GB+44.1865332156+44.1865332157noreply@eurid.euGB12345678enTRID-0001','contact_update build 1'); is($rc->is_success(),1,'contact_update is_success 1'); ## p.29 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $toc=$dri->local_object('changes'); $co2=$dri->local_object('contact'); $co2->voice('+44.1865332156'); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is($R1,'sb3249+44.1865332156TRID-0001','contact_update build 2'); is($rc->is_success(),1,'contact_update is_success 2'); ## p.30 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $toc=$dri->local_object('changes'); $co2=$dri->local_object('contact'); $co2->lang('nl'); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is($R1,'sb3249nlTRID-0001','contact_update build 3'); is($rc->is_success(),1,'contact_update is_success 3'); ## p.31 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $toc=$dri->local_object('changes'); $co2=$dri->local_object('contact'); $co2->org(''); $co2->vat(''); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is($R1,'sb3249TRID-0001','contact_update build 4'); is($rc->is_success(),1,'contact_update is_success 4'); ## p.32 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $rc=$dri->contact_delete($dri->local_object('contact')->srid('sj5')); is($R1,'sj5TRID-0001','contact_delete build'); is($rc->is_success(),1,'contact_delete is_success'); ## p.35 $R2=$E1.''.r().'sb3249477365-EURIDSmith BillGreen TowerCity SquareLondon1111GB+44.1865332156+44.1865332157noreply@eurid.eut000006t0000062005-09-22T13:28:31.000Z2005-09-22T14:41:48.000Zregistrantnl'.$TRID.''.$E2; $rc=$dri->contact_info($dri->local_object('contact')->srid('sb3249')); is($R1,'sb3249TRID-0001','contact_info build'); is($rc->is_success(),1,'contact_info is_success'); is($dri->get_info('exist'),1,'contact_info get_info(exist)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::Contact::EURid','contact_info get_info(self)'); is($co->srid(),'sb3249','contact_info get_info(self) srid'); is($co->roid(),'477365-EURID','contact_info get_info(self) roid'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','contact_info get_info(status)'); is_deeply([$s->list_status()],['ok'],'contact_info get_info(status) list_status'); is($s->can_delete(),1,'contact_info get_info(status) can_delete'); is($co->name(),'Smith Bill','contact_info get_info(self) name'); is($co->org(),'','contact_info get_info(self) org'); is_deeply($co->street(),['Green Tower','City Square'],'contact_info get_info(self) street'); is($co->city(),'London','contact_info get_info(self) city'); is($co->pc(),'1111','contact_info get_info(self) pc'); is($co->cc(),'GB','contact_info get_info(self) cc'); is($co->voice(),'+44.1865332156','contact_info get_info(self) voice'); is($co->fax(),'+44.1865332157','contact_info get_info(self) fax'); is($co->email(),'noreply@eurid.eu','contact_info get_info(self) email'); is($dri->get_info('clID'),'t000006','contact_info get_info(clID)'); is($dri->get_info('crID'),'t000006','contact_info get_info(crID)'), $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','contact_info get_info(crDate)'); is(''.$d,'2005-09-22T13:28:31','contact_info get_info(crDate) value'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','contact_info get_info(upDate)'); is(''.$d,'2005-09-22T14:41:48','contact_info get_info(upDate) value'); is($co->type(),'registrant','contact_info get_info(self) type'); is($co->lang(),'nl','contact_info get_info(self) lang'); ############################################################################################################# ## Nsgroup ## p.39 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $dh=$dri->local_object('hosts'); $dh->name('nsgroup-eurid'); $dh->add('ns1.eurid.eu'); $dh->add('ns2.eurid.eu'); $dh->add('ns3.eurid.eu'); $dh->add('ns4.eurid.eu'); $dh->add('ns5.eurid.eu'); my $ro=$dri->remote_object('nsgroup'); $rc=$ro->create($dh); is($R1,'nsgroup-euridns1.eurid.euns2.eurid.euns3.eurid.euns4.eurid.euns5.eurid.euTRID-0001'.$E2,'nsgroup_create build'); is($rc->is_success(),1,'nsgroup_create is_success'); ## p.42 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $dh=$dri->local_object('hosts')->name('nsgroup-eurid3'); $toc=$dri->local_object('changes'); $toc->set('ns',$dri->local_object('hosts')->name('nsgroup-eurid3')->add('ns2.eurid.eu')); $rc=$ro->update($dh,$toc); is($R1,'nsgroup-eurid3ns2.eurid.euTRID-0001'.$E2,'nsgroup_update build'); is($rc->is_success(),1,'nsgroup_update is_success'); ## p.44 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $dh->name('nsgroup-eurid3'); $rc=$ro->delete($dh); is($R1,'nsgroup-eurid3TRID-0001'.$E2,'nsgroup_delete build'); is($rc->is_success(),1,'nsgroup_delete is_success'); ## p.46 $R2=$E1.''.r().'nsgroup-eurid1nsgroup-eurid2nsgroup-eurid3nsgroup-eurid4nsgroup-eurid5nsgroup-eurid6nsgroup-eurid7'.$TRID.''.$E2; my @dh=map { $dri->local_object('hosts')->name('nsgroup-eurid'.$_) } (1..7); $rc=$ro->check_multi(@dh); is($R1,'nsgroup-eurid1nsgroup-eurid2nsgroup-eurid3nsgroup-eurid4nsgroup-eurid5nsgroup-eurid6nsgroup-eurid7TRID-0001'.$E2,'nsgroup_check_multi build'); is($rc->is_success(),1,'nsgroup_check_multi is_success'); is($dri->get_info('exist','nsgroup','nsgroup-eurid1'),0,'nsgroup_check_multi get_info(exist) 1'); is($dri->get_info('exist','nsgroup','nsgroup-eurid2'),1,'nsgroup_check_multi get_info(exist) 2'); is($dri->get_info('exist','nsgroup','nsgroup-eurid3'),0,'nsgroup_check_multi get_info(exist) 3'); is($dri->get_info('exist','nsgroup','nsgroup-eurid4'),1,'nsgroup_check_multi get_info(exist) 4'); is($dri->get_info('exist','nsgroup','nsgroup-eurid5'),0,'nsgroup_check_multi get_info(exist) 5'); is($dri->get_info('exist','nsgroup','nsgroup-eurid6'),0,'nsgroup_check_multi get_info(exist) 6'); is($dri->get_info('exist','nsgroup','nsgroup-eurid7'),0,'nsgroup_check_multi get_info(exist) 7'); $R2=$E1.''.r().'nsgroup-eurid1'.$TRID.''.$E2; $rc=$ro->check('nsgroup-eurid1'); is($R1,'nsgroup-eurid1TRID-0001'.$E2,'nsgroup_check build'); is($rc->is_success(),1,'nsgroup_check is_success'); is($dri->get_info('exist','nsgroup','nsgroup-eurid1'),0,'nsgroup_check get_info(exist) 1'); is($dri->get_info('exist'),0,'nsgroup_check get_info(exist) 2'); ## p.48 $R2=$E1.''.r().'nsgroup-eurid4ns1.eurid.euns2.eurid.euns3.eurid.euns4.eurid.euns5.eurid.euns6.eurid.euns7.eurid.euns8.eurid.euns9.eurid.eu'.$TRID.''.$E2; $rc=$ro->info('nsgroup-eurid4'); is($R1,'nsgroup-eurid4TRID-0001'.$E2,'nsgroup_info build'); is($rc->is_success(),1,'nsgroup_info is_success'); $s=$dri->get_info('self'); isa_ok($s,'Net::DRI::Data::Hosts','nsgroup_info get_info(self) isa'); is_deeply([$s->get_names()],['ns1.eurid.eu','ns2.eurid.eu','ns3.eurid.eu','ns4.eurid.eu','ns5.eurid.eu','ns6.eurid.eu','ns7.eurid.eu','ns8.eurid.eu','ns9.eurid.eu'],'nsgroup_info get_info(self) get_names'); ############################################################################################################ ## Domain ## p.50 $R2=$E1.''.r().'mykingdom.eu2005-09-29T13:47:32.000ZOK'.$TRID.''.$E2; $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('mvw14'),'registrant'); $cs->set($dri->local_object('contact')->srid('mt24'),'tech'); $cs->set($dri->local_object('contact')->srid('jj1'),'billing'); $rc=$dri->domain_create('mykingdom.eu',{pure_create=>1,contact=>$cs}); is_string($R1,'mykingdom.eumvw14jj1mt24TRID-0001'.$E2,'domain_create build 1'); is($rc->is_success(),1,'domain_create is_success 1'); my $crdate=$dri->get_info('crDate'); is(''.$crdate,'2005-09-29T13:47:32','domain_create get_info(crDate) 1'); ## p.52 $R2=$E1.''.r().'everything.eu2005-09-29T14:25:50.000ZOK'.$TRID.''.$E2; $cs->set($dri->local_object('contact')->srid('mt24'),'admin'); $dh=$dri->local_object('hosts'); $dh->add('ns.eurid.eu'); $dh->add('ns.everything.eu',['193.12.11.1']); $rc=$dri->domain_create('everything.eu',{pure_create=>1,contact=>$cs,duration=>DateTime::Duration->new(years=>1),ns=>$dh}); is_string($R1,'everything.eu1ns.eurid.euns.everything.eu193.12.11.1mvw14mt24jj1mt24TRID-0001','domain_create build 2'); is($rc->is_success(),1,'domain_create is_success 2'); $crdate=$dri->get_info('crDate'); is(''.$crdate,'2005-09-29T14:25:50','domain_create get_info(crDate) 2'); ## p.55 $R2=$E1.''.r().'ecom.eu2005-09-29T14:45:34.000ZOK'.$TRID.''.$E2; $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('mvw14'),'registrant'); $cs->set($dri->local_object('contact')->srid('mt24'),'tech'); $cs->set($dri->local_object('contact')->srid('jj1'),'billing'); $dh=$dri->local_object('hosts'); $dh->add('ns.anything.eu'); $dh->add('ns.everything.eu'); my $dh2=$dri->local_object('hosts'); $dh2->name('nsgroup-eurid'); $rc=$dri->domain_create('ecom.eu',{pure_create=>1,contact=>$cs,ns=>$dh,nsgroup=>$dh2,duration=>DateTime::Duration->new(years=>1)}); is_string($R1,'ecom.eu1ns.anything.euns.everything.eumvw14jj1mt24nsgroup-euridTRID-0001','domain_create build'); is($rc->is_success(),1,'domain_create is_success 3'); $crdate=$dri->get_info('crDate'); is(''.$crdate,'2005-09-29T14:45:34','domain_create get_info(crDate) 3'); ## p.58 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $toc=$dri->local_object('changes'); $toc->add('ns',$dri->local_object('hosts')->add('ns.unknown.eu')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('mmai1'),'tech'); $toc->add('contact',$cs); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('mt24'),'tech'); $toc->del('contact',$cs); $toc->add('nsgroup',$dri->local_object('hosts')->name('nsgroup-eurid2')); $toc->del('nsgroup',$dri->local_object('hosts')->name('nsgroup-eurid')); $rc=$dri->domain_update('ecom.eu',$toc); is_string($R1,'ecom.euns.unknown.eummai1mt24nsgroup-eurid2nsgroup-euridTRID-0001','domain_update 1 build'); is($rc->is_success(),1,'domain_update 1 is_success'); is_deeply([$rc->get_extended_results()],[{type=>'text',from=>'eurid',message=>'OK'}],'domain_update 1 info'); $R2=$E1.''.r(2308,'Data management policy violation').'Contact mt24 is not linked to domain ecom'.$TRID.''.$E2; $rc=$dri->domain_update('ecom.eu',$toc); is($rc->is_success(),0,'domain_update 2 is_success'); is_deeply([$rc->get_extended_results()],[{type=>'text',from=>'eurid',message=>'Contact mt24 is not linked to domain ecom'}],'domain_update 2 info'); ## p.61 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $rc=$dri->domain_delete('ecom.eu',{pure_delete=>1,deleteDate=>DateTime->new(year=>2005,month=>9,day=>29,hour=>14,minute=>40,second=>51)}); is_string($R1,'ecom.eu2005-09-29T14:40:51.000000000ZTRID-0001','domain_delete build'); is($rc->is_success(),1,'domain_delete is_success'); ## Release 5.6, page 28 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $rc=$dri->domain_delete('domain-to-update-overwrite-true.eu',{pure_delete=>1,overwrite=>1,deleteDate=>DateTime->new(year=>2010,month=>1,day=>1,hour=>0,minute=>0,second=>0)}); is_string($R1,'domain-to-update-overwrite-true.eu2010-01-01T00:00:00.000000000ZtrueTRID-0001','domain_delete build'); is($rc->is_success(),1,'domain_delete is_success'); ## p.63 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $rc=$dri->domain_undelete('ecom.eu'); is_string($R1,'ecom.euTRID-0001','domain_undelete build'); is($rc->is_success(),1,'domain_undelete is_success'); ## p.67 $R2=$E1.''.r().'OK'.$TRID.''.$E2; my %rd; $rd{trDate}=DateTime->new(year=>2005,month=>9,day=>29,hour=>22); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('jj1'),'billing'); $cs->set($dri->local_object('contact')->srid('ak4589'),'registrant'); $cs->set($dri->local_object('contact')->srid('mt24'),'tech'); $rd{contact}=$cs; $rd{nsgroup}=$dri->local_object('hosts')->name('nsgroup-eurid'); $rc=$dri->domain_transfer_start('something.eu',\%rd); is_string($R1,'something.euak45892005-09-29T22:00:00.000000000Zjj1mt24nsgroup-euridTRID-0001','domain_transfer_start build'); is($rc->is_success(),1,'domain_transfer_start is_success'); ## Release 5.5, page 16 $R2=$E1.''.r().$TRID.''.$E2; %rd=(); $rd{trDate}=DateTime->new(year=>2008,month=>4,day=>22,hour=>22); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('c4436955'),'billing'); $cs->set('#auto#','registrant'); $cs->set($dri->local_object('contact')->srid('c4436957'),'tech'); $rd{contact}=$cs; $rd{owner_auth_code}='238110218175066'; ## see also RN 5.5 Addedum page 2 $rc=$dri->domain_transfer_start('something.eu',\%rd); is_string($R1,'something.eu#AUTO#2008-04-22T22:00:00.000000000Zc4436955c4436957238110218175066TRID-0001','domain_transfer_start with owner_auth_code build'); ## Release 5.5 page 20 $R2=$E1.''.r().$TRID.''.$E2; %rd=(); $rc=$dri->domain_transfer_stop('superdomain.eu',{reason => 'The reason for cancelling the transfer'}); is_string($R1,'superdomain.euThe reason for cancelling the transferTRID-0001','domain_transfer_stop build'); is($rc->is_success(),1,'domain_transfer_stop is_success'); ## p.70 $R2=$E1.''.r().'Content check ok'.$TRID.''.$E2; %rd=(); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('jd1'),'billing'); $cs->set($dri->local_object('contact')->srid('js5'),'registrant'); $cs->set($dri->local_object('contact')->srid('jb1'),'tech'); $rd{contact}=$cs; $rd{trDate}=DateTime->new(year=>2002,month=>2,day=>18,hour=>22); $rd{ns}=$dri->local_object('hosts')->add('ns1.superdomain.eu',['1.2.3.4'])->add('ns.test.eu'); $rd{nsgroup}='mynsgroup1'; $rc=$dri->domain_transfer_quarantine_start('superdomain.eu',\%rd); is_string($R1,'superdomain.eujs52002-02-18T22:00:00.000000000Zjd1jb1ns1.superdomain.eu1.2.3.4ns.test.eumynsgroup1TRID-0001','domain_transfer_quarantine_start build'); ## 3 corrections from EURid sample is($rc->is_success(),1,'domain_transfer_quarantine_start is_success'); ## Release 5.5, page 22 $R2=$E1.''.r().$TRID.''.$E2; %rd=(); $rc=$dri->domain_transfer_quarantine_stop('superdomain.eu',{reason => 'The reason for cancelling the transfer from quarantine'}); is_string($R1,'superdomain.euThe reason for cancelling the transfer from quarantineTRID-0001','domain_transfer_quarantine_stop build'); is($rc->is_success(),1,'domain_transfer_quarantine_stop is_success'); ## p.72 $R2=$E1.''.r().'OK'.$TRID.''.$E2; %rd=(); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('jj1'),'billing'); $cs->set($dri->local_object('contact')->srid('ak4589'),'registrant'); $cs->set($dri->local_object('contact')->srid('mt24'),'tech'); $rd{contact}=$cs; $rd{trDate}=DateTime->new(year=>2005,month=>9,day=>29,hour=>22); $rd{nsgroup}='nsgroup-eurid'; $rc=$dri->domain_trade_start('fox.eu',\%rd); is($R1,'fox.euak45892005-09-29T22:00:00.000000000Zjj1mt24nsgroup-euridTRID-0001','domain_trade build'); ## corrected from EURid sample is($rc->is_success(),1,'domain_trade build'); ## Release 5.5 page 20 $R2=$E1.''.r().$TRID.''.$E2; %rd=(); $rc=$dri->domain_trade_stop('superdomain.eu',{reason => 'The reason for cancelling the trade'}); is_string($R1,'superdomain.euThe reason for cancelling the tradeTRID-0001','domain_trade_stop build'); ## p.74 $R2=$E1.''.r().'OK'.$TRID.''.$E2; $rc=$dri->domain_reactivate('ecom.eu'); is($R1,'ecom.euTRID-0001','domain_reactivate build'); is($rc->is_success(),1,'domain_reactivate is_success'); ## p.76 $R2=$E1.''.r().'nothing.euanything.euecom.eumykingdom.eueverything.eusomething.eumything.eu'.$TRID.''.$E2; $dri->cache_clear(); $rc=$dri->domain_check_multi('nothing.eu','anything.eu','ecom.eu','mykingdom.eu','everything.eu','something.eu','mything.eu'); is($R1,'nothing.euanything.euecom.eumykingdom.eueverything.eusomething.eumything.euTRID-0001','domain_check_multi build'); is($rc->is_success(),1,'domain_check_multi is_success'); is($dri->get_info('exist','domain','nothing.eu'),1,'domain_check_multi get_info(exist) 1/7'); is($dri->get_info('exist','domain','anything.eu'),0,'domain_check_multi get_info(exist) 2/7'); is($dri->get_info('exist','domain','ecom.eu'),1,'domain_check_multi get_info(exist) 3/7'); is($dri->get_info('exist','domain','mykingdom.eu'),1,'domain_check_multi get_info(exist) 4/7'); is($dri->get_info('exist','domain','everything.eu'),1,'domain_check_multi get_info(exist) 5/7'); is($dri->get_info('exist','domain','something.eu'),0,'domain_check_multi get_info(exist) 6/7'); is($dri->get_info('exist','domain','mything.eu'),0,'domain_check_multi get_info(exist) 7/7'); ## p.78 $R2=$E1.''.r().'ecom.eu19204-EURIDmvw14jj1mmai1ns.anything.euns.everything.euns.unknown.eut000006t0000062005-09-29T14:45:35.000Zt0000062005-09-29T14:45:35.000Z2006-09-29T15:45:35.0Znsgroup-eurid2'.$TRID.''.$E2; $rc=$dri->domain_info('ecom.eu'); is_string($R1,'ecom.euTRID-0001','domain_info build'); is($rc->is_success(),1,'domain_info is_success'); is($dri->get_info('exist'),1,'domain_info get_info(exist)'); is($dri->get_info('roid'),'19204-EURID','domain_info get_info(roid)'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','domain_info get_info(status)'); is_deeply([$s->list_status()],['ok'],'domain_info get_info(status) list'); is($s->is_active(),1,'domain_info get_info(status) is_active'); $s=$dri->get_info('contact'); isa_ok($s,'Net::DRI::Data::ContactSet','domain_info get_info(contact)'); is_deeply([$s->types()],['billing','registrant','tech'],'domain_info get_info(contact) types'); is($s->get('registrant')->srid(),'mvw14','domain_info get_info(contact) registrant srid'); is($s->get('billing')->srid(),'jj1','domain_info get_info(contact) billing srid'); is($s->get('tech')->srid(),'mmai1','domain_info get_info(contact) tech srid'); $dh=$dri->get_info('ns'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(ns)'); @c=$dh->get_names(); is_deeply(\@c,['ns.anything.eu','ns.everything.eu','ns.unknown.eu'],'domain_info get_info(ns) get_names'); is($dri->get_info('clID'),'t000006','domain_info get_info(clID)'); is($dri->get_info('crID'),'t000006','domain_info get_info(crID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_info get_info(crDate)'); is(''.$d,'2005-09-29T14:45:35','domain_info get_info(crDate) value'); is($dri->get_info('upID'),'t000006','domain_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','domain_info get_info(upDate)'); is(''.$d,'2005-09-29T14:45:35','domain_info get_info(upDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_info get_info(exDate)'); is(''.$d,'2006-09-29T15:45:35','domain_info get_info(exDate) value'); $d=$dri->get_info('nsgroup'); isa_ok($d,'ARRAY','domain_info get_info(nsgroup)'); is(@$d,1,'domain_info get_info(nsgroup) count'); $d=$d->[0]; isa_ok($d,'Net::DRI::Data::Hosts','domain_info get_info(nsgroup) [0]'); is($d->name(),'nsgroup-eurid2','domain_info get_info(nsgroup) [0] value'); ## Examples from https://secure.registry.eu/images/Library/release%20notes%205%201.pdf (in effect since 2007-08-06) # §1.2 $R2=$E1.''.r().'0001-inusedomain-0001-test.eu3787937-EURIDc195332c31c34a000005a0000052007-07-31T16:43:44.000Za0000052007-07-31T16:46:16.000Z2008-07-31T16:43:44.000Ztestfalsefalse'.$TRID.''.$E2; $rc=$dri->domain_info('0001-inusedomain-0001-test.eu'); is_string($R1,'0001-inusedomain-0001-test.euTRID-0001','domain_info version 2.0 build'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','domain_info version 2.0 get_info(status)'); is_deeply([$s->list_status()],['ok'],'domain_info version 2.0 get_info(status) list'); # §2.2 $R2=$E1.''.r().'0001-scheduledfordelete-0001-test.eu3787636-EURIDc195332c31c34a000005a0000052007-07-31T14:50:19.000Za0000052007-07-31T16:46:58.000Z2008-07-31T14:50:19.000Ztestfalsefalse2009-07-31T18:00:00.000Z'.$TRID.''.$E2; $rc=$dri->domain_info('0001-scheduledfordelete-0001-test.eu'); $d=$dri->get_info('deletionDate'); isa_ok($d,'DateTime','domain_info version 2.0 get_info(deletionDate)'); is(''.$d,'2009-07-31T18:00:00','domain_info version 2.0 get_info(deletionDate) value'); # §3.2 $R2=$E1.''.r().'0001-quarantinedomain-0001.eu3787640-EURIDc195332c31c34a000005a0000052007-07-31T14:51:37.000Za0000052007-07-31T14:51:37.000Z2008-07-31T14:51:37.000Zfalsetrue2007-09-09T23:00:00.000Z2007-07-31T14:00:00.000Z'.$TRID.''.$E2; $rc=$dri->domain_info('0001-quarantinedomain-0001.eu'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','domain_info version 2.0 get_info(status)'); is_deeply([$s->list_status()],['ok','quarantined'],'domain_info version 2.0 get_info(status) list'); $d=$dri->get_info('deletionDate'); isa_ok($d,'DateTime','domain_info version 2.0 get_info(deletionDate)'); is(''.$d,'2007-07-31T14:00:00','domain_info version 2.0 get_info(deletionDate) value'); $d=$dri->get_info('availableDate'); isa_ok($d,'DateTime','domain_info version 2.0 get_info(availableDate)'); is(''.$d,'2007-09-09T23:00:00','domain_info version 2.0 get_info(availableDate) value'); # §4.2 $R2=$E1.''.r().'0001-domainonhold-0001-test.eu3787823-EURIDc8033037c31c34a000005a0000052007-07-31T16:01:26.000Za0000052007-07-31T16:49:58.000Z2008-07-31T16:01:26.000Ztesttruefalse'.$TRID.''.$E2; $rc=$dri->domain_info('0001-domainonhold-0001-test.eu'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','domain_info version 2.0 get_info(status)'); is_deeply([$s->list_status()],['ok','onhold'],'domain_info version 2.0 get_info(status) list'); # §5.2 $R2=$E1.''.r().'0001-internaltradedomain-0001-test.eu3787827-EURIDc195332c31c34a000005a0000052007-07-31T16:02:21.000Za0000052007-07-31T16:50:25.000Z2008-07-31T16:02:21.000Ztestfalsefalsec75574622007-07-30T22:00:00.000Zc31c342007-07-31T16:19:58.000ZNotYetApprovedNoAnswerNoAnswer'.$TRID.''.$E2; $rc=$dri->domain_info('0001-internaltradedomain-0001-test.eu'); $s=$dri->get_info('pending_transaction'); is(ref($s),'HASH','domain_info version 2.0 get_info(pending_transaction) trade'); is($s->{type},'trade','domain_info version 2.0 get_info(pending_transaction) trade type'); isa_ok($s->{trDate},'DateTime','domain_info version 2.0 get_info(pending_transaction) trade trDate'); is(''.$s->{trDate},'2007-07-30T22:00:00','domain_info version 2.0 get_info(pending_transaction) trade trDate value'); $d=$s->{'contact'}; isa_ok($d,'Net::DRI::Data::ContactSet','domain_info version 2.0 get_info(pending_transaction) trade contact'); is_deeply([$d->types()],['billing','registrant','tech'],'domain_info version 2.0 get_info(pending_transaction) trade contact types'); is($d->get('registrant')->srid(),'c7557462','domain_info version 2.0 get_info(pending_transaction) trade registrant srid'); is($d->get('billing')->srid(),'c31','domain_info version 2.0 get_info(pending_transaction) trade billing srid'); is($d->get('tech')->srid(),'c34','domain_info version 2.0 get_info(pending_transaction) trade tech srid'); isa_ok($s->{initiationDate},'DateTime','domain_info version 2.0 get_info(pending_transaction) trade initiationDate'); is(''.$s->{initiationDate},'2007-07-31T16:19:58','domain_info version 2.0 get_info(pending_transaction) trade initiationDate value'); is($s->{status},'NotYetApproved','domain_info version 2.0 get_info(pending_transaction) trade status'); is($s->{replySeller},'NoAnswer','domain_info version 2.0 get_info(pending_transaction) trade replySeller'); is($s->{replyBuyer},'NoAnswer','domain_info version 2.0 get_info(pending_transaction) trade replyBuyer'); # §6.2, not done, same as §1.2 # §7.2 and §8.2, nothing new # §9.2, same as §5.2 # §10.2 $R2=$E1.''.r().'0001-domaintransfer-0001-test.eu0-EURID#non-disclosed#falsefalse#AUTO#2007-07-30T22:00:00.000Zc31c342007-07-31T16:22:19.000ZNotYetApprovedNoAnswer'.$TRID.''.$E2; $rc=$dri->domain_info('0001-domaintransfer-0001-test.eu'); $s=$dri->get_info('pending_transaction'); is(ref($s),'HASH','domain_info version 2.0 get_info(pending_transaction) trade'); is($s->{type},'transfer','domain_info version 2.0 get_info(pending_transaction) transfer type'); isa_ok($s->{trDate},'DateTime','domain_info version 2.0 get_info(pending_transaction) transfer trDate'); is(''.$s->{trDate},'2007-07-30T22:00:00','domain_info version 2.0 get_info(pending_transaction) transfer trDate value'); $d=$s->{'contact'}; isa_ok($d,'Net::DRI::Data::ContactSet','domain_info version 2.0 get_info(pending_transaction) transfer contact'); is_deeply([$d->types()],['billing','registrant','tech'],'domain_info version 2.0 get_info(pending_transaction) transfer contact types'); is($d->get('registrant')->srid(),'#AUTO#','domain_info version 2.0 get_info(pending_transaction) transfer registrant srid'); is($d->get('billing')->srid(),'c31','domain_info version 2.0 get_info(pending_transaction) transfer billing srid'); is($d->get('tech')->srid(),'c34','domain_info version 2.0 get_info(pending_transaction) transfer tech srid'); isa_ok($s->{initiationDate},'DateTime','domain_info version 2.0 get_info(pending_transaction) transfer initiationDate'); is(''.$s->{initiationDate},'2007-07-31T16:22:19','domain_info version 2.0 get_info(pending_transaction) transfer initiationDate value'); is($s->{status},'NotYetApproved','domain_info version 2.0 get_info(pending_transaction) transfer status'); is($s->{replyOwner},'NoAnswer','domain_info version 2.0 get_info(pending_transaction) transfer replyOwner'); ## Check commands $R2=$E1.''.r().'0002-quarantinedomain-0001.euquarantine0002-quarantinedomain-0001.eu2007-09-09T23:00:00.000Z'.$TRID.''.$E2; $rc=$dri->domain_check('0002-quarantinedomain-0001.eu'); is_string($R1,'0002-quarantinedomain-0001.euTRID-0001','domain_check version 2.0 build'); is($rc->is_success(),1,'domain_check version 2.0 is_success'); is($dri->get_info('exist','domain','0002-quarantinedomain-0001.eu'),1,'domain_check version 2.0 get_info(exist)'); is($dri->get_info('exist_reason','domain','0002-quarantinedomain-0001.eu'),'quarantine','domain_check version 2.0 get_info(exist_reason)'); is($dri->get_info('application_accepted','domain','0002-quarantinedomain-0001.eu'),0,'domain_check version 2.0 get_info(application_accepted)'); is($dri->get_info('application_expired','domain','0002-quarantinedomain-0001.eu'),0,'domain_check version 2.0 get_info(application_expired)'); is($dri->get_info('application_initial','domain','0002-quarantinedomain-0001.eu'),0,'domain_check version 2.0 get_info(application_initial)'); is($dri->get_info('application_rejected','domain','0002-quarantinedomain-0001.eu'),0,'domain_check version 2.0 get_info(application_rejected)'); $s=$dri->get_info('availableDate','domain','0002-quarantinedomain-0001.eu'); isa_ok($s,'DateTime','domain_check version 2.0 get_info(availableDate)'); is(''.$s,'2007-09-09T23:00:00','domain_check version 2.0 get_info(availableDate) value'); ## Release 5.5, page 18 $R2=$E1.''.r().'100'.$TRID.''.$E2; $rc=$dri->domain_check_contact_for_transfer('domainnametocheck1.eu',{registrant=>$dri->local_object('contact')->srid('c3456789')}); is_string($R1,'domainnametocheck1.euc3456789','domain_check_contact_for_transfer build'); is($rc->is_success(),1,'domain_check_contact_for_transfer is_success'); is($dri->get_info('percentage'),100,'domain_check_contact_for_transfer get_info(percentage)'); ################################################################################################################ ## Release 5.6 october 2008 ## page 28 $R2=$E1.''.r().'100110002008-10-09T17:31:20.000Z8922.000'.$TRID.''.$E2; $rc=$dri->registrar_info(); is_string($R1,'TRID-0001','registrar_info build'); $s=$rc->get_data('hitpoints'); isa_ok($s,'HASH','registrar_info get_data(hitpoints)'); is($s->{current_number},1001,'registrar_info get_data(hitpoints) current_number'); is($s->{maximum_number},1000,'registrar_info get_data(hitpoints) maximum_number'); isa_ok($s->{blocked_until},'DateTime','registrar_info get_data(hitpoints) blocked_until isa DateTime'); is(''.$s->{blocked_until},'2008-10-09T17:31:20','registrar_info get_data(hitpoints) blocked_until value'); is($rc->get_data('amount_available'),8922,'registrar_info get_data(amount_available)'); $s=$rc->get_data('credits'); isa_ok($s,'HASH','registrar_info get_data(credits)'); is($s->{renewal},0,'registrar_info get_data(credits) renewal'); is($s->{promo},undef,'registrar_info get_data(credits) promo'); ## page 33 $rc=$dri->domain_remind('abc.eu',{destination=>'owner'}); is_string($R1,'abc.euownerTRID-0001','domain_remind destionation=owner build'); $rc=$dri->domain_remind('abc.eu',{destination=>'buyer'}); is_string($R1,'abc.eubuyerTRID-0001','domain_remind destionation=owner build'); ## page 19 $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2008-09-18T21:29:28.179+02:00Transfer of domain name mytransferdomain.euCONFIRMmytransferdomain.eu1155TRANSFER'.$TRID.''.$E2; $rc=$dri->message_retrieve(); ## This is a *very* convoluted way to access data, it is only done so to test everything is there $s=$rc->get_data('message','session','last_id'); is($s,6830,'notification get_data(message,session,last_id)'); $s=$rc->get_data('message',$s,'name'); is($s,'mytransferdomain.eu','notification get_data(message,ID,name)'); is($rc->get_data('domain',$s,'object_type'),$rc->get_data('object_type'),'notification get_data(domain,X,Y)=get_data(Y)'); is($rc->get_data('exist'),1,'notification get_data(exist)'); is($rc->get_data('return_code'),1155,'notification get_data(return_code)'); is($rc->get_data('action'),'confirm_transfer','notification get_data(action)'); is($rc->get_data('id'),6830,'notification get_data(id)'); ################################################################################################################ ## Examples from Registration_guidelines_v1_0F-appendix2-sunrise.pdf $dri->target('EURid')->add_current_profile('p2','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['Net::DRI::Protocol::EPP::Extensions::EURid::Sunrise']}); ## p.8 $R2='Command completed successfully; ending sessionc-and-a.euc-and-a_125651000060299992005-11-08T14:51:08.929ZOKclientref-12310026eurid-1589'; $ro=$dri->remote_object('domain'); $h=$dri->local_object('hosts')->add('ns.c-and-a.eu',['81.2.4.4'],['2001:0:0:0:8:800:200C:417A'])->add('ns.isp.eu'); ## IPv6 changed $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('js5'),'registrant'); $cs->set($dri->local_object('contact')->srid('jd1'),'billing'); $cs->set($dri->local_object('contact')->srid('jd2'),'tech'); $rc=$ro->apply('c-and-a.eu',{reference=>'c-and-a_1',right=>'REG-TM-NAT','prior-right-on-name'=>'c&a','prior-right-country'=>'NL',documentaryevidence=>'applicant','evidence-lang'=>'nl',ns=>$h,contact=>$cs}); is($R1,'c-and-a.euc-and-a_1REG-TM-NATc&aNLnlns.c-and-a.eu81.2.4.42001:0:0:0:8:800:200C:417Ans.isp.eujs5jd1jd2TRID-0001','domain_apply build'); ## IPv6 changed from EURid example is($rc->is_success(),1,'domain_apply is_success'); is($dri->get_info('reference'),'c-and-a_1','domain_apply get_info(reference)'); is($dri->get_info('code'),'2565100006029999','domain_apply get_info(code)'); is(''.$dri->get_info('crDate'),'2005-11-08T14:51:08','domain_apply get_info(crDate)'); ## p.12 $R2='Command completed successfullyc-and-a.euc-and-a_125651000060299992005-11-08T14:51:08.929ZINITIALjs5jd1jd2ns.c-and-a.eu81.2.4.4ns.isp.euns.c-and-a.eu2001:0:0:0:8:800:200C:417A2005-11-08T21:46:56.000ZfalseTRID-0001eurid-0'; ## IPv6 changed from EURid example $ro=$dri->remote_object('domain'); $rc=$ro->apply_info('c-and-a_1'); is($R1,'c-and-a_1TRID-0001','domain_apply_info build'); is($rc->is_success(),1,'domain_apply_info is_success'); is($dri->get_info('reference'),'c-and-a_1','domain_apply get_info(reference)'); is($dri->get_info('code'),'2565100006029999','domain_apply get_info(code)'); is(''.$dri->get_info('crDate'),'2005-11-08T14:51:08','domain_apply get_info(crDate)'); is($dri->get_info('application_status'),'INITIAL','domain_apply get_info(application_status)'); $s=$dri->get_info('contact'); isa_ok($s,'Net::DRI::Data::ContactSet','domain_apply get_info(contact)'); is_deeply([$s->types()],['billing','registrant','tech'],'domain_apply get_info(contact) types'); is($s->get('billing')->srid(),'jd1','domain_apply get_info(contact) billing srid'); is($s->get('registrant')->srid(),'js5','domain_apply get_info(contact) registrant srid'); is($s->get('tech')->srid(),'jd2','domain_apply get_info(contact) tech srid'); $dh=$dri->get_info('ns'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_apply get_info(ns)'); @c=$dh->get_names(); is_deeply(\@c,['ns.c-and-a.eu','ns.isp.eu'],'domain_apply get_info(ns) get_names'); @c=$dh->get_details(1); is($c[0],'ns.c-and-a.eu','domain_apply get_info(ns) get_details(1) 0'); is_deeply($c[1],['81.2.4.4'],'domain_apply get_info(ns) get_details(1) 1'); is_deeply($c[2],['2001:0:0:0:8:800:200C:417A'],'domain_apply get_info(ns) get_details(1) 2'); @c=$dh->get_details(2); is($c[0],'ns.isp.eu','domain_apply get_info(ns) get_details(2) 0'); is_deeply($c[1],[],'domain_apply get_info(ns) get_details(2) 1'); is_deeply($c[2],[],'domain_apply get_info(ns) get_details(2) 2'); is(''.$dri->get_info('docsReceivedDate'),'2005-11-08T21:46:56','domain_apply get_info(docsReceivedDate)'); is($dri->get_info('adr'),0,'domain_apply get_info(adr)'); exit 0; Net-DRI-0.96/t/611vnds_epp_idnlang.t0000755000175000017500000000352111241325410016655 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 1; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['Net::DRI::Protocol::EPP::Extensions::VeriSign::IDNLanguage']}); ######################################################################################################### ## Example taken from EPP-IDN-Lang-Mapping.pdf my $rc=$dri->domain_create('xn--example2.com',{pure_create => 1, auth => { pw => '2fooBAR' }, language => 'en'}); is($R1,$E1.'xn--example2.com2fooBARenABC-12345'.$E2,'domain_create build'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/502drd_name.t0000755000175000017500000000302711350046365015126 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 2; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } #################################################################################################### my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('NAME'); $dri->target('NAME')->add_current_profile('p1','test=epp',{f_send => \&mysend, f_recv => \&myrecv}); is($dri->verify_name_domain('firstname.lastname.name','info'),'','firstname.lastname.name registrability'); is($dri->verify_name_domain('lastname.name','info'),'','lastname.name registrability'); #################################################################################################### exit 0; Net-DRI-0.96/t/103cache.t0000755000175000017500000000245011023330733014404 0ustar patrickpatrick#!/usr/bin/perl -w use strict; use Net::DRI::Cache; use Test::More tests => 12; my $c; $c=Net::DRI::Cache->new(-1); isa_ok($c,'Net::DRI::Cache'); $c->set('regname','type','key',{w=>'a'}); is_deeply($c->{data},{},'nothing in cache if negative TTL'); $c=Net::DRI::Cache->new(100); ## cache of 100 seconds isa_ok($c->set('regname','domain','example.foo',{'whatever' => 'whatever2'}),'HASH','set'); is($c->get('domain','example.foo','whatever','regname'),'whatever2','get from cache 1'); is($c->get('domain','example.foo','whatever','regname2'),undef,'get from cache 2'); isa_ok($c->set('regname','domain','example.foo',{'whatever2' => 'whatever22'},1),'HASH','set for 1 second'); my $c2=Net::DRI::Cache->new(1); $c2->set('regname','domain','cachec2',{'whatever3'=>2}); is($c2->get('domain','cachec2','whatever3','regname'),2,'get from cache 3'); sleep(2); is($c->get('domain','example.foo','whatever2','regname'),undef,'get from cache after expiry'); $c2->delete_expired(); is_deeply($c2->{data}->{domain},{},'empty cache after delete_expired'); isa_ok($c->set('regname','domain','example.foo',{'whatever' => 'whatever2'}),'HASH','set 2'); is($c->get('domain','example.foo','whatever','regname'),'whatever2','get from cache 4'); $c->delete(); is_deeply($c->{data},{},'empty cache after delete_expired'); exit 0; Net-DRI-0.96/t/155data_statuslist.t0000755000175000017500000000263510266022566016577 0ustar patrickpatrick#!/usr/bin/perl -w use strict; use Net::DRI::Data::StatusList; use Test::More tests => 17; my $s=Net::DRI::Data::StatusList->new(); isa_ok($s,'Net::DRI::Data::StatusList'); is($s->is_empty(),1,'is_empty() 1'); $s=Net::DRI::Data::StatusList->new('p','1.0'); isa_ok($s,'Net::DRI::Data::StatusList'); is($s->is_empty(),1,'is_empty() 2'); $s=Net::DRI::Data::StatusList->new('p','1.0','ACTIVE'); isa_ok($s,'Net::DRI::Data::StatusList'); is($s->is_empty(),0,'is_empty() 0'); is_deeply([$s->list_status()],['ACTIVE'],'list_status()'); $s=Net::DRI::Data::StatusList->new('p','1.0',{name => 'ACTIVE', lang=>'en', msg => 'Test' }); isa_ok($s,'Net::DRI::Data::StatusList'); is($s->is_empty(),0,'is_empty() 0'); is_deeply([$s->list_status()],['ACTIVE'],'list_status()'); $s->add('WHATEVER'); is($s->has_any('WHATEVER'),1,'has_any()'); is($s->has_not('ACTIVE'),0,'has_not()'); $s=Net::DRI::Data::StatusList->new(); $s->_register_pno({w=>'WHATEVER',a=>'ACTIVE'}); is_deeply([$s->possible_no()],['a','w'],'possible_no()'); $s->no('w'); is_deeply([$s->list_status()],['WHATEVER'],'no() 1/3'); $s->no('a','Whatever','fr'); is_deeply([$s->list_status()],['ACTIVE','WHATEVER'],'no() 2/3'); is_deeply($s->status_details(),{'WHATEVER'=>{},'ACTIVE'=>{'msg'=>'Whatever','lang'=>'fr'}},'no() 3/3'); can_ok('Net::DRI::Data::StatusList','is_active','is_published','is_pending','is_linked','can_update','can_transfer','can_delete','can_renew'); exit 0; Net-DRI-0.96/t/501drd_icann.t0000755000175000017500000000201210575331530015265 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::DRD::ICANN; use Test::More tests => 12; is(Net::DRI::DRD::ICANN::is_reserved_name('whatever.foo','create'),0,'whatever.foo'); is(Net::DRI::DRD::ICANN::is_reserved_name('icann.foo','create'),1,'icann.foo'); is(Net::DRI::DRD::ICANN::is_reserved_name('icann.bar.foo','create'),1,'icann.bar.foo'); is(Net::DRI::DRD::ICANN::is_reserved_name('ab--cd.foo','create'),1,'ab-cd.foo'); is(Net::DRI::DRD::ICANN::is_reserved_name('a.foo','create'),1,'a.foo'); is(Net::DRI::DRD::ICANN::is_reserved_name('ab.foo','create'),1,'ab.foo'); is(Net::DRI::DRD::ICANN::is_reserved_name('biz.foo','create'),1,'biz.foo'); is(Net::DRI::DRD::ICANN::is_reserved_name('foo.biz','create'),0,'foo.biz'); is(Net::DRI::DRD::ICANN::is_reserved_name('www.foo','create'),1,'www.foo'); is(Net::DRI::DRD::ICANN::is_reserved_name('foo.www','create'),0,'foo.www'); is(Net::DRI::DRD::ICANN::is_reserved_name('q.com','create'),1,'q.com (creation)'); is(Net::DRI::DRD::ICANN::is_reserved_name('q.com','update'),0,'q.com (update)'); exit 0; Net-DRI-0.96/t/001load_mandatory.t0000755000175000017500000003610511350046635016347 0ustar patrickpatrick#!/usr/bin/perl -w use Test::More tests => 320; BEGIN { use_ok('Net::DRI'); use_ok('Net::DRI::Transport'); use_ok('Net::DRI::Exception'); use_ok('Net::DRI::Cache'); use_ok('Net::DRI::Protocol'); use_ok('Net::DRI::Util'); use_ok('Net::DRI::Registry'); use_ok('Net::DRI::Shell'); use_ok('Net::DRI::BaseClass'); use_ok('Net::DRI::Logging'); use_ok('Net::DRI::Logging::Null'); use_ok('Net::DRI::Logging::Files'); use_ok('Net::DRI::Logging::Stderr'); use_ok('Net::DRI::Logging::Syslog'); use_ok('Net::DRI::DRD'); use_ok('Net::DRI::DRD::ICANN'); use_ok('Net::DRI::DRD::VNDS'); use_ok('Net::DRI::DRD::AFNIC'); use_ok('Net::DRI::DRD::Gandi'); use_ok('Net::DRI::DRD::WS'); use_ok('Net::DRI::DRD::EURid'); use_ok('Net::DRI::DRD::SE'); use_ok('Net::DRI::DRD::PL'); use_ok('Net::DRI::DRD::IENUMAT'); use_ok('Net::DRI::DRD::CAT'); use_ok('Net::DRI::DRD::AERO'); use_ok('Net::DRI::DRD::MOBI'); use_ok('Net::DRI::DRD::BE'); use_ok('Net::DRI::DRD::AT'); use_ok('Net::DRI::DRD::COOP'); use_ok('Net::DRI::DRD::INFO'); use_ok('Net::DRI::DRD::ORG'); use_ok('Net::DRI::DRD::LU'); use_ok('Net::DRI::DRD::BIZ'); use_ok('Net::DRI::DRD::ASIA'); use_ok('Net::DRI::DRD::NAME'); use_ok('Net::DRI::DRD::NU'); use_ok('Net::DRI::DRD::AU'); use_ok('Net::DRI::DRD::US'); use_ok('Net::DRI::DRD::OVH'); use_ok('Net::DRI::DRD::BookMyName'); use_ok('Net::DRI::DRD::Nominet'); use_ok('Net::DRI::DRD::DENIC'); use_ok('Net::DRI::DRD::SWITCH'); use_ok('Net::DRI::DRD::HN'); use_ok('Net::DRI::DRD::SC'); use_ok('Net::DRI::DRD::VC'); use_ok('Net::DRI::DRD::AG'); use_ok('Net::DRI::DRD::BZ'); use_ok('Net::DRI::DRD::LC'); use_ok('Net::DRI::DRD::MN'); use_ok('Net::DRI::DRD::ME'); use_ok('Net::DRI::DRD::CZ'); use_ok('Net::DRI::DRD::TRAVEL'); use_ok('Net::DRI::DRD::NO'); use_ok('Net::DRI::DRD::BR'); use_ok('Net::DRI::DRD::PRO'); use_ok('Net::DRI::DRD::OpenSRS'); use_ok('Net::DRI::DRD::PT'); use_ok('Net::DRI::DRD::CentralNic'); use_ok('Net::DRI::DRD::CoCCA'); use_ok('Net::DRI::DRD::ARNES'); use_ok('Net::DRI::DRD::IM'); use_ok('Net::DRI::DRD::AdamsNames'); use_ok('Net::DRI::DRD::SIDN'); use_ok('Net::DRI::DRD::IT'); use_ok('Net::DRI::DRD::IRegistry'); use_ok('Net::DRI::DRD::CIRA'); use_ok('Net::DRI::DRD::GL'); use_ok('Net::DRI::Data::Raw'); use_ok('Net::DRI::Data::Hosts'); use_ok('Net::DRI::Data::Changes'); use_ok('Net::DRI::Data::StatusList'); use_ok('Net::DRI::Data::RegistryObject'); use_ok('Net::DRI::Data::Contact'); use_ok('Net::DRI::Data::ContactSet'); use_ok('Net::DRI::Data::Contact::EURid'); use_ok('Net::DRI::Data::Contact::SE'); use_ok('Net::DRI::Data::Contact::PL'); use_ok('Net::DRI::Data::Contact::AFNIC'); use_ok('Net::DRI::Data::Contact::US'); use_ok('Net::DRI::Data::Contact::CAT'); use_ok('Net::DRI::Data::Contact::AERO'); use_ok('Net::DRI::Data::Contact::BE'); use_ok('Net::DRI::Data::Contact::AT'); use_ok('Net::DRI::Data::Contact::COOP'); use_ok('Net::DRI::Data::Contact::LU'); use_ok('Net::DRI::Data::Contact::ASIA'); use_ok('Net::DRI::Data::Contact::Nominet'); use_ok('Net::DRI::Data::Contact::DENIC'); use_ok('Net::DRI::Data::Contact::SWITCH'); use_ok('Net::DRI::Data::Contact::NO'); use_ok('Net::DRI::Data::Contact::BR'); use_ok('Net::DRI::Data::Contact::JOBS'); use_ok('Net::DRI::Data::Contact::FCCN'); use_ok('Net::DRI::Data::Contact::ARNES'); use_ok('Net::DRI::Data::Contact::OpenSRS'); use_ok('Net::DRI::Data::Contact::SIDN'); use_ok('Net::DRI::Data::Contact::CIRA'); use_ok('Net::DRI::Data::Contact::IT'); use_ok('Net::DRI::Transport::Socket'); use_ok('Net::DRI::Transport::Dummy'); use_ok('Net::DRI::Transport::Defer'); use_ok('Net::DRI::Protocol::ResultStatus'); use_ok('Net::DRI::Protocol::Message'); use_ok('Net::DRI::Protocol::RRP::Message'); use_ok('Net::DRI::Protocol::RRP::Core::Domain'); use_ok('Net::DRI::Protocol::RRP::Core::Host'); use_ok('Net::DRI::Protocol::RRP::Core::Status'); use_ok('Net::DRI::Protocol::RRP::Core::Session'); use_ok('Net::DRI::Protocol::RRP::Connection'); use_ok('Net::DRI::Protocol::RRP'); use_ok('Net::DRI::Protocol::AFNIC::WS::Domain'); use_ok('Net::DRI::Protocol::AFNIC::WS::Message'); use_ok('Net::DRI::Protocol::AFNIC::WS'); use_ok('Net::DRI::Protocol::AFNIC::Email::Domain'); use_ok('Net::DRI::Protocol::EPP'); use_ok('Net::DRI::Protocol::EPP::Message'); use_ok('Net::DRI::Protocol::EPP::Connection'); use_ok('Net::DRI::Protocol::EPP::Util'); use_ok('Net::DRI::Protocol::EPP::Core::Status'); use_ok('Net::DRI::Protocol::EPP::Core::Contact'); use_ok('Net::DRI::Protocol::EPP::Core::Domain'); use_ok('Net::DRI::Protocol::EPP::Core::Host'); use_ok('Net::DRI::Protocol::EPP::Core::Session'); use_ok('Net::DRI::Protocol::EPP::Core::RegistryMessage'); use_ok('Net::DRI::Protocol::EPP::Extensions::GracePeriod'); use_ok('Net::DRI::Protocol::EPP::Extensions::E164'); use_ok('Net::DRI::Protocol::EPP::Extensions::SecDNS'); use_ok('Net::DRI::Protocol::EPP::Extensions::NSgroup'); use_ok('Net::DRI::Protocol::EPP::Extensions::EURid'); use_ok('Net::DRI::Protocol::EPP::Extensions::EURid::Sunrise'); use_ok('Net::DRI::Protocol::EPP::Extensions::EURid::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::EURid::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::EURid::Message'); use_ok('Net::DRI::Protocol::EPP::Extensions::EURid::Registrar'); use_ok('Net::DRI::Protocol::EPP::Extensions::EURid::Notifications'); use_ok('Net::DRI::Protocol::EPP::Extensions::SE'); use_ok('Net::DRI::Protocol::EPP::Extensions::SE::Extensions'); use_ok('Net::DRI::Protocol::EPP::Extensions::SE::Message'); use_ok('Net::DRI::Protocol::EPP::Extensions::PL'); use_ok('Net::DRI::Protocol::EPP::Extensions::PL::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::PL::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::PL::Message'); use_ok('Net::DRI::Protocol::EPP::Extensions::US'); use_ok('Net::DRI::Protocol::EPP::Extensions::US::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::VeriSign'); use_ok('Net::DRI::Protocol::EPP::Extensions::VeriSign::Sync'); use_ok('Net::DRI::Protocol::EPP::Extensions::VeriSign::IDNLanguage'); use_ok('Net::DRI::Protocol::EPP::Extensions::VeriSign::WhoisInfo'); use_ok('Net::DRI::Protocol::EPP::Extensions::VeriSign::NameStore'); use_ok('Net::DRI::Protocol::EPP::Extensions::VeriSign::PollLowBalance'); use_ok('Net::DRI::Protocol::EPP::Extensions::VeriSign::PollRGP'); use_ok('Net::DRI::Protocol::EPP::Extensions::VeriSign::JobsContact'); use_ok('Net::DRI::Protocol::EPP::Extensions::AT::Result'); use_ok('Net::DRI::Protocol::EPP::Extensions::AT::IOptions'); use_ok('Net::DRI::Protocol::EPP::Extensions::AT::Message'); use_ok('Net::DRI::Protocol::EPP::Extensions::IENUMAT'); use_ok('Net::DRI::Protocol::EPP::Extensions::CAT'); use_ok('Net::DRI::Protocol::EPP::Extensions::CAT::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::CAT::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::CAT::DefensiveRegistration'); use_ok('Net::DRI::Protocol::EPP::Extensions::AERO'); use_ok('Net::DRI::Protocol::EPP::Extensions::AERO::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::AERO::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::MOBI'); use_ok('Net::DRI::Protocol::EPP::Extensions::MOBI::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::DNSBE'); use_ok('Net::DRI::Protocol::EPP::Extensions::DNSBE::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::DNSBE::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::DNSBE::Message'); use_ok('Net::DRI::Protocol::EPP::Extensions::AT'); use_ok('Net::DRI::Protocol::EPP::Extensions::AT::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::AT::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::AT::ATResult'); use_ok('Net::DRI::Protocol::EPP::Extensions::COOP'); use_ok('Net::DRI::Protocol::EPP::Extensions::COOP::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::LU'); use_ok('Net::DRI::Protocol::EPP::Extensions::LU::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::LU::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::LU::Poll'); use_ok('Net::DRI::Protocol::EPP::Extensions::LU::Status'); use_ok('Net::DRI::Protocol::EPP::Extensions::CentralNic'); use_ok('Net::DRI::Protocol::EPP::Extensions::CentralNic::TTL'); use_ok('Net::DRI::Protocol::EPP::Extensions::CentralNic::WebForwarding'); use_ok('Net::DRI::Protocol::EPP::Extensions::CentralNic::Release'); use_ok('Net::DRI::Protocol::EPP::Extensions::ASIA'); use_ok('Net::DRI::Protocol::EPP::Extensions::ASIA::CED'); use_ok('Net::DRI::Protocol::EPP::Extensions::ASIA::IPR'); use_ok('Net::DRI::Protocol::EPP::Extensions::AU'); use_ok('Net::DRI::Protocol::EPP::Extensions::AU::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::E164Validation'); use_ok('Net::DRI::Protocol::EPP::Extensions::E164Validation::RFC5076'); use_ok('Net::DRI::Protocol::EPP::Extensions::Afilias'); use_ok('Net::DRI::Protocol::EPP::Extensions::Afilias::IDNLanguage'); use_ok('Net::DRI::Protocol::EPP::Extensions::Afilias::Restore'); use_ok('Net::DRI::Protocol::EPP::Extensions::NAME'); use_ok('Net::DRI::Protocol::EPP::Extensions::NAME::EmailFwd'); use_ok('Net::DRI::Protocol::EPP::Extensions::Nominet'); use_ok('Net::DRI::Protocol::EPP::Extensions::Nominet::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::Nominet::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::Nominet::Host'); use_ok('Net::DRI::Protocol::EPP::Extensions::Nominet::Account'); use_ok('Net::DRI::Protocol::EPP::Extensions::Nominet::Notifications'); use_ok('Net::DRI::Protocol::EPP::Extensions::SWITCH'); use_ok('Net::DRI::Protocol::EPP::Extensions::CZ'); use_ok('Net::DRI::Protocol::EPP::Extensions::CZ::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::CZ::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::CZ::NSSET'); use_ok('Net::DRI::Protocol::EPP::Extensions::NeuLevel::UIN'); use_ok('Net::DRI::Protocol::EPP::Extensions::NeuLevel::IDNLanguage'); use_ok('Net::DRI::Protocol::EPP::Extensions::NO'); use_ok('Net::DRI::Protocol::EPP::Extensions::NO::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::NO::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::NO::Host'); use_ok('Net::DRI::Protocol::EPP::Extensions::NO::Message'); use_ok('Net::DRI::Protocol::EPP::Extensions::NO::Result'); use_ok('Net::DRI::Protocol::EPP::Extensions::AFNIC'); use_ok('Net::DRI::Protocol::EPP::Extensions::AFNIC::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::AFNIC::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::AFNIC::Notifications'); use_ok('Net::DRI::Protocol::EPP::Extensions::AFNIC::Status'); use_ok('Net::DRI::Protocol::EPP::Extensions::BR'); use_ok('Net::DRI::Protocol::EPP::Extensions::BR::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::BR::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::PRO'); use_ok('Net::DRI::Protocol::EPP::Extensions::PRO::AV'); use_ok('Net::DRI::Protocol::EPP::Extensions::PRO::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::FCCN'); use_ok('Net::DRI::Protocol::EPP::Extensions::FCCN::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::FCCN::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::ARNES'); use_ok('Net::DRI::Protocol::EPP::Extensions::ARNES::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::ARNES::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::IT'); use_ok('Net::DRI::Protocol::EPP::Extensions::IT::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::IT::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::IT::Notifications'); use_ok('Net::DRI::Protocol::EPP::Extensions::IRegistry'); use_ok('Net::DRI::Protocol::EPP::Extensions::SIDN'); use_ok('Net::DRI::Protocol::EPP::Extensions::SIDN::Message'); use_ok('Net::DRI::Protocol::EPP::Extensions::SIDN::Notifications'); use_ok('Net::DRI::Protocol::EPP::Extensions::SIDN::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::SIDN::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::SIDN::Host'); use_ok('Net::DRI::Protocol::EPP::Extensions::CIRA'); use_ok('Net::DRI::Protocol::EPP::Extensions::CIRA::Notifications'); use_ok('Net::DRI::Protocol::EPP::Extensions::CIRA::Domain'); use_ok('Net::DRI::Protocol::EPP::Extensions::CIRA::Contact'); use_ok('Net::DRI::Protocol::EPP::Extensions::CIRA::Agreement'); use_ok('Net::DRI::Protocol::DAS'); use_ok('Net::DRI::Protocol::DAS::Message'); use_ok('Net::DRI::Protocol::DAS::Connection'); use_ok('Net::DRI::Protocol::DAS::Domain'); use_ok('Net::DRI::Protocol::DAS::AU'); use_ok('Net::DRI::Protocol::DAS::AU::Message'); use_ok('Net::DRI::Protocol::DAS::AU::Connection'); use_ok('Net::DRI::Protocol::DAS::AU::Domain'); use_ok('Net::DRI::Protocol::DAS::AdamsNames'); use_ok('Net::DRI::Protocol::DAS::AdamsNames::Message'); use_ok('Net::DRI::Protocol::DAS::AdamsNames::Connection'); use_ok('Net::DRI::Protocol::DAS::AdamsNames::Domain'); use_ok('Net::DRI::Protocol::DAS::SIDN'); use_ok('Net::DRI::Protocol::DAS::SIDN::Message'); use_ok('Net::DRI::Protocol::DAS::SIDN::Connection'); use_ok('Net::DRI::Protocol::DAS::SIDN::Domain'); use_ok('Net::DRI::Protocol::Whois'); use_ok('Net::DRI::Protocol::Whois::Message'); use_ok('Net::DRI::Protocol::Whois::Connection'); use_ok('Net::DRI::Protocol::Whois::Domain::common'); use_ok('Net::DRI::Protocol::Whois::Domain::COM'); use_ok('Net::DRI::Protocol::Whois::Domain::ORG'); use_ok('Net::DRI::Protocol::Whois::Domain::AERO'); use_ok('Net::DRI::Protocol::Whois::Domain::INFO'); use_ok('Net::DRI::Protocol::Whois::Domain::EU'); use_ok('Net::DRI::Protocol::Whois::Domain::BIZ'); use_ok('Net::DRI::Protocol::Whois::Domain::MOBI'); use_ok('Net::DRI::Protocol::Whois::Domain::NAME'); use_ok('Net::DRI::Protocol::Whois::Domain::LU'); use_ok('Net::DRI::Protocol::Whois::Domain::WS'); use_ok('Net::DRI::Protocol::Whois::Domain::SE'); use_ok('Net::DRI::Protocol::Whois::Domain::CAT'); use_ok('Net::DRI::Protocol::Whois::Domain::AT'); use_ok('Net::DRI::Protocol::Whois::Domain::TRAVEL'); use_ok('Net::DRI::Protocol::Whois::Domain::PT'); use_ok('Net::DRI::Protocol::OVH::WS'); use_ok('Net::DRI::Protocol::OVH::WS::Connection'); use_ok('Net::DRI::Protocol::OVH::WS::Message'); use_ok('Net::DRI::Protocol::OVH::WS::Account'); use_ok('Net::DRI::Protocol::OVH::WS::Domain'); use_ok('Net::DRI::Protocol::BookMyName::WS'); use_ok('Net::DRI::Protocol::BookMyName::WS::Message'); use_ok('Net::DRI::Protocol::BookMyName::WS::Account'); use_ok('Net::DRI::Protocol::BookMyName::WS::Domain'); use_ok('Net::DRI::Protocol::Gandi::WS'); use_ok('Net::DRI::Protocol::Gandi::WS::Message'); use_ok('Net::DRI::Protocol::Gandi::WS::Account'); use_ok('Net::DRI::Protocol::Gandi::WS::Domain'); use_ok('Net::DRI::Protocol::RRI'); use_ok('Net::DRI::Protocol::RRI::Connection'); use_ok('Net::DRI::Protocol::RRI::Contact'); use_ok('Net::DRI::Protocol::RRI::Message'); use_ok('Net::DRI::Protocol::RRI::Session'); use_ok('Net::DRI::Protocol::RRI::Domain'); use_ok('Net::DRI::Protocol::RRI::RegistryMessage'); use_ok('Net::DRI::Protocol::OpenSRS::XCP'); use_ok('Net::DRI::Protocol::OpenSRS::XCP::Account'); use_ok('Net::DRI::Protocol::OpenSRS::XCP::Domain'); use_ok('Net::DRI::Protocol::OpenSRS::XCP::Session'); use_ok('Net::DRI::Protocol::OpenSRS::XCP::Message'); use_ok('Net::DRI::Protocol::IRIS'); use_ok('Net::DRI::Protocol::IRIS::Message'); use_ok('Net::DRI::Protocol::IRIS::Core'); use_ok('Net::DRI::Protocol::IRIS::DCHK::Domain'); use_ok('Net::DRI::Protocol::IRIS::DCHK::Status'); use_ok('Net::DRI::Protocol::IRIS::XCP'); use_ok('Net::DRI::Protocol::AdamsNames::WS'); use_ok('Net::DRI::Protocol::AdamsNames::WS::Connection'); use_ok('Net::DRI::Protocol::AdamsNames::WS::Message'); use_ok('Net::DRI::Protocol::AdamsNames::WS::Domain'); } exit 0; Net-DRI-0.96/t/200protocol.t0000755000175000017500000000076211241157361015212 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::Protocol; use Test::More tests => 7; my $p; $p=Net::DRI::Protocol->new(); isa_ok($p,'Net::DRI::Protocol'); is($p->message(),undef,'empty message at init'); is_deeply($p->capabilities(),{},'empty capabilities at init'); $p->name('myname'); $p->version('1.5'); is($p->name(),'myname','name()'); is($p->version(),'1.5','version()'); is($p->nameversion(),'myname/1.5','nameversion()'); TODO: { local $TODO='other tests (factories, commands)'; ok(0); } exit 0; Net-DRI-0.96/t/150data_hosts.t0000755000175000017500000000477311023323067015510 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::Data::Hosts; use Test::More tests => 25; my $d=Net::DRI::Data::Hosts->new(); isa_ok($d,'Net::DRI::Data::Hosts'); $d=Net::DRI::Data::Hosts->new('ns.example.foo',['1.2.3.4','1.2.3.5']); $d->name('test1'); $d->loid(12345); isa_ok($d,'Net::DRI::Data::Hosts'); is($d->count(),1,'count()'); my @c; @c=$d->get_details(1); is_deeply($c[1],['1.2.3.4','1.2.3.5'],'get_details(integer) ip address'); is($d->name(),'test1','name()'); is($d->loid(),12345,'loid()'); @c=$d->get_details('ns.example.foo'); is_deeply($c[1],['1.2.3.4','1.2.3.5'],'get_details(name) ip address'); $d->add('ns.example.foo',['1.2.3.5']); @c=$d->get_details('ns.example.foo'); is_deeply($c[1],['1.2.3.4','1.2.3.5'],'get_details(name) ip address add 1'); $d->add('ns.example.foo',['1.2.3.6']); @c=$d->get_details('ns.example.foo'); is_deeply($c[1],['1.2.3.4','1.2.3.5','1.2.3.6'],'get_details(name) ip address add 2'); $d->add('ns.example.foo',[],['2001:0:0:0:8:800:200C:417A']); @c=$d->get_details('ns.example.foo'); is_deeply($c[1],['1.2.3.4','1.2.3.5','1.2.3.6'],'get_details(name) ip address add 3 ip4'); is_deeply($c[2],['2001:0:0:0:8:800:200C:417A'],'get_details(name) ip address add 3 ip6'); $d=Net::DRI::Data::Hosts->new('ns.example.foo',['1.2.3.4','1.2.3.4']); isa_ok($d,'Net::DRI::Data::Hosts'); @c=$d->get_details(1); is_deeply($c[1],['1.2.3.4'],'remove dups IP'); is(($d->get_names(1))[0],'ns.example.foo','get_names()'); my $dd=$d->add('ns2.example.foo',['1.2.10.4']); isa_ok($dd,'Net::DRI::Data::Hosts'); is_deeply($d,$dd,'add() returns the object itself'); @c=$d->get_names(); is_deeply(\@c,['ns.example.foo','ns2.example.foo'],'get_names() after add'); @c=$d->get_names(2); is_deeply(\@c,['ns.example.foo','ns2.example.foo'],'get_names(2) after add'); @c=$d->get_names(1); is_deeply(\@c,['ns.example.foo'],'get_names(1) after add'); $d->set(['ns.example.foo',['1.2.3.4','1.2.3.5']]); is($d->count(),1,'count() after set()'); @c=$d->get_details(1); is_deeply($c[1],['1.2.3.4','1.2.3.5'],'get_details(integer) ip address after set()'); $d->add('test.extra.parameters',[],[],{key1=>'v1',key2=>2}); @c=$d->get_details(2); isa_ok($c[-1],'HASH'); is_deeply($c[-1],{key1=>'v1',key2=>2},'correct retrieval of extra parameters'); $d->add('test.extra.parameters',[],[],{key2=>22,key3=>'whatever'}); @c=$d->get_details(2); is_deeply($c[-1],{key1=>'v1',key2=>22,key3=>'whatever'},'correct retrieval of extra parameters after merge'); TODO: { local $TODO='tests on add() with other params, new_set(), is_empty()'; ok(0); } exit 0; Net-DRI-0.96/t/632travel_epp.t0000755000175000017500000001365711241325705015531 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 9; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport, $count, $msg) = @_; $R1 = $msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2 ? $R2 : $E1 . '' . r() . $TRID . '' . $E2); } my $dri; eval { $dri = Net::DRI->new(10); }; print $@->as_string() if $@; $dri->{trid_factory} = sub { return 'ABC-12345'; }; $dri->add_registry('TRAVEL'); eval { $dri->target('TRAVEL')->add_current_profile('p1', 'test=EPP', { f_send=> \&mysend, f_recv=> \&myrecv }, {extensions=>['Net::DRI::Protocol::EPP::Extensions::NeuLevel::UIN']}); }; print $@->as_string() if $@; my $rc; my $s; my $d; my ($dh,@c); ############################################################################ ## Create a domain $R2 = $E1 . '' . r(1001,'Command completed successfully; ' . 'action pending') . $TRID . '' . $E2; my $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('TL1-TRAVEL'), 'tech'); $cs->add($dri->local_object('contact')->srid('SK1-TRAVEL'), 'admin'); eval { $rc = $dri->domain_create('jerusalem.travel', { pure_create => 1, ns => $dri->local_object('hosts')->add('dns1.syhosting.ch'), contact => $cs, duration => new DateTime::Duration(years => 2), auth => { pw => 'bulle.com' }, uin => 235}); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'domain create'); is($R1, 'jerusalem.travel2dns1.syhosting.chSK1-TRAVELTL1-TRAVELbulle.comUIN=235ABC-12345', 'domain create xml'); ## Renew a domain $R2 = $E1 . '' . r(1001,'Command completed successfully; ' . 'action pending') . $TRID . '' . $E2; eval { $rc = $dri->domain_renew('muenchhausen-airlines.travel', { current_expiration => new DateTime(year => 2006, month => 12, day => 24), duration => new DateTime::Duration(years => 2), uin => 423}); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'domain renew'); is($R1, 'muenchhausen-airlines.travel2006-12-242UIN=423ABC-12345', 'domain renew xml'); ## Restore a deleted domain $R2 = $E1 . '' . r(1001,'Command completed successfully; ' . 'action pending') . $TRID . '' . $E2; eval { $rc = $dri->domain_renew('deleted-by-accident.travel', { current_expiration => new DateTime(year => 2008, month => 12, day => 24), rgp => { code => 1, comment => 'Deleted by mistake'}, uin => 423}); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'domain restore'); is($R1, 'deleted-by-accident.travel2008-12-24RestoreReasonCode=1 RestoreComment=DeletedByMistake TrueData=Y ValidUse=Y UIN=423ABC-12345', 'domain restore xml'); #################################################################################################### exit(0); sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/622vnds_epp_e164validation.t0000755000175000017500000002241411350046057020007 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 6; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; use Net::DRI::DRD::VNDS; { no strict; no warnings; sub Net::DRI::DRD::VNDS::tlds { return ('e164.arpa'); }; sub Net::DRI::DRD::VNDS::verify_name_domain { return ''; }; } $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['E164Validation']}); my ($rc,$e,$toc); ######################################################################################################### ## Extension: E164Validation (RFC5076) $R2=$E1.''.r().'5.1.5.1.8.6.2.4.4.1.4.e164.arpaEXAMPLE1-REPjd1234sh8013sh8013ns1.example.comns2.example.comClientXClientY1999-04-03T22:00:00.0ZClientX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0Z2fooBARValidation-XVE-NMQClient-X2004-04-082004-10-07'.$TRID.''.$E2; $rc=$dri->domain_info('5.1.5.1.8.6.2.4.4.1.4.e164.arpa',{auth=>{pw=>'2fooBAR'}}); is($dri->get_info('exist'),1,'domain_info get_info(exist) +E164Validation'); $e=$dri->get_info('e164_validation_information'); is_deeply($e,[['EK77','urn:ietf:params:xml:ns:e164valex-1.1',{method_id=>'Validation-X',validation_entity_id=>'VE-NMQ',registrar_id=>'Client-X',execution_date=>'2004-04-08T00:00:00',expiration_date=>'2004-10-07T00:00:00'}]],'domain_info get_info(validation_information) +E164Validation'); $R2=''; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $rc=$dri->domain_create('5.1.5.1.8.6.2.4.4.1.4.e164.arpa',{pure_create=>1,duration=>DateTime::Duration->new(years=>1),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns2.example.com']),contact=>$cs,auth=>{pw=>'2fooBAR'},e164_validation_information=>[['EK77','urn:ietf:params:xml:ns:e164valex-1.1',{method_id=>'Validation-X',validation_entity_id=>'VE-NMQ',registrar_id=>'Client-X',execution_date=>DateTime->new(year=>2004,month=>4,day=>8),expiration_date=>DateTime->new(year=>2004,month=>10,day=>7)}]]}); is_string($R1,$E1.'5.1.5.1.8.6.2.4.4.1.4.e164.arpa1ns1.example.comns2.example.comjd1234sh8013sh80132fooBARValidation-XVE-NMQClient-X2004-04-082004-10-07ABC-12345'.$E2,'domain_create build +E164Validation'); $rc=$dri->domain_renew('5.1.5.1.8.6.2.4.4.1.4.e164.arpa',{duration => DateTime::Duration->new(years=>1), current_expiration => DateTime->new(year=>2005,month=>4,day=>9),e164_validation_information=>[['CAB176','urn:ietf:params:xml:ns:e164valex-1.1',{method_id=>'Validation-X',validation_entity_id=>'VE-NMQ',registrar_id=>'Client-X',execution_date=>'2005-03-30',expiration_date=>'2005-09-29'}]]}); is_string($R1,$E1.'5.1.5.1.8.6.2.4.4.1.4.e164.arpa2005-04-091Validation-XVE-NMQClient-X2005-03-302005-09-29ABC-12345'.$E2,'domain_renew build +E164Validation'); $rc=$dri->domain_transfer_start('5.1.5.1.8.6.2.4.4.1.4.e164.arpa',{auth=>{pw=>'2fooBAR',roid=>"HB1973-ZUE"},e164_validation_information=>[['LJ1126','urn:ietf:params:xml:ns:e164valex-1.1',{method_id=>'Validation-Y',validation_entity_id=>'VE2-LMQ',registrar_id=>'Client-Y',execution_date=>'2005-01-22',expiration_date=>'2005-07-21'}]]}); is_string($R1,$E1.'5.1.5.1.8.6.2.4.4.1.4.e164.arpa2fooBARValidation-YVE2-LMQClient-Y2005-01-222005-07-21ABC-12345'.$E2,'domain_transfer_request build +E164Validation'); $R2=''; $toc=$dri->local_object('changes'); $toc->add('e164_validation_information',[['EK2510','urn:ietf:params:xml:ns:e164valex-1.1',{method_id=>'Validation-X',validation_entity_id=>'VE-NMQ',registrar_id=>'Client-X',execution_date=>'2004-10-02',expiration_date=>'2005-04-01'}]]); $toc->del('e164_validation_information',['EK77']); $rc=$dri->domain_update('5.1.5.1.8.6.2.4.4.1.4.e164.arpa',$toc); is_string($R1,$E1.'5.1.5.1.8.6.2.4.4.1.4.e164.arpaValidation-XVE-NMQClient-X2004-10-022005-04-01ABC-12345'.$E2,'domain_update build +E164Validation'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/202protocol_resultstatus.t0000755000175000017500000000253711350046465020063 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::Protocol::ResultStatus; use Test::More tests => 18; my $n; $n=Net::DRI::Protocol::ResultStatus->new('epp',1000,undef,1,'Command completed successfully'); isa_ok($n,'Net::DRI::Protocol::ResultStatus'); is($n->is_success(),1,'epp is_success'); is($n->native_code(),1000,'epp native_code'); is($n->code(),1000,'epp code'); is($n->message(),'Command completed successfully','epp message'); is($n->as_string(0),'SUCCESS 1000 Command completed successfully','epp as_string(0)'); is($n->as_string(1),'SUCCESS 1000 Command completed successfully','epp as_string(1)'); $n=Net::DRI::Protocol::ResultStatus->new('rrp',200,1000,1,'Command completed successfully'); isa_ok($n,'Net::DRI::Protocol::ResultStatus'); is($n->is_success(),1,'rrp is_success'); is($n->native_code(),200,'rrp native_code'); is($n->code(),1000,'rrp code'); is($n->message(),'Command completed successfully','rrp message'); $n=Net::DRI::Protocol::ResultStatus->new('foobar'); isa_ok($n,'Net::DRI::Protocol::ResultStatus'); is($n->code(),2900,'foobar code'); $n=Net::DRI::Protocol::ResultStatus->new('rrp',0,undef,0); isa_ok($n,'Net::DRI::Protocol::ResultStatus'); is($n->code(),2900,'rrp undef not success code'); $n=Net::DRI::Protocol::ResultStatus->new('rrp',1,undef,1); isa_ok($n,'Net::DRI::Protocol::ResultStatus'); is($n->code(),1900,'rrp undef success code'); exit 0; Net-DRI-0.96/t/631cz_epp.t0000755000175000017500000006125411241325705014643 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 54; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1 = ''; our $E2 = ''; our $TRID = 'ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri; eval { $dri = Net::DRI->new(10); $dri->{trid_factory} = sub { return 'ABC-12345'; }; $dri->add_registry('CZ'); $dri->target('CZ')->add_current_profile('p1', 'test=Net::DRI::Protocol::EPP::Extensions::CZ', {f_send => \&mysend, f_recv => \&myrecv}); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } my $rc; my $s; my $d; my ($dh, @c); #################################################################################################### ## Contact operations ## Contact create $R2 = $E1 . 'Command completed successfullyTL1-CZ2008-04-25T18:20:51+02:00' . $TRID . '' . $E2; my $c = $dri->local_object('contact'); $c->srid('TL1-CZ'); $c->name('Tonnerre Lombard'); $c->org('SyGroup GmbH'); $c->street(['Gueterstrasse 86']); $c->city('Basel'); $c->sp('BS'); $c->pc('4053'); $c->cc('CH'); $c->voice('+41.61338033'); $c->fax('+41.613831467'); $c->email('tonnerre.lombard@sygroup.ch'); $c->auth({pw => 'blablabla'}); eval { $rc = $dri->contact_create($c); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'contact create success'); die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'TL1-CZTonnerre LombardSyGroup GmbHGueterstrasse 86BaselBS4053CH+41.61338033+41.613831467tonnerre.lombard@sygroup.chblablablaABC-12345' . $E2, 'contact create xml correct'); is($dri->get_info('crDate', 'contact', 'TL1-CZ'), '2008-04-25T18:20:51', 'contact create crdate'); $c = $dri->local_object('contact'); $c->srid('TL2-CZ'); ## Contact info $R2 = $E1 . 'Command completed successfullyTL2-CZC0000146169-CZObjekt is without restrictionsTonnerre LombardSyGroup GmbHGueterstrasse 86BaselBasel-Stadt4053CH+41.61338033+41.613831467tonnerre.lombard@sygroup.chREG-FRED_AREG-FRED_A2008-04-25T18:20:51+02:00REG-FRED_A2008-04-25T18:29:12+02:00blablabla' . $TRID . '' . $E2; eval { $rc = $dri->contact_info($c); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'contact info success'); $c = $dri->get_info('self', 'contact', 'TL2-CZ'); is(ref($c), 'Net::DRI::Data::Contact', 'contact info type'); is($c->srid(), 'TL2-CZ', 'contact info srid'); is($c->roid(), 'C0000146169-CZ', 'contact info roid'); is($c->name(), 'Tonnerre Lombard', 'contact info name'); is($c->org(), 'SyGroup GmbH', 'contact info org'); is_deeply($c->street(), ['Gueterstrasse 86'], 'contact info street'); is($c->city(), 'Basel', 'contact info city'); is($c->sp(), 'Basel-Stadt', 'contact info sp'); is($c->pc(), '4053', 'contact info pc'); is($c->voice(), '+41.61338033', 'contact info voice'); is($c->fax(), '+41.613831467', 'contact info fax'); is($c->email(), 'tonnerre.lombard@sygroup.ch', 'contact info email'); is($c->auth()->{pw}, 'blablabla', 'contact info authcode'); ## Contact update $R2 = $E1 . 'Command completed successfully' . $TRID . '' . $E2; my $todo = $dri->local_object('changes'); $c = $dri->local_object('contact'); $c->srid('TL2-CZ'); $c->street(['Gueterstrasse 86']); $c->city('Basel'); $c->sp('BS'); $c->fax(undef); $c->auth({pw => 'bliblablu'}); $todo->set('info', $c); eval { $rc = $dri->contact_update($c, $todo); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'contact update success'); is($R1, 'TL2-CZGueterstrasse 86BaselBSbliblabluABC-12345', 'contact update xml correct'); #################################################################################################### ## Domain operations ## Domain create $R2 = $E1 . 'Command completed successfullysygroup.cz2008-05-07T14:31:26+02:002009-05-07' . $TRID . '' . $E2; my $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('SG1-CZ'), 'registrant'); $cs->add($dri->local_object('contact')->srid('SK1-CZ'), 'admin'); eval { $rc = $dri->domain_create('sygroup.cz', { pure_create => 1, contact => $cs, nsset => 'nameservers', duration => DateTime::Duration->new(years => 2), auth => { pw => 'yumyumyum' } }); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } is($rc->is_success(), 1, 'domain create success'); die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'sygroup.cz2nameserversSG1-CZSK1-CZyumyumyumABC-12345' . $E2, 'domain create xml correct'); is($dri->get_info('crDate', 'domain', 'sygroup.cz'), '2008-05-07T14:31:26', 'domain create crdate'); is($dri->get_info('exDate', 'domain', 'sygroup.cz'), '2009-05-07T00:00:00', 'domain create exdate'); ## Domain info $R2 = $E1 . 'Command completed successfullysyhosting.czD0000152990-CZDomain is not generated into zoneTK1-CZTL1-CZREG-FRED_AREG-FRED_A2008-05-07T14:31:26+02:002009-05-07gnagnagna' . $TRID . '' . $E2; eval { $rc = $dri->domain_info('syhosting.cz'); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'syhosting.czABC-12345', 'domain info xml correct'); is($dri->get_info('name', 'domain', 'syhosting.cz'), 'syhosting.cz', 'domain_info name'); is($dri->get_info('roid', 'domain', 'syhosting.cz'), 'D0000152990-CZ', 'domain_info roid'); $cs = $dri->get_info('contact', 'domain', 'syhosting.cz'); is_deeply([$cs->types()], [qw(admin registrant)], 'domain_info contact types'); is($cs->get('admin')->srid(), 'TL1-CZ', 'domain_info contact admin'); is($cs->get('registrant')->srid(), 'TK1-CZ', 'domain_info contact registrant'); is($dri->get_info('crDate', 'domain', 'syhosting.cz'), '2008-05-07T14:31:26', 'domain_info crDate'); is($dri->get_info('crID', 'domain', 'syhosting.cz'), 'REG-FRED_A', 'domain_info crID'); is($dri->get_info('exDate', 'domain', 'syhosting.cz'), '2009-05-07T00:00:00', 'domain_info exDate'); is($dri->get_info('clID', 'domain', 'syhosting.cz'), 'REG-FRED_A', 'domain_info clID'); is($dri->get_info('auth', 'domain', 'syhosting.cz')->{pw}, 'gnagnagna', 'domain_info auth'); ## Domain renew $R2 = $E1 . 'Command completed successfullysybla.cz2010-05-07' . $TRID . '' . $E2; eval { $rc = $dri->domain_renew('sybla.cz', DateTime::Duration->new(years => 2), DateTime->new(year => 2008, month => 5, day => 7)); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'sybla.cz2008-05-072ABC-12345', 'domain renew xml correct'); is($dri->get_info('exDate', 'domain', 'sybla.cz'), '2010-05-07T00:00:00', 'domain_renew exDate'); ## Domain update $R2 = $E1 . 'Command completed successfully' . $TRID . '' . $E2; $todo = $dri->local_object('changes'); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('TL1-TZ'), 'admin'); $todo->del('contact', $cs); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('DA1-TZ'), 'admin'); $todo->add('contact', $cs); $todo->set('nsset', 'alfredservers'); $todo->set('auth', { pw => 'coincoin' }); eval { $rc = $dri->domain_update('sybla.cz', $todo); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'sybla.czDA1-TZTL1-TZalfredserverscoincoinABC-12345', 'domain renew xml correct'); ############################################################################### ## NSSET object ## NSSET check $R2 = $E1 . 'Command completed successfullytestserversprodservers' . $TRID . '' . $E2; my $ro = $dri->remote_object('nsset'); eval { $rc = $ro->check('testservers', 'prodservers'); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'testserversprodserversABC-12345', 'nsset check xml correct'); is($dri->get_info('exist', 'nsset', 'testservers'), 1, 'nsset check existent'); is($dri->get_info('exist', 'nsset', 'prodservers'), 0, 'nsset check nonexistent'); ## NSSET create $R2 = $E1 . 'Command completed successfully' . $TRID . '' . $E2; my $ns = $dri->local_object('hosts'); $ns->add('dns1.syhosting.ch'); $ns->add('dns2.syhosting.cz', [], ['2001:6b0:1:ea:202:a5ff:fecd:13a6']); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('TL1-CZ'), 'tech'); eval { $rc = $ro->create('testservers', { ns => $ns, contact => $cs, reportlevel => 5, auth => { pw => 'gnagnagna' } }); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'testserversdns1.syhosting.chdns2.syhosting.cz2001:6b0:1:ea:202:a5ff:fecd:13a6TL1-CZgnagnagna5ABC-12345', 'nsset create xml correct'); ## NSSET update $R2 = $E1 . 'Command completed successfully' . $TRID . '' . $E2; $todo = $dri->local_object('changes'); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('TL1-CZ'), 'tech'); $todo->del('contact', $cs); $ns = $dri->local_object('hosts'); $ns->add('dns2.syhosting.cz', [], ['2001:6b0:1:ea:202:a5ff:fecd:13a6']); $todo->del('ns', $ns); $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('DA1-CZ'), 'tech'); $todo->add('contact', $cs); $ns = $dri->local_object('hosts'); $ns->add('dns3.syhosting.ch', ['194.25.2.129'], ['2001:3f8:bcd::1']); $todo->add('ns', $ns); $todo->set('auth', { pw => 'bliblablu'}); $todo->set('reportlevel', 4); eval { $rc = $ro->update('nameservers', $todo); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'nameserversdns3.syhosting.ch194.25.2.1292001:3f8:bcd::1DA1-CZdns2.syhosting.czTL1-CZbliblablu4ABC-12345', 'nsset update xml correct'); ## NSSET delete $R2 = $E1 . 'Command completed successfully' . $TRID . '' . $E2; eval { $rc = $ro->delete('testservers'); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'testserversABC-12345', 'nsset delete xml correct'); ## NSSET info $R2 = $E1 . 'Command completed successfullyprodserversN0000164015-CZObjekt is without restrictionsREG-FRED_AREG-FRED_A2008-05-26T17:41:29+02:00blablabladns1.syhosting.cz193.219.115.46dns3.syhosting.cz212.101.151.35dns2.syhosting.cz193.219.115.51TL1-CZ0' . $TRID . '' . $E2; eval { $rc = $ro->info('prodservers'); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'prodserversABC-12345', 'nsset info xml correct'); is($dri->get_info('name', 'nsset', 'prodservers'), 'prodservers', 'nsset info name'); is($dri->get_info('roid', 'nsset', 'prodservers'), 'N0000164015-CZ', 'nsset info roid'); is($dri->get_info('crID', 'nsset', 'prodservers'), 'REG-FRED_A', 'nsset info crID'); is($dri->get_info('crDate', 'nsset', 'prodservers'), '2008-05-26T17:41:29', 'nsset info crDate'); is($dri->get_info('auth', 'nsset', 'prodservers')->{pw}, 'blablabla', 'nsset info auth'); is(join(',', $dri->get_info('status', 'nsset', 'prodservers')->list_status()), 'ok', 'nsset info status'); is($dri->get_info('reportlevel', 'nsset', 'prodservers'), 0, 'nsset info reportlevel'); $ns = $dri->get_info('self', 'nsset', 'prodservers'); is(join(',', $ns->get_names()), 'dns1.syhosting.cz,dns3.syhosting.cz,dns2.syhosting.cz', 'nsset info ns'); ## NSSET transfer query $R2 = $E1 . 'Command completed successfully' . $TRID . '' . $E2; eval { $rc = $ro->transfer_query('nameservers', { auth => { pw => 'gnagnagna' }}); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'nameserversgnagnagnaABC-12345', 'nsset transfer query xml correct'); ## NSSET transfer request $R2 = $E1 . 'Command completed successfully' . $TRID . '' . $E2; eval { $rc = $ro->transfer_request('nameservers', { auth => { pw => 'gnagnagna' }}); }; if ($@) { if (ref($@) eq 'Net::DRI::Exception') { die($@->as_string()); } else { die($@); } } die('Error ' . $rc->code() . ': ' . $rc->message()) unless ($rc->is_success()); is($R1, 'nameserversgnagnagnaABC-12345', 'nsset transfer request xml correct'); ############################################################################### exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/612vnds_epp_whoisinfo.t0000755000175000017500000000642711241325410017257 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 3; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['Net::DRI::Protocol::EPP::Extensions::VeriSign::WhoisInfo']}); ######################################################################################################### ## Example taken from EPP-Whois-Info-Ext.pdf $R2='Command completed successfullyexample2.comEXAMPLE1-VRSNClientXClientY2005-11-11T18:09:52.0354Z2fooBARExample Registrar Inc.whois.example.comhttp://www.example.comiris.example.comABC-1234554321-XYZ'; my $rc=$dri->domain_info('example2.com',{whois_info => 1}); is($R1,$E1.'example2.com1ABC-12345'.$E2,'domain_info build'); is($rc->is_success(),1,'domain_info is_success'); my $w=$dri->get_info('whois_info'); is_deeply($w,{ registrar => 'Example Registrar Inc.', whois_server => 'whois.example.com', url => 'http://www.example.com', iris_server => 'iris.example.com' },'domain_info get_info(whois_info)'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/630afilias_epp_restore.t0000755000175000017500000000537211241325705017400 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Data::Dumper; use Test::More tests => 3; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport, $count, $msg) = @_; $R1 = $msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2 ? $R2 : $E1 . '' . r() . $TRID . '' . $E2); } my $dri; eval { $dri = Net::DRI->new(10); }; print $@->as_string() if $@; $dri->{trid_factory} = sub { return 'ABC-12345'; }; $dri->add_registry('HN'); eval { $dri->target('HN')->add_current_profile('p1', 'test=EPP', { f_send=> \&mysend, f_recv=> \&myrecv }, {extensions=>['Net::DRI::Protocol::EPP::Extensions::Afilias::Restore']}); }; print $@->as_string() if $@; my $rc; my $s; my $d; my ($dh,@c); #################################################################################################### ## Restore a deleted domain $R2 = $E1 . '' . r(1001,'Command completed successfully; ' . 'action pending') . $TRID . '' . $E2; eval { $rc = $dri->domain_renew('deleted-by-accident.com.hn', { current_expiration => new DateTime(year => 2008, month => 12, day => 24), rgp => 1}); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'Domain successfully recovered'); is($R1, 'deleted-by-accident.com.hn2008-12-24ABC-12345', 'Recover Domain XML correct'); #################################################################################################### exit(0); sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/637pro_epp.t0000755000175000017500000003765011241325755015045 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Data::Dumper; use Test::More tests => 59; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport, $count, $msg) = @_; $R1 = $msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2 ? $R2 : $E1 . '' . r() . $TRID . '' . $E2); } my $dri; eval { $dri = Net::DRI->new(10); }; print $@->as_string() if $@; $dri->{trid_factory} = sub { return 'ABC-12345'; }; $dri->add_registry('PRO'); eval { $dri->target('PRO')->add_current_profile('p1', 'test=Net::DRI::Protocol::EPP::Extensions::PRO', { f_send=> \&mysend, f_recv=> \&myrecv }); }; print $@->as_string() if $@; my $rc; my $s; my $d; my ($dh,@c); ############################################################################ ## Create a domain $R2 = $E1 . '' . r(1001,'Command completed successfully; ' . 'action pending') . $TRID . '' . $E2; my $cs = $dri->local_object('contactset'); $cs->add($dri->local_object('contact')->srid('testcontact1'), 'tech'); $cs->add($dri->local_object('contact')->srid('testcontact2'), 'admin'); $cs->add($dri->local_object('contact')->srid('testcontact3'), 'registrant'); eval { $rc = $dri->domain_create('wirzenius.law.pro', { pure_create => 1, ns => $dri->local_object('hosts')->add('ns1.test.pro')-> add('ns2.test.pro'), duration => new DateTime::Duration(years => 4), contact => $cs, pro => { type => 'Resolving', auth => { pw => 'FAKETEXT', roid => 'RPRODEF-SAMPLE-1' } }, auth => { pw => 'testTest' } }); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'domain create'); is($R1, 'wirzenius.law.pro4ns1.test.prons2.test.protestcontact3testcontact2testcontact1testTestResolvingFAKETEXTABC-12345', 'domain create xml'); eval { $rc = $dri->domain_create('bucerius.law.pro', { pure_create => 1, ns => $dri->local_object('hosts')->add('ns1.test.pro')-> add('ns2.test.pro'), duration => new DateTime::Duration(years => 4), contact => $cs, pro => { type => 'Resolving', auth => { pw => 'FAKETEXT', roid => 'RPRODEF-SAMPLE-1' }, activate => 1 }, auth => { pw => 'testTest' } }); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'domain activate'); is($R1, 'bucerius.law.pro4ns1.test.prons2.test.protestcontact3testcontact2testcontact1testTestResolvingFAKETEXTABC-12345', 'domain activate xml'); ## Update a domain $R2 = $E1 . '' . r(1001,'Command completed successfully; ' . 'action pending') . $TRID . '' . $E2; my $todo = $dri->local_object('changes'); $todo->set('pro', +{ redirect => 'localhost.localnet' }); eval { $rc = $dri->domain_update('localhost.eng.pro', $todo); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'domain update'); is($R1, 'localhost.eng.prolocalhost.localnetABC-12345', 'domain update xml'); ## Query a domain $R2 = $E1 . '' . r(1000,'Command completed successfully') . 'cocaine.cpa.proDM1234-PROjordynbuchananjordynbuchanansh8013ns1.cocaine.cpa.prons1.test.prons2.test.prons2.cocaine.cpa.proRegistrarXRegistrarY1999-04-03T22:00:00.0ZRegistrarX1999-12-03T09:00:00.0Z2005-04-03T22:00:00.0Z2000-04-08T09:00:00.0ZtestTestPremiumIPDefensiveCokeUS1991-12-11349876' . $TRID . '' . $E2; eval { $rc = $dri->domain_info('cocaine.cpa.pro'); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'domain query is_success'); is($R1, 'cocaine.cpa.proABC-12345', 'domain query xml'); my $pro = $dri->get_info('pro', 'domain', 'cocaine.cpa.pro'); isa_ok($pro, 'HASH'); is($dri->get_info('name', 'domain', 'cocaine.cpa.pro'), 'cocaine.cpa.pro', 'domain query name'); is($pro->{type}, 'PremiumIPDefensive', 'domain query type'); is($pro->{tmname}, 'Coke', 'domain query trademark name'); is($pro->{tmjurisdiction}, 'US', 'domain query trademark jurisdiction'); is($pro->{tmdate}->ymd, '1991-12-11', 'domain query trademark date'); is($pro->{tmnumber}, '349876', 'domain query trademark number'); is($pro->{redirect}, undef, 'domain query redirect'); ############################################################################ ## Check for existence of A/V contacts $R2 = $E1 . '' . r(1000,'Command completed successfully') . 'sh8013sah8013In use8013sah' . $TRID . '' . $E2; eval { $rc=$dri->av_check(['sh8013', 'sah8013', '8013sah']); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'a/v check is_success'); is($R1, 'sh8013sah80138013sahABC-12345', 'a/v check xml'); is($dri->get_info('exist', 'av', 'sh8013'), 0, 'av exist sh8013'); is($dri->get_info('exist', 'av', 'sah8013'), 1, 'av exist sah8013'); is($dri->get_info('exist_reason', 'av', 'sah8013'), 'In use', 'av exist_reason sah8013'); is($dri->get_info('exist', 'av', '8013sah'), 0, 'av exist 8013sah'); ## Create an A/V contact $R2 = $E1 . '' . r(1000,'Command completed successfully') . 'sh8013SH8013-REP1999-04-03T22:00:00.0Zhttps://avhost.registrypro.pro/index.jsp?id=sh8013' . $TRID . '' . $E2; eval { $rc = $dri->av_create('sh8013', +{ type => 'Individual-Pro-OOB', host => 'registryTK-registrarUI', contact => $dri->local_object('contact')->srid('con9486') }); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'a/v create is_success'); is($R1, 'sh8013Individual-Pro-OOBregistryTK-registrarUIcon9486ABC-12345', 'a/v create xml'); is($dri->get_info('id', 'av', 'sh8013'), 'sh8013', 'av info id'); is($dri->get_info('roid', 'av', 'sh8013'), 'SH8013-REP', 'av info roid'); is($dri->get_info('crDate', 'av', 'sh8013'), '1999-04-03T22:00:00', 'av info crDate'); is($dri->get_info('avurl', 'av', 'sh8013'), 'https://avhost.registrypro.pro/index.jsp?id=sh8013', 'av info avurl'); ## Create an A/V contact $R2 = $E1 . '' . r(1000,'Command completed successfully') . 'sh8014SH8014-REPClientX1999-04-03T22:00:00.0Zcon9486Individual-Pro-OOBregistryTK-registryUIClientX1999-12-03T09:00:00.0Zavchk94839043905jujf8w99er3k5oob001medNY-USsuccess1999-12-03T08:32:17.0Zcomplete' . $TRID . '' . $E2; eval { $rc = $dri->av_info('sh8014'); }; print(STDERR $@->as_string()) if ($@); isa_ok($rc, 'Net::DRI::Protocol::ResultStatus'); is($rc->is_success(), 1, 'a/v info is_success'); is($R1, 'sh8014ABC-12345', 'a/v info xml'); is($dri->get_info('id', 'av', 'sh8014'), 'sh8014', 'av info id'); is($dri->get_info('roid', 'av', 'sh8014'), 'SH8014-REP', 'av info roid'); is($dri->get_info('clID', 'av', 'sh8014'), undef, 'av info clID'); is($dri->get_info('crID', 'av', 'sh8014'), 'ClientX', 'av info crID'); is($dri->get_info('upID', 'av', 'sh8014'), 'ClientX', 'av info upID'); is($dri->get_info('crDate', 'av', 'sh8014'), '1999-04-03T22:00:00', 'av info crDate'); is($dri->get_info('upDate', 'av', 'sh8014'), '1999-12-03T09:00:00', 'av info upDate'); is($dri->get_info('avurl', 'av', 'sh8014'), undef, 'av info avurl'); is($dri->get_info('type', 'av', 'sh8014'), 'Individual-Pro-OOB', 'av info type'); is($dri->get_info('host', 'av', 'sh8014'), 'registryTK-registryUI', 'av info host'); isa_ok($dri->get_info('contact', 'av', 'sh8014'), 'Net::DRI::Data::Contact'); is($dri->get_info('contact', 'av', 'sh8014')->srid(), 'con9486', 'av info contact'); my $res = $dri->get_info('avresult', 'av', 'sh8014'); isa_ok($res, 'HASH'); is($res->{checkid}, 'avchk9483', 'av info result checkid'); is($res->{persfingerprint}, '9043905jujf8w9', 'av info result persfp'); is($res->{proffingerprint}, '9er3k5', 'av info result proffp'); is($res->{oobmethodid}, 'oob001', 'av info result oobmethodid'); is($res->{profession}, 'med', 'av info result profession'); is($res->{jurisdiction}, 'NY-US', 'av info result jurisdiction'); is($res->{status}, 'complete', 'av info result status'); is($res->{avresult}, 'success', 'av info result avresult'); is($res->{avDate}, '1999-12-03T08:32:17', 'av info result avDate'); ############################################################################ exit(0); sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/242epp_connection.t0000755000175000017500000000426111043673531016362 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::Protocol::EPP::Connection; use Encode (); use Test::More tests => 5; can_ok('Net::DRI::Protocol::EPP::Connection',qw(login logout keepalive parse_greeting parse_login parse_logout read_data write_message)); TODO: { local $TODO="tests on login() logout() keepalive() parse_greeting() parse_login() parse_logout() read_data() write_message() find_code()"; ok(0); } ## This was basically in t/241epp_message.t before but needs to be moved SKIP: { eval { require Net::DRI::Protocol::EPP::Message; }; skip 'Unable to correctly load Net::DRI::Protocol::EPP::Message',3 if $@; my $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $msg->command(['check','host:check','xmlns:host="urn:ietf:params:xml:ns:host-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:host-1.0 host-1.0.xsd"']); $msg->command_body([['host:name','ns1.example.com'],['host:name','ns2.example.com'],['host:name','ns3.example.com']]); $msg->cltrid('ABC-12345'); $s=< ns1.example.com ns2.example.com ns3.example.com ABC-12345 EOF $msg->version('1.0'); my $m=Net::DRI::Protocol::EPP::Connection->write_message(undef,$msg); ok(!Encode::is_utf8($m),'Unicode : XML string sent on network is bytes not characters (version 1.0)'); my $l=unpack('N',substr($m,0,4)); $m=substr($m,4); is($l,4+length(_n($s)),'Unicode : XML string length (version 1.0)'); is($m,_n($s),'Unicode : string is ok after removing length (version 1.0)'); } exit 0; sub _n { my $in=shift; $in=~s/^\s+//gm; $in=~s/\n/ /g; $in=~s/>\s+ 1; can_ok('Net::DRI::Data::RegistryObject',qw/new target/); exit 0; Net-DRI-0.96/t/640pt_epp.t0000755000175000017500000003537611350045660014660 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime; use DateTime::Duration; use Test::More tests => 22; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our ($R1,$R2); sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1;} sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('PT'); $dri->target('PT')->add_current_profile('p1','test=Net::DRI::Protocol::EPP::Extensions::FCCN',{f_send=>\&mysend,f_recv=>\&myrecv}); print $@->as_string() if $@; my ($rc,$s,$d,$dh,@c,$co); #################################################################################################### ## Domain commands $R2=$E1.''.r().'mytestdomain.pt2006-03-21T11:58:50.6Z4569356'.$TRID.''.$E2; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('FCZA-142520-FCCN'); $cs->set($c1,'registrant'); $cs->set($c1,'tech'); $rc=$dri->domain_create('mytestdomain.pt',{pure_create=>1,duration=>DateTime::Duration->new(years=>1),contact=>$cs,legitimacy=>1,registration_basis=>'090',add_period=>1,next_possible_registration=>0,auto_renew=>1}); is($R1,$E1.'mytestdomain.pt1FCZA-142520-FCCNFCZA-142520-FCCN101ABC-12345'.$E2,'domain_create build'); is($dri->get_info('roid'),'4569356','domain_create get_info(roid)'); ## Example corrected, domain:name needs a namespace $R2=$E1.'Object existsmytestdomain2.ptThere was a previous submission for the same domain name that is still in pending create. To put a new submission into the next-possible-registration queue resend this command with the next-possible-registration extension element set to true'.$TRID.''.$E2; $rc=$dri->domain_create('mytestdomain2.pt',{pure_create=>1,duration=>DateTime::Duration->new(years=>1),contact=>$cs,legitimacy=>1,registration_basis=>'090',add_period=>1,next_possible_registration=>0,auto_renew=>1}); is($rc->is_success(),0,'domain_create is_success'); is($rc->code(),2302,'domain_create code'); is_deeply([$rc->get_extended_results()],[{from=>'eppcom:extValue',type=>'rawxml',message=>'mytestdomain2.pt',reason=>'There was a previous submission for the same domain name that is still in pending create. To put a new submission into the next-possible-registration queue resend this command with the next-possible-registration extension element set to true',lang=>'en'}],'domain_create extra info'); $R2=$E1.''.r().'mytestdomain3.pt2221881-FCCNFCZA-142520-FCCNFCZA-142520-FCCNns1.anything.ptns2.everything.ptFCZA-142520-FCCNFCZA-142520-FCCN2006-03-21T12:19:25.000ZFCZA-142520-FCCN2006-03-21T12:19:25.000Z2007-03-21T12:19:25.000Ztrue'.$TRID.''.$E2; $rc=$dri->domain_info('mytestdomain3.pt',{roid=>'2221881-FCCN'}); is($R1,$E1.'mytestdomain3.pt2221881-FCCNABC-12345'.$E2,'domain_info'); is($dri->get_info('legitimacy'),1,'domain_info get_info(legitimacy)'); is($dri->get_info('registration_basis'),30,'domain_info get_info(registration_basis)'); is($dri->get_info('auto_renew'),1,'domain_info get_info(auto_renew)'); $R2=''; $toc=$dri->local_object('changes'); $toc->add('ns',$dri->local_object('hosts')->add('ns.mytestdomain3.pt',['19.0.2.2'])); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('c112574'),'tech'); $toc->add('contact',$cs); $rc=$dri->domain_update('mytestdomain3.pt',$toc,{roid => '33591'}); is($R1,$E1.'mytestdomain3.ptns.mytestdomain3.pt19.0.2.2c11257433591ABC-12345'.$E2,'domain_update build'); $R2=''; $rc=$dri->domain_renew('example.pt',{duration => DateTime::Duration->new(years=>5), current_expiration => DateTime->new(year=>2008,month=>4,day=>3),roid=>26368,auto_renew=>0,not_renew=>0}); is($R1,$E1.'example.pt2008-04-0352636800ABC-12345'.$E2,'domain_renew build'); $R2=''; $rc=$dri->domain_delete('example.pt',{pure_delete => 1,roid=>33591}); is($R1,$E1.'example.pt33591ABC-12345'.$E2,'domain_delete build'); $R2=''; $rc=$dri->domain_renounce('telepac2.pt',{roid=>33591}); is($R1,$E1.'telepac2.pt33591ABC-12345'.$E2,'domain_renounce build'); ######################################################################################################### ## Contact commands $R2=$E1.''.r().'c10064412007-03-21T10:02:45Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('NIC-Handle'); $co->name('Smith Bill'); $co->street(['Blue Tower']); $co->city('Lisboa'); $co->pc('1900'); $co->cc('PT'); $co->voice('+351.963456569'); $co->fax('+351.213456569'); $co->email('noreply@dns.pt'); $co->auth({pw=>'pA55w0rD'}); $co->type('individual'); $co->identification({type=>'010',value=>'234561728'}); $co->mobile('+351.916589304'); $rc=$dri->contact_create($co); is_string($R1,$E1.'NIC-HandleSmith BillBlue TowerLisboa1900PT+351.963456569+351.213456569noreply@dns.ptpA55w0rDindividual234561728+351.916589304ABC-12345'.$E2,'contact_create build'); is($rc->is_success(),1,'contact_create is_success'); is($dri->get_info('id'),'c1006441','contact_create get_info(id)'); is($dri->get_info('action','contact','c1006441'),'create','contact_create get_info(action)'); is($dri->get_info('exist','contact','c1006441'),1,'contact_create get_info(exist)'); $R2=$E1.''.r().'c10064491006449-FCCNSmith BillBlue TowerParis571234FR+33.16345656+33.16345656noreply@dns.ptt0000052006-03-21T10:04:54.000Z2006-03-21T10:04:54.000Zindividual234561728+33.9689304'.$TRID.''.$E2; $co->srid('c1006449'); $rc=$dri->contact_info($co); $co=$dri->get_info('self'); is($co->type(),'individual','contact_info get_info(self) type'); is_deeply($co->identification(),{type=>'010',value=>'234561728'},'contact_info get_info(self) identification'); is($co->mobile(),'+33.9689304','contact_info get_info(self) mobile'); $R2=''; $co=$dri->local_object('contact')->srid('c1006441')->auth({pw=>'pas5w0Rd'}); $toc=$dri->local_object('changes'); my $co2=$dri->local_object('contact'); $co2->street(['Green Tower']); $co2->city('London'); $co2->pc('1111'); $co2->cc('GB'); $co2->voice('+44.1865332156'); $co2->fax('+44.1865332157'); $co2->email('noreply@dns.co.uk'); $co2->mobile('+351.1865332156'); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'c1006441Green TowerLondon1111GB+44.1865332156+44.1865332157noreply@dns.co.ukpas5w0Rd+351.1865332156ABC-12345'.$E2,'contact_update build'); exit 0; Net-DRI-0.96/t/201protocol_message.t0000755000175000017500000000026511043674031016713 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::Protocol::Message; use Test::More tests=>1; can_ok('Net::DRI::Protocol::Message','new','is_success','result_status','parse','version'); exit 0; Net-DRI-0.96/t/617vnds_epp_polllowbalance.t0000755000175000017500000000540211241325473020256 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 11; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my $rc; my $s; my $d; my ($dh,@c); $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2004-03-25T18:20:07.0078ZLow Account Balance (SRS)Test Registar10001080'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info last_id'); is(''.$dri->get_info('qdate','message',12345),'2004-03-25T18:20:07','message get_info qdate'); is($dri->get_info('content','message',12345),'Low Account Balance (SRS)','message get_info msg'); is($dri->get_info('lang','message',12345),'en','message get_info lang'); is($dri->get_info('object_type','message',12345),'session','message get_info object_type'); is($dri->get_info('action','message',12345),'lowbalance_notification','message get_info rgp_notification'); is($dri->get_info('registrar_name','message',12345),'Test Registar','message get_info registrar_name'); is($dri->get_info('credit_limit','message',12345),1000,'message get_info credit_limit'); is($dri->get_info('credit_threshold_type','message',12345),'PERCENT','message get_info credit_threshold_type'); is($dri->get_info('credit_threshold','message',12345),10,'message get_info credit_threshold'); is($dri->get_info('available_credit','message',12345),80,'message get_info available_credit'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/605vnds_epp_nsgroup.t0000755000175000017500000002324411241325177016757 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 18; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new({cache_ttl=>10,trid_factory => sub { return 'clientref-123007'}}); $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=EPP',{f_send=>\&mysend,f_recv=>\&myrecv},{extensions=>['NSgroup']}); my ($rc,$toc); ######################################################################################################### ## Extension: NSgroup my $nsg1=$dri->remote_object('nsgroup'); $dri->{registries}->{VNDS}->{trid}=sub { return 'clientref-123007'; }; $R2='Command completed successfullymynsgroup1Content check okclientref-123007dnsbe-1543'; my $c1=$dri->local_object('hosts'); $c1->name('mynsgroup1'); $c1->add('ns1.nameserver.be'); $c1->add('ns2.nameserver.be'); $rc=$nsg1->create($c1); is($R1,$E1.'mynsgroup1ns1.nameserver.bens2.nameserver.beclientref-123007'.$E2,'nsgroup create build'); is($rc->is_success(),1,'nsgroup create is_success'); $R2='Command completed successfullymynsgroup1Content check okclientref-123007dnsbe-1545'; my $c2=$dri->local_object('hosts'); $c2->name('mynsgroup1'); $c2->add('ns1.nameserver.be'); $c2->add('ns2.nameserver.be'); $c2->add('ns3.nameserver.be'); $toc=$dri->local_object('changes'); $toc->set('ns',$c2); $rc=$nsg1->update($c1,$toc); is($R1,$E1.'mynsgroup1ns1.nameserver.bens2.nameserver.bens3.nameserver.beclientref-123007'.$E2,'nsgroup update build'); is($rc->is_success(),1,'nsgroup update is_success'); $R2='Command completed successfullymynsgroup1Content check okclientref-123007dnsbe-1545'; $rc=$nsg1->delete($c1); is($R1,$E1.'mynsgroup1clientref-123007'.$E2,'nsgroup delete build'); is($rc->is_success(),1,'nsgroup delete is_success'); $R2='Command completed successfullymynsgroup1mynsgroup2clientref-123007dnsbe-1545'; $rc=$nsg1->delete($c1); $rc=$nsg1->check_multi('mynsgroup1','mynsgroup2'); is($R1,$E1.'mynsgroup1mynsgroup2clientref-123007'.$E2,'nsgroup check_multi is_success'); is($rc->is_success(),1,'nsgroup check_multi is_success'); is($dri->get_info('exist','nsgroup','mynsgroup1'),1,'nsgroup check_multi get_info(exist) 1/2'); is($dri->get_info('exist','nsgroup','mynsgroup2'),0,'nsgroup check_multi get_info(exist) 2/2'); is($dri->get_info('action','nsgroup','mynsgroup1'),'check','nsgroup check_multi get_info(action) 1/2'); is($dri->get_info('action','nsgroup','mynsgroup2'),'check','nsgroup check_multi get_info(action) 2/2'); $R2='Command completed successfullymynsgroup1ns1.nameserver.bens2.nameserver.beclientref-123007dnsbe-1545'; $rc=$nsg1->info($c1); is($R1,$E1.'mynsgroup1clientref-123007'.$E2,'nsgroup info build'); is($rc->is_success(),1,'nsgroup info is_success'); is_deeply($dri->get_info('self'),$c1,'nsgroup info get_info(self)'); is($dri->get_info('action'),'info','nsgroup info get_info(action)'); is($dri->get_info('exist'),1,'nsgroup info get_info(exist)'); is($dri->get_info('exist','nsgroup','mynsgroup1'),1,'nsgroup info get_info(exist) +cache'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/626nominet_epp.t0000755000175000017500000017553511350046033015707 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use DateTime::Duration; use Test::More tests => 304; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('Nominet'); $dri->target('Nominet')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my ($rc,$s,$d,$dh,@c,$co); # ## Domain commands $R2=$E1.''.r().'example.co.ukexample2.co.uk'.$TRID.''.$E2; $rc=$dri->domain_check_multi('example.co.uk','example2.co.uk'); is_string($R1,$E1.'example.co.ukexample2.co.ukABC-12345'.$E2,'domain_check build'); is($rc->is_success(),1,'domain_check_multi is_success'); is($dri->get_info('exist','domain','example.co.uk'),1,'domain_check_multi get_info(exist) 1/2'); is($dri->get_info('exist','domain','example2.co.uk'),0,'domain_check_multi get_info(exist) 2/2'); $R2=$E1.''.r().'example.co.ukRegistration request being processed.S123456Mr R. StrantR. S. IndustriesSTRANI123456N2102 High StreetCarfaxOxfordOxfordshireOX1 1DFGBC12345Mr R.Strant01865 12345601865 123456r.strant@strant.co.ukTESTdomains@isp.com1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZC23456Ms S. Strant01865 12345701865 123456s.strant@strant.co.ukTESTdomains@isp.com1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZC12347A. Ccountant01865 657893acc@billing.co.ukTESTdomains@isp.com1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZTESTTEST1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZTESTTEST1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0Z2007-12-03T09:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_info('example.co.uk'); is_string($R1,$E1.'example.co.ukABC-12345'.$E2,'domain_info build'); is($rc->is_success(),1,'domain_info is_success'); is($dri->get_info('action'),'info','domain_info get_info(action)'); is($dri->get_info('exist'),1,'domain_info get_info(exist)'); is($dri->get_info('reg-status'),'Registration request being processed.','domain_info get_info(reg-status)'); $co=$dri->get_info('contact'); isa_ok($co,'Net::DRI::Data::ContactSet','domain_info get_info(contact)'); is_deeply([$co->types()],['admin','billing','registrant'],'domain_info get_info(contact) types'); $d=$co->get('registrant'); isa_ok($d,'Net::DRI::Data::Contact','domain_info get_info(contact) get(registrant)'); is($d->roid(),'S123456','domain_info get_info(contact) get(registrant) roid'); is($d->name(),'Mr R. Strant','domain_info get_info(contact) get(registrant) name'); is($d->org(),'R. S. Industries','domain_info get_info(contact) get(registrant) org/trad-name'); is($d->type(),'STRA','domain_info get_info(contact) get(registrant) type'); is($d->co_no(),'NI123456','domain_info get_info(contact) get(registrant) co_no'); is($d->opt_out(),'N','domain_info get_info(contact) get(registrant) opt_out'); is_deeply($d->street(),['2102 High Street','Carfax'],'domain_info get_info(contact) get(registrant) street'); is($d->city(),'Oxford','domain_info get_info(contact) get(registrant) city'); is($d->sp(),'Oxfordshire','domain_info get_info(contact) get(registrant) sp/county'); is($d->pc(),'OX1 1DF','domain_info get_info(contact) get(registrant) pc/postcode'); is($d->cc(),'GB','domain_info get_info(contact) get(registrant) country'); $d=($co->get('admin'))[0]; isa_ok($d,'Net::DRI::Data::Contact','domain_info get_info(contact) get(admin1)'); is($dri->get_info('action','contact',$d->roid()),'info','domain_info get_info(action,contact,admin1->roid)'); is($dri->get_info('exist','contact',$d->roid()),1,'domain_info get_info(exist,contact,admin1->roid)'); is($d->roid(),'C12345','domain_info get_info(contact) get(admin1) roid'); is($d->name(),'Mr R.Strant','domain_info get_info(contact) get(admin1) name'); is($d->voice(),'01865 123456','domain_info get_info(contact) get(admin1) voice'); is($d->fax(),'01865 123456','domain_info get_info(contact) get(admin1) fax'); is($d->email(),'r.strant@strant.co.uk','domain_info get_info(contact) get(admin1) email'); is($dri->get_info('clID','contact',$d->roid()),'TEST','domain_info get_info(clID,contact,admin1->roid)'); is($dri->get_info('crID','contact',$d->roid()),'domains@isp.com','domain_info get_info(crID,contact,admin1->roid)'), $d=$dri->get_info('crDate','contact',$d->roid()); isa_ok($d,'DateTime','domain_info get_info(crDate,contact,admin1->roid)'); is(''.$d,'1999-04-03T22:00:00','domain_info get_info(crDate,contact,admin1->roid) value'); is($dri->get_info('upID'),'domains@isp.com','domain_info get_info(upID,contact,admin1->roid)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','domain_info get_info(upDate,contact,admin1->roid)'); is(''.$d,'1999-12-03T09:00:00','domain_info get_info(upDate,contact,admin1->roid) value'); $d=($co->get('admin'))[1]; isa_ok($d,'Net::DRI::Data::Contact','domain_info get_info(contact) get(admin2)'); is($dri->get_info('action','contact',$d->roid()),'info','account_info get_info(action,contact,admin2->roid)'); is($dri->get_info('exist','contact',$d->roid()),1,'account_info get_info(exist,contact,admin2->roid)'); is($d->roid(),'C23456','domain_info get_info(contact) get(admin2) roid'); is($d->name(),'Ms S. Strant','domain_info get_info(contact) get(admin2) name'); is($d->voice(),'01865 123457','domain_info get_info(contact) get(admin2) voice'); is($d->fax(),'01865 123456','domain_info get_info(contact) get(admin2) fax'); is($d->email(),'s.strant@strant.co.uk','domain_info get_info(contact) get(admin2) email'); is($dri->get_info('clID','contact',$d->roid()),'TEST','domain_info get_info(clID,contact,admin2->roid)'); is($dri->get_info('crID','contact',$d->roid()),'domains@isp.com','domain_info get_info(crID,contact,admin2->roid)'), $d=$dri->get_info('crDate','contact',$d->roid()); isa_ok($d,'DateTime','domain_info get_info(crDate,contact,admin2->roid)'); is(''.$d,'1999-04-03T22:00:00','domain_info get_info(crDate,contact,admin2->roid) value'); is($dri->get_info('upID'),'domains@isp.com','domain_info get_info(upID,contact,admin2->roid)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','domain_info get_info(upDate,contact,admin2->roid)'); is(''.$d,'1999-12-03T09:00:00','domain_info get_info(upDate,contact,admin2->roid) value'); $d=($co->get('billing'))[0]; isa_ok($d,'Net::DRI::Data::Contact','domain_info get_info(contact) get(billing1)'); is($dri->get_info('action','contact',$d->roid()),'info','account_info get_info(action,contact,billing1->roid)'); is($dri->get_info('exist','contact',$d->roid()),1,'domain_info get_info(exist,contact,billing1->roid)'); is($d->roid(),'C12347','domain_info get_info(contact) get(billing1) roid'); is($d->name(),'A. Ccountant','domain_info get_info(contact) get(billing1) name'); is($d->voice(),'01865 657893','domain_info get_info(contact) get(billing1) voice'); is($d->email(),'acc@billing.co.uk','domain_info get_info(contact) get(billing1) email'); is($dri->get_info('clID','contact',$d->roid()),'TEST','domain_info get_info(clID,contact,billing1->roid)'); is($dri->get_info('crID','contact',$d->roid()),'domains@isp.com','domain_info get_info(crID,contact,billing1->roid)'), $d=$dri->get_info('crDate','contact',$d->roid()); isa_ok($d,'DateTime','domain_info get_info(crDate,contact,billing1->roid)'); is(''.$d,'1999-04-03T22:00:00','domain_info get_info(crDate,contact,billing1->roid) value'); is($dri->get_info('upID'),'domains@isp.com','domain_info get_info(upID,contact,billing1->roid)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','domain_info get_info(upDate,contact,billing1->roid)'); is(''.$d,'1999-12-03T09:00:00','domain_info get_info(upDate,contact,billing1->roid) value'); is($dri->get_info('clID','account','S123456'),'TEST','domain_info get_info(clID,account,registrant->srid)'); is($dri->get_info('crID','account','S123456'),'TEST','domain_info get_info(crID,account,registrant->srid)'), $d=$dri->get_info('crDate','account','S123456'); isa_ok($d,'DateTime','domain_info get_info(crDate,account,registrant->srid)'); is(''.$d,'1999-04-03T22:00:00','domain_info get_info(crDate,account,registrant->srid) value'); is($dri->get_info('upID','account','S123456'),'domains@isp.com','domain_info get_info(upID,account,registrant->srid)'); $d=$dri->get_info('upDate','account','S123456'); isa_ok($d,'DateTime','domain_info get_info(upDate,account,registrant->srid)'); is(''.$d,'1999-12-03T09:00:00','domain_info get_info(upDate,account,registrant->srid) value'); is($dri->get_info('clID'),'TEST','domain_info get_info(clID)'); is($dri->get_info('crID'),'TEST','domain_info get_info(crID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_info get_info(crDate)'); is(''.$d,'1999-04-03T22:00:00','domain_info get_info(crDate) value'); is($dri->get_info('upID'),'domains@isp.com','domain_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','domain_info get_info(upDate)'); is(''.$d,'1999-12-03T09:00:00','domain_info get_info(upDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_info get_info(exDate)'); is(''.$d,'2007-12-03T09:00:00','domain_info get_info(exDate) value'); $R2=''; $rc=$dri->domain_delete('example.co.uk',{pure_delete=>1}); is_string($R1,$E1.'example.co.ukABC-12345'.$E2,'domain_delete build'); is($rc->is_success(),1,'domain_delete is_success'); $R2=$E1.''.r().'example.co.uk2007-04-03T22:00:00.0Z'.$TRID.''.$E2; $rc=$dri->domain_renew('example.co.uk',{duration => DateTime::Duration->new(years=>2)}); is_string($R1,$E1.'example.co.uk2ABC-12345'.$E2,'domain_renew build'); is($dri->get_info('action'),'renew','domain_renew get_info(action)'); is($dri->get_info('exist'),1,'domain_renew get_info(exist)'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_renew get_info(exDate)'); is(''.$d,'2007-04-03T22:00:00','domain_renew get_info(exDate) value'); $R2=''; $rc=$dri->domain_transfer_start('example.co.uk',{registrar_tag => 'TEST', account_id => '123456'}); is_string($R1,$E1.'example.co.ukTEST123456ABC-12345'.$E2,'domain_transfer_request build'); is($rc->is_success(),1,'domain_transfer_request is_success'); ## The domain is not really used for accept/refuse, nor even sent to registry, but must be there, whatever value it has as long as it is a domain name in the .UK registry $R2=''; $rc=$dri->domain_transfer_accept('whatever.co.uk',{case_id => 10001}); is_string($R1,$E1.'10001ABC-12345'.$E2,'domain_transfer_accept build'); is($rc->is_success(),1,'domain_transfer_accept is_success'); $R2=''; $rc=$dri->domain_transfer_refuse('whatever.co.uk',{case_id => 10001}); is_string($R1,$E1.'10001ABC-12345'.$E2,'domain_transfer_accept build'); is($rc->is_success(),1,'domain_transfer_refuse is_success'); $R2=$E1.''.r().'whatever.co.uk100029-UKMr R. StrantC100081-UKMr R. StrantC100082-UKA. CcountantC100083-UKMs S. Strant2005-10-14T13:40:502007-10-14T13:40:50YOU ARE WARNED !'.$TRID.''.$E2; $dh=$dri->local_object('hosts'); $dh->add('ns0.whatever.co.uk',['1.2.3.4']); $dh->add('ns3.example.net'); my $cs=$dri->local_object('contactset'); $co=$dri->local_object('contact'); $co->name('Mr R. Strant'); $co->org('R. S. Industries'); $co->type('LTD'); $co->co_no('NI123456'); $co->opt_out('N'); $co->street(['2102 High Street','Carfax']); $co->city('Oxford'); $co->sp('Oxfordshire'); $co->pc('OX1 1DF'); $co->cc('GB'); $cs->set($co,'registrant'); $co=$dri->local_object('contact'); $co->name('Mr R. Strant'); $co->voice('01865 123456'); $co->fax('01865 123456'); $co->email('r.strant@strant.co.uk'); $cs->set($co,'admin'); $co=$dri->local_object('contact'); $co->name('Ms S. Strant'); $co->voice('01865 123457'); $co->fax('01865 123456'); $co->email('s.strant@strant.co.uk'); $cs->add($co,'admin'); $co=$dri->local_object('contact'); $co->name('A. Ccountant'); $co->voice('01865 657893'); $co->email('acc@billing.co.uk'); $cs->set($co,'billing'); $rc=$dri->domain_create('whatever.co.uk',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dh,contact=>$cs,'recur-bill'=>'bc'}); is_string($R1,$E1.'whatever.co.uk2Mr R. StrantR. S. IndustriesLTDNI123456N2102 High StreetCarfaxOxfordOxfordshireOX1 1DFGBMr R. Strant01865 12345601865 123456r.strant@strant.co.ukMs S. Strant01865 12345701865 123456s.strant@strant.co.ukA. Ccountant01865 657893acc@billing.co.ukns0.whatever.co.uk1.2.3.4ns3.example.netbcABC-12345'.$E2,'domain_create build with new account'); is($rc->is_success(),1,'domain_create is_success'); $cs=$dri->get_info('contact'); isa_ok($cs,'Net::DRI::Data::ContactSet'); is_deeply([$cs->types()],['admin','billing','registrant'],'get_info(contact) has 3 types'); $co=$cs->get('registrant'); isa_ok($co,'Net::DRI::Data::Contact::Nominet'); is($co->srid(),'100029-UK','get_info(contact) registrant srid'); is($co->name(),'Mr R. Strant','get_info(contact) registrant name'); my @co=$cs->get('admin'); is(scalar(@co),2,'get_info(contact) admin count'); isa_ok($co[0],'Net::DRI::Data::Contact::Nominet'); is($co[0]->srid(),'C100081-UK','get_info(contact) admin1 srid'); is($co[0]->name(),'Mr R. Strant','get_info(contact) admin1 name'); isa_ok($co[1],'Net::DRI::Data::Contact::Nominet'); is($co[1]->srid(),'C100083-UK','get_info(contact) admin2 srid'); is($co[1]->name(),'Ms S. Strant','get_info(contact) admin2 name'); $co=$cs->get('billing'); isa_ok($co,'Net::DRI::Data::Contact::Nominet'); is($co->srid(),'C100082-UK','get_info(contact) billing srid'); is($co->name(),'A. Ccountant','get_info(contact) billing name'); is($dri->get_info('exist','contact','C100082-UK'),1,'get_info(exist,contact,C100082-UK)'); is($dri->get_info('roid','contact','C100082-UK'),'C100082-UK','get_info(roid,contact,C100082-UK)'); my $co2=$dri->get_info('self','contact','C100082-UK'); is_deeply($co2,$co,'get_info(self,contact,C100082-UK'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_create get_info(crDate)'); is($d.'','2005-10-14T13:40:50','domain_create get_info(crDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_create get_info(exDate)'); is($d.'','2007-10-14T13:40:50','domain_create get_info(exDate) value'); is($dri->get_info('warning'),'YOU ARE WARNED !','domain_create get_info(warning)'); my $toc=$dri->local_object('changes'); $cs=$dri->local_object('contactset'); $co=$dri->local_object('contact'); $co->srid(1); ## just make it any true value to make sure it is a contact:update and not a contact:create ; the value itself is not used during account:update anyway $co->email('admin@strant.co.uk'); $cs->set($co,'admin'); $toc->set('contact',$cs); $dh=$dri->local_object('hosts'); $dh->add('ns2.example1.co.uk'); $toc->set('ns',$dh); $toc->set('auto-bill',''); $toc->set('next-bill',5); $rc=$dri->domain_update('whatever.co.uk',$toc); is_string($R1,$E1.'whatever.co.ukadmin@strant.co.ukns2.example1.co.uk5ABC-12345'.$E2,'domain_update_build'); is($rc->is_success(),1,'domain_update is_success'); $dri->cache_clear(); ## this is needed to make sure that calls below to host_info & contact_info do in fact do the query and not take results from cache ################################################################################################################## ## Host commands $R2=$E1.''.r().'NS12345ns1.example.co.uk10.10.10.10TESTTEST1999-04-03T22:00:00.0ZTEST1999-12-03T09:00:00.0Z'.$TRID.''.$E2; $rc=$dri->host_info('NS12345'); is_string($R1,$E1.'NS12345ABC-12345'.$E2,'host_info build'); is($dri->get_info('action'),'info','host_info get_info(action)'); is($dri->get_info('exist'),1,'host_info get_info(exist)'); is($dri->get_info('roid'),'NS12345','host_info get_info(roid)'); $s=$dri->get_info('self'); isa_ok($s,'Net::DRI::Data::Hosts','host_info get_info(self)'); my ($name,$ip4,$ip6,$rextra)=$s->get_details(1); is($name,'ns1.example.co.uk','host_info self name'); isa_ok($rextra,'HASH','host_info self extra info'); is($rextra->{roid},'NS12345','host_info self roid'); is_deeply($ip4,['10.10.10.10'],'host_info self ip4'); is($dri->get_info('clID'),'TEST','host_info get_info(clID)'); is($dri->get_info('crID'),'TEST','host_info get_info(crID)'); is($dri->get_info('upID'),'TEST','host_info get_info(upID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','host_info get_info(crDate)'); is($d.'','1999-04-03T22:00:00','host_info get_info(crDate) value'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','host_info get_info(upDate)'); is($d.'','1999-12-03T09:00:00','host_info get_info(upDate) value'); $R2=$E1.''.r().$TRID.''.$E2; $toc=$dri->local_object('changes'); $toc->set('name','ns0.example2.co.uk'); $rc=$dri->host_update('NS1001',$toc); is_string($R1,$E1.'NS1001ns0.example2.co.ukABC-12345'.$E2,'host_update build'); is($rc->is_success(),1,'host_update is_success'); ######################################################################################################### ## Contact commands $co=$dri->local_object('contact'); isa_ok($co,'Net::DRI::Data::Contact::Nominet','contact'); $co->srid('T1'); is($co->roid(),'T1','contact roid = srid'); $co->roid('T2'); is($co->srid(),'T2','contact srid = roid'); $R2=$E1.''.r().'C12345Mr Contact01865 12345601865 123456r.strant@strant.co.ukTESTTEST1999-04-03T22:00:00.0ZTEST1999-12-03T09:00:00.0Z'.$TRID.''.$E2; $co=$dri->local_object('contact')->srid('C12345'); $rc=$dri->contact_info($co); is_string($R1,$E1.'C12345ABC-12345'.$E2,'contact_info build'); is($rc->is_success(),1,'contact_info is_success'); is($dri->get_info('action'),'info','contact_info get_info(action)'); is($dri->get_info('exist'),1,'contact_info get_info(exist)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::Contact','contact_info get_info(self)'); is($co->srid(),'C12345','contact_info get_info(self) srid'); is($co->roid(),'C12345','contact_info get_info(self) roid'); is($co->name(),'Mr Contact','contact_info get_info(self) name'); is($co->voice(),'01865 123456','contact_info get_info(self) voice'); is($co->fax(),'01865 123456','contact_info get_info(self) fax'); is($co->email(),'r.strant@strant.co.uk','contact_info get_info(self) email'); is($dri->get_info('clID'),'TEST','contact_info get_info(clID)'); is($dri->get_info('crID'),'TEST','contact_info get_info(crID)'), $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','contact_info get_info(crDate)'); is(''.$d,'1999-04-03T22:00:00','contact_info get_info(crDate) value'); is($dri->get_info('upID'),'TEST','contact_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','contact_info get_info(upDate)'); is(''.$d,'1999-12-03T09:00:00','contact_info get_info(upDate) value'); $R2=''; $co=$dri->local_object('contact')->srid('C11001'); $toc=$dri->local_object('changes'); $co->fax(''); $co->email('contact@example.co.uk'); $toc->set('info',$co); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'C11001contact@example.co.ukABC-12345'.$E2,'contact_update build'); is($rc->is_success(),1,'contact_update is_success'); #################################################################################################### ## Account $R2=$E1.''.r().'S123456Mr R. StrantR. S. IndustriesSTRANI123456N2102 High StreetCarfaxOxfordOxfordshireOX1 1DFGBC12345Mr R.Strant01865 12345601865 123456r.strant@strant.co.ukTESTdomains@isp.com1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZC23456Ms S. Strant01865 12345701865 123456s.strant@strant.co.ukTESTdomains@isp.com1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZC12347A. Ccountant01865 657893acc@billing.co.ukTESTdomains@isp.com1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZTESTTEST1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0Z'.$TRID.''.$E2; $rc=$dri->account_info('S123456'); is_string($R1,$E1.'S123456ABC-12345'.$E2,'account_info build'); is($rc->is_success(),1,'account_info is_success'); is($dri->get_info('action'),'info','account_info get_info(action)'); is($dri->get_info('exist'),1,'account_info get_info(exist)'); is($dri->get_info('roid'),'S123456','account_info get_info(roid)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::ContactSet','account_info get_info(self)'); is_deeply([$co->types()],[qw/admin billing registrant/],'account_info get_info(self) types'); $d=$co->get('registrant'); isa_ok($d,'Net::DRI::Data::Contact','account_info get_info(self) get(registrant)'); is($d->roid(),'S123456','account_info get_info(self) get(registrant) roid'); is($d->name(),'Mr R. Strant','account_info get_info(self) get(registrant) name'); is($d->org(),'R. S. Industries','account_info get_info(self) get(registrant) org/trad-name'); is($d->type(),'STRA','account_info get_info(self) get(registrant) type'); is($d->co_no(),'NI123456','account_info get_info(self) get(registrant) co_no'); is($d->opt_out(),'N','account_info get_info(self) get(registrant) opt_out'); is_deeply($d->street(),['2102 High Street','Carfax'],'account_info get_info(self) get(registrant) street'); is($d->city(),'Oxford','account_info get_info(self) get(registrant) city'); is($d->sp(),'Oxfordshire','account_info get_info(self) get(registrant) sp/county'); is($d->pc(),'OX1 1DF','account_info get_info(self) get(registrant) pc/postcode'); is($d->cc(),'GB','account_info get_info(self) get(registrant) country'); $d=($co->get('admin'))[0]; isa_ok($d,'Net::DRI::Data::Contact','account_info get_info(self) get(admin1)'); is($dri->get_info('action','contact',$d->roid()),'info','account_info get_info(action,contact,admin1->roid)'); is($dri->get_info('exist','contact',$d->roid()),1,'account_info get_info(exist,contact,admin1->roid)'); is($d->roid(),'C12345','account_info get_info(self) get(admin1) roid'); is($d->name(),'Mr R.Strant','account_info get_info(self) get(admin1) name'); is($d->voice(),'01865 123456','account_info get_info(self) get(admin1) voice'); is($d->fax(),'01865 123456','account_info get_info(self) get(admin1) fax'); is($d->email(),'r.strant@strant.co.uk','account_info get_info(self) get(admin1) email'); is($dri->get_info('clID','contact',$d->roid()),'TEST','account_info get_info(clID,contact,admin1->roid)'); is($dri->get_info('crID','contact',$d->roid()),'domains@isp.com','account_info get_info(crID,contact,admin1->roid)'), $d=$dri->get_info('crDate','contact',$d->roid()); isa_ok($d,'DateTime','account_info get_info(crDate,contact,admin1->roid)'); is(''.$d,'1999-04-03T22:00:00','account_info get_info(crDate,contact,admin1->roid) value'); is($dri->get_info('upID'),'domains@isp.com','account_info get_info(upID,contact,admin1->roid)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','account_info get_info(upDate,contact,admin1->roid)'); is(''.$d,'1999-12-03T09:00:00','account_info get_info(upDate,contact,admin1->roid) value'); $d=($co->get('admin'))[1]; isa_ok($d,'Net::DRI::Data::Contact','account_info get_info(self) get(admin2)'); is($dri->get_info('action','contact',$d->roid()),'info','account_info get_info(action,contact,admin2->roid)'); is($dri->get_info('exist','contact',$d->roid()),1,'account_info get_info(exist,contact,admin2->roid)'); is($d->roid(),'C23456','account_info get_info(self) get(admin2) roid'); is($d->name(),'Ms S. Strant','account_info get_info(self) get(admin2) name'); is($d->voice(),'01865 123457','account_info get_info(self) get(admin2) voice'); is($d->fax(),'01865 123456','account_info get_info(self) get(admin2) fax'); is($d->email(),'s.strant@strant.co.uk','account_info get_info(self) get(admin2) email'); is($dri->get_info('clID','contact',$d->roid()),'TEST','account_info get_info(clID,contact,admin2->roid)'); is($dri->get_info('crID','contact',$d->roid()),'domains@isp.com','account_info get_info(crID,contact,admin2->roid)'), $d=$dri->get_info('crDate','contact',$d->roid()); isa_ok($d,'DateTime','account_info get_info(crDate,contact,admin2->roid)'); is(''.$d,'1999-04-03T22:00:00','account_info get_info(crDate,contact,admin2->roid) value'); is($dri->get_info('upID'),'domains@isp.com','account_info get_info(upID,contact,admin2->roid)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','account_info get_info(upDate,contact,admin2->roid)'); is(''.$d,'1999-12-03T09:00:00','account_info get_info(upDate,contact,admin2->roid) value'); $d=($co->get('billing'))[0]; isa_ok($d,'Net::DRI::Data::Contact','account_info get_info(self) get(billing1)'); is($dri->get_info('action','contact',$d->roid()),'info','account_info get_info(action,contact,billing1->roid)'); is($dri->get_info('exist','contact',$d->roid()),1,'account_info get_info(exist,contact,billing1->roid)'); is($d->roid(),'C12347','account_info get_info(self) get(billing1) roid'); is($d->name(),'A. Ccountant','account_info get_info(self) get(billing1) name'); is($d->voice(),'01865 657893','account_info get_info(self) get(billing1) voice'); is($d->email(),'acc@billing.co.uk','account_info get_info(self) get(billing1) email'); is($dri->get_info('clID','contact',$d->roid()),'TEST','account_info get_info(clID,contact,billing1->roid)'); is($dri->get_info('crID','contact',$d->roid()),'domains@isp.com','account_info get_info(crID,contact,billing1->roid)'), $d=$dri->get_info('crDate','contact',$d->roid()); isa_ok($d,'DateTime','account_info get_info(crDate,contact,billing1->roid)'); is(''.$d,'1999-04-03T22:00:00','account_info get_info(crDate,contact,billing1->roid) value'); is($dri->get_info('upID'),'domains@isp.com','account_info get_info(upID,contact,billing1->roid)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','account_info get_info(upDate,contact,billing1->roid)'); is(''.$d,'1999-12-03T09:00:00','account_info get_info(upDate,contact,billing1->roid) value'); is($dri->get_info('clID'),'TEST','account_info get_info(clID)'); is($dri->get_info('crID'),'TEST','account_info get_info(crID)'), $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','account_info get_info(crDate)'); is(''.$d,'1999-04-03T22:00:00','account_info get_info(crDate) value'); is($dri->get_info('upID'),'domains@isp.com','account_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','account_info get_info(upDate)'); is(''.$d,'1999-12-03T09:00:00','account_info get_info(upDate) value'); $toc=$dri->local_object('changes'); $cs=$dri->local_object('contactset'); $co=$dri->local_object('contact'); $co->org('R. S. Industries'); $co->type('STRA'); $co->co_no('NI123456'); $cs->set($co,'registrant'); $co=$dri->local_object('contact'); $cs->add($co,'registrant'); ## second empty slot is for the billing addr $co=$dri->local_object('contact'); $co->name('Ms S. Strant'); $co->voice('01865 123457'); $co->fax('01865 123456'); $co->email('s.strant@strant.co.uk'); $cs->set($co,'admin'); $co=$dri->local_object('contact'); $cs->set($co,'billing'); $co=$dri->local_object('contact'); $co->srid(1); ## just make it any true value to make sure it is a contact:update and not a contact:create ; the value itself is not used during account:update anyway $co->voice('01865 232564'); $cs->add($co,'admin'); $toc->set('contact',$cs); $rc=$dri->account_update('286467',$toc); is_string($R1,$E1.'286467R. S. IndustriesSTRANI123456Ms S. Strant01865 12345701865 123456s.strant@strant.co.uk01865 232564ABC-12345'.$E2,'account_update build'); $R2=$E1.''.r().'100029-UKMr R. StrantC100081-UKMr R. Strant2008-01-12T15:00:12'.$TRID.''.$E2; $rc=$dri->account_fork('567867845',{domains=>[qw/example1.co.uk example2.co.uk example3.co.uk/]}); is_string($R1,$E1.'567867845example1.co.ukexample2.co.ukexample3.co.ukABC-12345'.$E2,'account_fork build'); is($rc->is_success(),1,'account_fork is_success'); is($dri->get_info('fork_to'),'100029-UK','account_fork get_info(fork_to)'); is($dri->get_info('action','account','100029-UK'),'fork','account_fork get_info(action)'); is($dri->get_info('exist','account','100029-UK'),1,'account_fork get_info(exist)'); $co=$dri->get_info('self','account','100029-UK'); isa_ok($co,'Net::DRI::Data::ContactSet','account_fork get_info(self)'); is_deeply([$co->types()],[qw/admin registrant/],'account_fork get_info(self) types'); $d=$co->get('registrant'); isa_ok($d,'Net::DRI::Data::Contact','account_fork get_info(self) get(registrant)'); is($d->roid(),'100029-UK','account_fork get_info(self) get(registrant) roid'); is($d->name(),'Mr R. Strant','account_fork get_info(self) get(registrant) name'); $d=($co->get('admin'))[0]; isa_ok($d,'Net::DRI::Data::Contact','account_fork get_info(self) get(admin1)'); is($d->roid(),'C100081-UK','account_fork get_info(self) get(admin1) roid'); is($d->name(),'Mr R. Strant','account_fork get_info(self) get(admin1) name'); $rc=$dri->account_merge('567867845',{roid_source=>[qw/99999/],names=>['Company X Ltd'],domains=>[qw/epp-example1.co.uk epp-example2.co.uk epp-example3.co.uk/]}); is_string($R1,$E1.'56786784599999Company X Ltdepp-example1.co.ukepp-example2.co.ukepp-example3.co.ukABC-12345'.$E2,'account_merge build'); #################################################################################################### ## Notifications ## http://www.nominet.org.uk/registrars/systems/epp/referralreject/ $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2007-09-26T07:31:30Referral Rejected Notificationepp-example2.ltd.ukV205 Registrant does not match domain name'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info last_id 1'); is($dri->get_info('last_id','message','session'),12345,'message get_info last_id 2'); is($dri->get_info('id','message',12345),12345,'message get_info id'); is(''.$dri->get_info('qdate','message',12345),'2007-09-26T07:31:30','message get_info qdate'); is($dri->get_info('content','message',12345),'Referral Rejected Notification','message get_info msg'); is($dri->get_info('lang','message',12345),'en','message get_info lang'); is($dri->get_info('object_type','message','12345'),'domain','message get_info object_type'); is($dri->get_info('object_id','message','12345'),'epp-example2.ltd.uk','message get_info id'); is($dri->get_info('action','message','12345'),'fail','message get_info action'); ## with this, we know what action has triggered this delayed message is($dri->get_info('exist','domain','epp-example2.ltd.uk'),0,'message get_info(exist,domain,DOM)'); is($dri->get_info('fail_reason','domain','epp-example2.ltd.uk'),'V205 Registrant does not match domain name','message get_info(reason,domain,DOM)'); ## http://www.nominet.org.uk/registrars/systems/epp/registrarchange/ ## We only do a very simple parse $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2005-10-06T10:29:30ZRegistrar Change Notificationp@automaton-example.org.ukEXAMPLEauto-example1.co.ukRegistered until expiry dateNS1015-UKepp-example1.co.ukEXAMPLE-TAGEXAMPLE-TAGexample@epp-example.co.uk2005-06-03T12:00:002007-06-03T12:00:00epp-example2.co.ukRenewal requiredEXAMPLE-TAGexample@epp-example2.co.uk2005-06-03T12:00:002007-06-03T12:00:00123456Mr R. StrantR. S. IndustriesSTRANI123456N2102 High StreetCarfaxOxfordOxfordshireOX1 1DFGBC12345Mr R.Strant01865 12345601865 123456r.strant@strant.co.ukTESTdomains@isp.com1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZTESTTEST1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0Z'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),123456,'message get_info(last_id) 2'); is($dri->get_info('action','message',123456),'registrar_change','message get_info(action)'); is($dri->get_info('orig','message',123456),'p@automaton-example.org.uk','message get_info(orig)'); is($dri->get_info('registrar_to','message',123456),'EXAMPLE','message get_info(registrar_to)'); is_deeply($dri->get_info('domains','message',123456),[qw/auto-example1.co.uk epp-example2.co.uk/],'message get_info(domains)'); ## http://www.nominet.org.uk/registrars/systems/epp/registrantchange/ ## We only do a very simple parse $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2007-10-06T10:29:30ZRegistrant Transfer Notificationp@automaton-example.org.uk58658458596859epp-example1.co.ukRegistered until expiry dateNS1015-UKns1.epp-example1.co.ukEXAMPLE-TAGEXAMPLE-TAGexample@epp-example.co.uk2005-06-03T12:00:002007-06-03T12:00:00epp-example2.co.ukRenewal requiredEXAMPLE-TAGexample@epp-example.co.uk2005-06-03T12:45:342007-06-02T12:45:34123456Mr R. StrantR. S. IndustriesSTRANI123456N2102 High StreetCarfaxOxfordOxfordshireOX1 1DFGBC12345Mr R.Strant01865 12345601865 123456r.strant@strant.co.ukTESTdomains@isp.com1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0ZTESTTEST1999-04-03T22:00:00.0Zdomains@isp.com1999-12-03T09:00:00.0Z'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),123456,'message get_info(last_id) 3'); is($dri->get_info('action','message',123456),'registrant_change','message get_info(action)'); is($dri->get_info('account_from','message',123456),'596859','message get_info(account_from)'); is($dri->get_info('account_to','message',123456),'58658458','message get_info(account_to)'); is_deeply($dri->get_info('domains','message',123456),[qw/epp-example1.co.uk epp-example2.co.uk/],'message get_info(domains)'); ## http://www.nominet.org.uk/registrars/systems/epp/domaincancelled/ $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2007-09-26T07:31:30Domain name Cancellation Notificationepp-example1.co.ukexample@nominet'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),123456,'message get_info(last_id) 4'); is($dri->get_info('object_type','message','123456'),'domain','message get_info(object_type)'); is($dri->get_info('object_id','message','123456'),'epp-example1.co.uk','message get_info(object_id)'); is($dri->get_info('action','domain','epp-example1.co.uk'),'cancelled','message get_info(action)'); is($dri->get_info('cancelled_orig','domain','epp-example1.co.uk'),'example@nominet','message get_info(cancelled_orig)'); ## http://www.nominet.org.uk/registrars/systems/epp/handshakerequest/ ## We only do a very simple parse $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2007-09-26T07:31:30Registrar Change Authorisation Requestp@epp-example.org.ukEXAMPLE3560epp-example1.co.ukRegistered until expiry dateNS1015-UKautomaton-example1.co.ukEXAMPLE-TAGEXAMPLE-TAGexample@epp-example.co.uk2005-06-03T12:00:002007-06-03T12:00:00epp-example2.co.ukRenewal requiredEXAMPLE-TAGexample@epp-example2.co.uk2005-06-03T12:00:002007-06-03T12:00:00123456T. ExampleExample IncSTRA57846548N10 High StreetLittle RisingBirminghamWest MidlandsB1 5AAGB'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info(last_id) 5'); is($dri->get_info('action','message',12345),'handshake_request','message get_info(action)'); is($dri->get_info('orig','message',12345),'p@epp-example.org.uk','message get_info(orig)'); is($dri->get_info('registrar_to','message',12345),'EXAMPLE','message get_info(registrar_to)'); is($dri->get_info('case_id','message',12345),'3560','message get_info(case_id)'); is_deeply($dri->get_info('domains','message',12345),[qw/epp-example1.co.uk epp-example2.co.uk/],'message get_info(domains)'); ## http://www.nominet.org.uk/registrars/systems/epp/poorqualitydata/ $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2007-10-06T10:29:30ZPoor Quality Data Notification589695E. Examplen/an/aN1 1NAGB2007-10-26T00:00:002007-11-25T00:00:00epp-example1.co.ukepp-example2.co.ukepp-example3.co.ukepp-example4.co.ukepp-example5.co.ukepp-example6.co.uk'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),123456,'message get_info(last_id) 6'); is($dri->get_info('action','message',123456),'poor_quality','message get_info(action)'); is($dri->get_info('poor_quality_stage','message',123456),'initial','message get_info(poor_quality_stage)'); $co=$dri->get_info('poor_quality_account','message',123456); isa_ok($co,'Net::DRI::Data::Contact','message get_info(poor_quality_account)'); is($co->roid(),'589695','account roid'); is($co->name(),'E. Example','account name'); is_deeply($co->street(),['n/a'],'account street'); is($co->city(),'n/a','account city'); is($co->pc(),'N1 1NA','account pc'); is($co->cc(),'GB','account cc'); is(''.$dri->get_info('poor_quality_suspend','message',123456),'2007-10-26T00:00:00','message get_info(poor_quality_suspend)'); is(''.$dri->get_info('poor_quality_cancel','message',123456),'2007-11-25T00:00:00','message get_info(poor_quality_cancel)'); is_deeply($dri->get_info('domains','message',123456),[qw/epp-example1.co.uk epp-example2.co.uk epp-example3.co.uk epp-example4.co.uk epp-example5.co.uk epp-example6.co.uk/],'message get_info(domains)'); ## http://www.nominet.org.uk/registrars/systems/epp/domainsreleased/ $R2=$E1.''.r(1301,'Command completed successfully; ack to dequeue').'2007-09-26T07:31:30Domains Released Notification12345EXAMPLE1-TAGEXAMPLE2-TAGepp-example1.co.ukepp-example2.co.ukepp-example3.co.ukepp-example4.co.ukepp-example5.co.ukepp-example6.co.uk'.$TRID.''.$E2; $rc=$dri->message_retrieve(); is($dri->get_info('last_id'),12345,'message get_info(last_id) 6'); is($dri->get_info('action','message',12345),'domains_released','message get_info(action)'); is($dri->get_info('account_id','message',12345),'12345','message get_info(account_id)'); is($dri->get_info('account_moved','message',12345),1,'message get_info(account_moved)'); is($dri->get_info('registrar_from','message',12345),'EXAMPLE1-TAG','message get_info(registrar_from)'); is($dri->get_info('registrar_to','message',12345),'EXAMPLE2-TAG','message get_info(registrar_to)'); is_deeply($dri->get_info('domains','message',12345),[qw/epp-example1.co.uk epp-example2.co.uk epp-example3.co.uk epp-example4.co.uk epp-example5.co.uk epp-example6.co.uk/],'message get_info(domains)'); ## http://www.nominet.org.uk/registrars/systems/nominetepp/Unrenew/ $rc=$dri->domain_unrenew('example.co.uk'); is_string($R1,$E1.'example.co.ukABC-12345'.$E2,'domain_unrenew build'); $R2=$E1.''.r().'epp-example1.co.ukepp-example2.co.ukepp-example3.co.ukepp-example4.co.ukepp-example5.co.ukepp-example6.co.uk'.$TRID.''.$E2; $rc=$dri->account_list_domains({registration=>DateTime->new({year=>2008,month=>12})}); is_string($R1,$E1.'2008-12noneABC-12345'.$E2,'account_list_domains build'); is_deeply($rc->get_data('account','domains','list'),[qw/epp-example1.co.uk epp-example2.co.uk epp-example3.co.uk epp-example4.co.uk epp-example5.co.uk epp-example6.co.uk/],'account_list_domains get_data(account,domains,list)'); exit 0; Net-DRI-0.96/t/153data_contactset.t0000755000175000017500000000052610266032424016514 0ustar patrickpatrick#!/usr/bin/perl -w use strict; use Net::DRI::Data::ContactSet; use Test::More tests => 3; can_ok('Net::DRI::Data::ContactSet',qw/new types has_type add del clear set get match has_contact/); my $s=Net::DRI::Data::ContactSet->new(); isa_ok($s,'Net::DRI::Data::ContactSet'); TODO: { local $TODO="tests"; ok(0); } exit 0; Net-DRI-0.96/t/101exception.t0000755000175000017500000000771211072655610015353 0ustar patrickpatrick#!/usr/bin/perl -w use Test::More tests => 45; use Net::DRI::Exception; my $e=Net::DRI::Exception->new(1,'test area',786,'test message'); my $ln=__LINE__; $ln--; my $fn=__FILE__; isa_ok($e,'Net::DRI::Exception','Exception object'); is($e->is_error(),1,'retrieve error'); is($e->area(),'test area','retrieve area'); is($e->code(),786,'retrieve code'); is($e->msg(),'test message','retrieve message'); my $err=$e->as_string(); is($err,'EXCEPTION 786@test area from line '.$ln.' of file '.$fn.":\ntest message\n",'print complete error message'); $e=f1('A','B'); $err=$e->as_string(); like($err,qr/test message f3:A_B/,'backtrace of nested calls (final message)'); ## \s* added because of perl 5.8.2 on netbsd : http://www.nntp.perl.org/group/perl.cpan.testers/2008/08/msg1973281.html like($err,qr/main::f1\('A',\s*'B'\) called at ${fn}/,' (first level)'); like($err,qr/main::f2\('A',\s*'B'\) called at ${fn}/,' (second level)'); like($err,qr/main::f3\('A',\s*'B'\) called at ${fn}/,' (third level)'); eval { Net::DRI::Exception->die(1,'test area die',788,'test message die'); }; isa_ok($@,'Net::DRI::Exception','Exception->die() results'); is($@->is_error(),1,'Exception->die() is error'); is($@->area(),'test area die','Exception->die() area'); is($@->code(),788,'Exception->die() code'); is($@->msg(),'test message die','Exception->die() message'); eval { Net::DRI::Exception::err_method_not_implemented('foobar'); }; isa_ok($@,'Net::DRI::Exception','err_method_not_implemented() results'); is($@->is_error(),1,'err_method_not_implemented() is error'); is($@->area(),'internal','err_method_not_implemented() area'); is($@->code(),1,'err_method_not_implemented() code'); is($@->msg(),'Method not implemented: foobar','err_method_not_implemented() message'); eval { Net::DRI::Exception::err_insufficient_parameters('stuff missing'); }; isa_ok($@,'Net::DRI::Exception','err_insufficient_parameters() results'); is($@->is_error(),1,'err_insufficient_parameters() is error'); is($@->area(),'internal','err_insufficient_parameters() area'); is($@->code(),2,'err_insufficient_parameters() code'); is($@->msg(),'Insufficient parameters: stuff missing','err_insufficient_parameters() message'); eval { Net::DRI::Exception::err_invalid_parameters('crazy stuff'); }; isa_ok($@,'Net::DRI::Exception','err_invalid_parameters() results'); is($@->is_error(),1,'err_invalid_parameters() is error'); is($@->area(),'internal','err_invalid_parameters() area'); is($@->code(),3,'err_invalid_parameters() code'); is($@->msg(),'Invalid parameters: crazy stuff','err_invalid_parameters() message'); eval { Net::DRI::Exception::usererr_insufficient_parameters('user stuff missing'); }; isa_ok($@,'Net::DRI::Exception','usererr_insufficient_parameters() results'); is($@->is_error(),0,'usererr_insufficient_parameters() is error'); is($@->area(),'internal','usererr_insufficient_parameters() area'); is($@->code(),2,'usererr_insufficient_parameters() code'); is($@->msg(),'Insufficient parameters: user stuff missing','usererr_insufficient_parameters() message'); eval { Net::DRI::Exception::usererr_invalid_parameters('crazy user stuff'); }; isa_ok($@,'Net::DRI::Exception','usererr_invalid_parameters() results'); is($@->is_error(),0,'usererr_invalid_parameters() is error'); is($@->area(),'internal','usererr_invalid_parameters() area'); is($@->code(),3,'usererr_invalid_parameters() code'); is($@->msg(),'Invalid parameters: crazy user stuff','usererr_invalid_parameters() message'); eval { Net::DRI::Exception::err_assert('something has failed'); }; isa_ok($@,'Net::DRI::Exception','err_assert() results'); is($@->is_error(),1,'err_assert is error'); is($@->area(),'internal','err_assert area'); is($@->code(),4,'err_assert code'); is($@->msg(),'Assert failed: something has failed','err_assert message'); exit 0; sub f1 { return f2(@_); } sub f2 { return f3(@_); } sub f3 { return Net::DRI::Exception->new(1,'test area f3',787,'test message f3:'.join('_',@_)); } Net-DRI-0.96/t/616vnds_epp_namestore.t0000755000175000017500000001720311241333771017256 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Test::More tests => 12; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=$msg->as_string(); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI::TrapExceptions->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('VNDS'); $dri->target('VNDS')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv},{default_product=>'dotNET'}); ######################################################################################################### ## Example taken from EPP-NameStoreExt-Mapping.pdf $R2=$E1.''.r().'example22.comexample2.netIn usedotCC'.$TRID.''.$E2; my $rc=$dri->domain_check_multi('example22.com','example2.net'); is_string($R1,$E1.'example22.comexample2.netdotNETABC-12345'.$E2,'domain_check_multi build with namestore fixed in add_current_profile()'); is($rc->is_success(),1,'domain_check_multi is_success'); is($dri->get_info('exist','domain','example22.com'),0,'domain_check_multi get_info(exist) 1/2'); is($dri->get_info('exist','domain','example2.net'),1,'domain_check_multi get_info(exist) 2/2'); is($dri->get_info('exist_reason','domain','example2.net'),'In use','domain_check_multi get_info(exist_reason)'); is($dri->get_info('subproductid'),'dotCC','domain_check_multi get_info(subproductid)'); ## if _auto_ it will be computed from first domain $dri->target('VNDS')->add_current_profile('p2','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv},{default_product=>'_auto_'}); $rc=$dri->domain_check_multi('example22.com','example2.net'); is_string($R1,$E1.'example22.comexample2.netdotCOMABC-12345'.$E2,'domain_check_multi build with namestore=_auto_'); ## you can always pass it explicitely, which will override the default set in add_current_profile only for the given call $dri->target('VNDS')->add_current_profile('p3','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv},{default_product=>'_auto_'}); $rc=$dri->domain_check_multi('example22.com','example2.net',{subproductid=>'dotAA'}); is_string($R1,$E1.'example22.comexample2.netdotAAABC-12345'.$E2,'domain_check_multi build with namestore given in call'); ## Check some more namestores $rc=$dri->domain_check('example4.cc'); is_string($R1,$E1.'example4.ccdotCCABC-12345'.$E2,'domain_check build with namestore=_auto_ for .cc'); $rc=$dri->domain_check('example4.tv'); is_string($R1,$E1.'example4.tvdotTVABC-12345'.$E2,'domain_check build with namestore=_auto_ for .tv'); $rc=$dri->domain_check('example4.bz'); is_string($R1,$E1.'example4.bzdotBZABC-12345'.$E2,'domain_check build with namestore=_auto_ for .bz'); $rc=$dri->domain_check('example4.jobs'); is_string($R1,$E1.'example4.jobsdotJOBSABC-12345'.$E2,'domain_check build with namestore=_auto_ for .jobs'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/t/241epp_message.t0000755000175000017500000003030711350046403015637 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI::Protocol::EPP::Message; use Net::DRI::Data::Raw; use Encode; use Test::More tests=> 32; my $msg; my $s; ################################################################################### $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $s=Net::DRI::Data::Raw->new_from_string(< Command completed successfully ABC-12345 54321-XYZ EOF $msg->parse($s); is($msg->result_code(),1000,'parse (result,trid) result_code'); is($msg->result_message(),'Command completed successfully','parse (result,trid) result_message'); is($msg->result_lang(),'en','parse (result,trid) result_lang'); is($msg->cltrid(),'ABC-12345','parse (result,trid) cltrid'); is($msg->svtrid(),'54321-XYZ','parse (result,trid) svtrid'); $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $s=Net::DRI::Data::Raw->new_from_string(< Parameter value range error 2525 Parameter value syntax error ex(ample abc.ex(ampleInvalid character found. ABC-12345 54321-XYZ EOF $msg->parse($s); is($msg->result_code(0),2004,'parse (result,2 errors) result_code(0)'); is($msg->result_code(1),2005,'parse (result,2 errors) result_code(1)'); $ri=$msg->result_extra_info(0); is_deeply($ri,[{type=>'rawxml',from=>'eppcom:value',message=>'2525'}],'parse (result,2 errors) result_extra_info(0)'); $ri=$msg->result_extra_info(1); is_deeply($ri,[{type=>'rawxml',from=>'eppcom:value',message=>'ex(ample'},{type=>'rawxml',from=>'eppcom:extValue',message=>'abc.ex(ample',reason=>'Invalid character found.',lang=>'en'}],'parse (result,2 errors) result_extra_info(1)'); is_deeply([$msg->results_code()],[2004,2005],'parse (result,2 errors) results_code'); is_deeply([$msg->results_message()],['Parameter value range error','Parameter value syntax error'],'parse (result,2 errors) results_message'); is_deeply([$msg->results_lang()],['en','en'],'parse (result,2 errors) results_lang'); ################################################################################# $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $msg->command(['check','host:check','xmlns:host="urn:ietf:params:xml:ns:host-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:host-1.0 host-1.0.xsd"']); $msg->command_body([['host:name','ns1.example.com'],['host:name','ns2.example.com'],['host:name','ns3.example.com']]); $msg->cltrid('ABC-12345'); $s=< ns1.example.com ns2.example.com ns3.example.com ABC-12345 EOF is($msg->as_string(),_n($s),'build host check [RFC 4932 §3.1.1]'); $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $s=Net::DRI::Data::Raw->new_from_string(< Command completed successfully ns1.example.com ns2.example2.com In use ns3.example3.com ABC-12345 54322-XYZ EOF $msg->parse($s); my $nn=$msg->get_response('urn:ietf:params:xml:ns:host-1.0','chkData'); my $o=$nn->firstChild(); $o=$o->getNextSibling(); is($o->nodeName(),'host:cd','parse host:chkData 1'); is($o->firstChild->getNextSibling->nodeName(),'host:name','parse host:chkData 2'); is($o->firstChild->getNextSibling->getAttribute('avail'),1,'parse host:chkData 3'); is($o->firstChild->getNextSibling->getFirstChild->getData(),'ns1.example.com','parse host:chkData 4'); $o=$o->getNextSibling()->getNextSibling(); is($o->nodeName(),'host:cd','parse host:chkData 5'); is($o->firstChild->getNextSibling->nodeName(),'host:name','parse host:chkData 6'); is($o->firstChild->getNextSibling->getAttribute('avail'),0,'parse host:chkData 7'); is($o->firstChild->getNextSibling->getFirstChild->getData(),'ns2.example2.com','parse host:chkData 8'); is($o->firstChild->getNextSibling->getNextSibling->getNextSibling->nodeName(),'host:reason','parse host:chkData 9'); is($o->firstChild->getNextSibling->getNextSibling->getNextSibling->getFirstChild->getData(),'In use','parse host:chkData 10'); $o=$o->getNextSibling()->getNextSibling(); is($o->nodeName(),'host:cd','parse host:chkData 11'); is($o->firstChild->getNextSibling->nodeName(),'host:name','parse host:chkData 12'); is($o->firstChild->getNextSibling->getAttribute('avail'),1,'parse host:chkData 13'); is($o->firstChild->getNextSibling->getFirstChild->getData(),'ns3.example3.com','parse host:chkData 14'); $o=$o->getNextSibling()->getNextSibling(); is($o,undef,'parse host:chkData 15'); ############################################################################## $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $msg->command(['info','host:info','xmlns:host="urn:ietf:params:xml:ns:host-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:host-1.0 host-1.0.xsd"']); $msg->command_body([['host:name','ns1.example.com']]); $msg->cltrid('ABC-12345'); $s=< ns1.example.com ABC-12345 EOF is($msg->as_string(),_n($s),'build host info [RFC 4932 §3.1.2]'); ############################################################################## $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $msg->command(['create','host:create','xmlns:host="urn:ietf:params:xml:ns:host-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:host-1.0 host-1.0.xsd"']); $msg->command_body([['host:name','ns1.example.com'],['host:addr','192.0.2.2',{ip=>'v4'}],['host:addr','192.0.2.29',{ip=>'v4'}],['host:addr','1080:0:0:0:8:800:200C:417A',{ip=>'v6'}]]); $msg->cltrid('ABC-12345'); $s=< ns1.example.com 192.0.2.2 192.0.2.29 1080:0:0:0:8:800:200C:417A ABC-12345 EOF is($msg->as_string(),_n($s),'build host create [RFC 4932 §3.2.1]'); ############################################################################## $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $msg->command(['delete','host:delete','xmlns:host="urn:ietf:params:xml:ns:host-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:host-1.0 host-1.0.xsd"']); $msg->command_body([['host:name','ns1.example.com']]); $msg->cltrid('ABC-12345'); $s=< ns1.example.com ABC-12345 EOF is($msg->as_string(),_n($s),'build host delete [RFC 4932 §3.2.2]'); ############################################################################## $msg=Net::DRI::Protocol::EPP::Message->new(); $msg->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'] }); $msg->command(['update','host:update','xmlns:host="urn:ietf:params:xml:ns:host-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:host-1.0 host-1.0.xsd"']); $msg->command_body([['host:name','ns1.example.com'],['host:add',['host:addr','192.0.2.22',{ip=>'v4'}],['host:status',undef,{s=>'clientUpdateProhibited'}]],['host:rem',['host:addr','1080:0:0:0:8:800:200C:417A',{ip=>'v6'}]],['host:chg',['host:name','ns2.example.com']]]); $msg->cltrid('ABC-12345'); $s=< ns1.example.com 192.0.2.22 1080:0:0:0:8:800:200C:417A ns2.example.com ABC-12345 EOF is($msg->as_string(),_n($s),'build host update [RFC 4932 §3.2.5]'); exit 0; sub _n { my $in=shift; $in=~s/^\s+//gm; $in=~s/\n/ /g; $in=~s/>\s+ 2; can_ok('Net::DRI::Protocol::RRP::Connection',qw(login logout keepalive parse_greeting parse_login parse_logout read_data write_message)); TODO: { local $TODO="tests on login() logout() keepalive() parse_greeting() parse_login() parse_logout() read_data() write_message() find_code()"; ok(0); } exit 0; Net-DRI-0.96/t/613cat_epp.t0000755000175000017500000006544411241325410014774 0ustar patrickpatrick#!/usr/bin/perl -w use Net::DRI; use Net::DRI::Data::Raw; use Net::DRI::Protocol::EPP::Connection; use DateTime; use DateTime::Duration; use Encode (); use Test::More tests => 110; eval { no warnings; require Test::LongString; Test::LongString->import(max => 100); $Test::LongString::Context=50; }; *{'main::is_string'}=\&main::is if $@; our $E1=''; our $E2=''; our $TRID='ABC-1234554322-XYZ'; our $R1; sub mysend { my ($transport,$count,$msg)=@_; $R1=substr(Net::DRI::Protocol::EPP::Connection->write_message(undef,$msg),4); return 1; } our $R2; sub myrecv { return Net::DRI::Data::Raw->new_from_string($R2? $R2 : $E1.''.r().$TRID.''.$E2); } my $dri=Net::DRI->new(10); $dri->{trid_factory}=sub { return 'ABC-12345'; }; $dri->add_registry('CAT'); $dri->target('CAT')->add_current_profile('p1','test=epp',{f_send=>\&mysend,f_recv=>\&myrecv}); my ($rc,$s,$d,$dh,@c,$co); #################################################################################################### ## Contacts ## p.31 $co=$dri->local_object('contact')->srid('sh8013'); $co->name('John Doe'); $co->org('Example Inc.'); $co->street(['123 Example Dr.','Suite 100']); $co->city('Dulles'); $co->sp('VA'); $co->pc('20166-6503'); $co->cc('US'); $co->voice('+1.7035555555x1234'); $co->fax('+1.7035555556'); $co->email('jdoe@example.com'); $co->auth({pw=>'2fooBAR'}); $co->disclose({voice=>0,email=>0}); $co->lang('ca'); $co->maintainer('MyDomains.cat'); $co->email_sponsor('catsponsor@example.com'); $rc=$dri->contact_create($co); is($R1,$E1.'sh8013John DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+1.7035555555+1.7035555556jdoe@example.com2fooBARcaMyDomains.catcatsponsor@example.comABC-12345'.$E2,'contact_create build'); ##p.33 $R2=''; $co=$dri->local_object('contact')->srid('sh8013')->auth({pw=>'2fooBAR'}); $toc=$dri->local_object('changes'); $toc->add('status',$dri->local_object('status')->no('delete')); my $co2=$dri->local_object('contact'); $co2->org(''); $co2->street(['124 Example Dr.','Suite 200']); $co2->city('Dulles'); $co2->sp('VA'); $co2->pc('20166-6503'); $co2->cc('US'); $co2->voice('+1.7034444444'); $co2->fax(''); $co2->auth({pw=>'2fooBAR'}); $co2->disclose({voice=>1,email=>1}); $co2->lang('ca'); $co2->maintainer('MyDomains.cat'); $co2->email_sponsor('catsponsor@example.com'); $toc->set('info',$co2); $rc=$dri->contact_update($co,$toc); is_string($R1,$E1.'sh8013124 Example Dr.Suite 200DullesVA20166-6503US+1.70344444442fooBARcaMyDomains.catcatsponsor@example.comABC-12345'.$E2,'contact_update build'); ##p.35 $R2=$E1.''.r().'sh8013SH8013-REPJohn DoeExample Inc.123 Example Dr.Suite 100DullesVA20166-6503US+1.7035555555+1.7035555556jdoe@example.comR-123R-1231999-04-03T22:00:00.0ZR-1231999-12-03T09:00:00.0Z2000-04-08T09:00:00.0Z2fooBARcamyDomains.catcatsponsor@example.comABC-1234554322-XYZ'.$E2; $co=$dri->local_object('contact')->srid('sh8013')->auth({pw=>'2fooBAR'}); $rc=$dri->contact_info($co); is_string($R1,$E1.'sh80132fooBARABC-12345'.$E2,'contact_info build'); is($rc->is_success(),1,'contact_info is_success'); is($dri->get_info('exist'),1,'contact_info get_info(exist)'); $co=$dri->get_info('self'); isa_ok($co,'Net::DRI::Data::Contact::CAT','contact_info get_info(self)'); is($co->srid(),'sh8013','contact_info get_info(self) srid'); is($co->roid(),'SH8013-REP','contact_info get_info(self) roid'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','contact_info get_info(status)'); is_deeply([$s->list_status()],['clientDeleteProhibited','linked'],'contact_info get_info(status) list_status'); is($s->can_delete(),0,'contact_info get_info(status) can_delete'); is($co->name(),'John Doe','contact_info get_info(self) name'); is($co->org(),'Example Inc.','contact_info get_info(self) org'); is_deeply($co->street(),['123 Example Dr.','Suite 100'],'contact_info get_info(self) street'); is($co->city(),'Dulles','contact_info get_info(self) city'); is($co->sp(),'VA','contact_info get_info(self) sp'); is($co->pc(),'20166-6503','contact_info get_info(self) pc'); is($co->cc(),'US','contact_info get_info(self) cc'); is($co->voice(),'+1.7035555555x1234','contact_info get_info(self) voice'); is($co->fax(),'+1.7035555556','contact_info get_info(self) fax'); is($co->email(),'jdoe@example.com','contact_info get_info(self) email'); is($dri->get_info('clID'),'R-123','contact_info get_info(clID)'); is($dri->get_info('crID'),'R-123','contact_info get_info(crID)'), $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','contact_info get_info(crDate)'); is("".$d,'1999-04-03T22:00:00','contact_info get_info(crDate) value'); is($dri->get_info('upID'),'R-123','contact_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','contact_info get_info(upDate)'); is("".$d,'1999-12-03T09:00:00','contact_info get_info(upDate) value'); $d=$dri->get_info('trDate'); isa_ok($d,'DateTime','contact_info get_info(trDate)'); is("".$d,'2000-04-08T09:00:00','contact_info get_info(trDate) value'); is_deeply($co->auth(),{pw=>'2fooBAR'},'contact_info get_info(self) auth'); is_deeply($co->disclose(),{voice=>0,email=>0},'contact_info get_info(self) disclose'); is($co->lang(),'ca','contact_info get_info(self) lang'); is($co->maintainer(),'myDomains.cat','contact_info get_info(self) maintainer'); is($co->email_sponsor(),'catsponsor@example.com','contact_info get_info(self) email_sponsor'); #################################################################################################### ## Domains ##p.48 $R2=''; my $cs=$dri->local_object('contactset'); my $c1=$dri->local_object('contact')->srid('jd1234'); my $c2=$dri->local_object('contact')->srid('sh8013'); $cs->set($c1,'registrant'); $cs->set($c2,'admin'); $cs->set($c2,'tech'); $cs->set($c2,'billing'); $rc=$dri->domain_create('barca.cat',{pure_create=>1,duration=>DateTime::Duration->new(years=>2),ns=>$dri->local_object('hosts')->set(['ns1.example.com'],['ns1.example.net']),contact=>$cs,auth=>{pw=>'2fooBAR'},name_variant=>['barcà.cat','xn--bara-2oa.cat'],lang=>'ca',maintainer=>'myDomains.cat',ens=>{sponsor=>['sponsor1@example.com','sponsor2@example.net','sponsor3@example.org'],intended_use=>'Website dedicated about sailing around Barcelona'}}); is_string($R1,Encode::encode('utf8',$E1.'barca.cat2ns1.example.comns1.example.netjd1234sh8013sh8013sh80132fooBARbarcà.catxn--bara-2oa.catcamyDomains.catsponsor1@example.comsponsor2@example.netsponsor3@example.orgWebsite dedicated about sailing around BarcelonaABC-12345'.$E2),'domain_create build'); ##p.51 $R2=''; $toc=$dri->local_object('changes'); $toc->add('ns',$dri->local_object('hosts')->set('ns2.example.com')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('mak21'),'tech'); $toc->add('contact',$cs); $toc->add('status',$dri->local_object('status')->no('publish','Payment overdue.')); $toc->del('ns',$dri->local_object('hosts')->set('ns1.example.com')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('sh8013'),'tech'); $toc->del('contact',$cs); $toc->del('status',$dri->local_object('status')->no('update')); $toc->set('registrant',$dri->local_object('contact')->srid('sh8013')); $toc->set('auth',{pw=>'2BARfoo'}); $toc->add('name_variant',['bàrca.cat']); $toc->del('name_variant',['barça.cat']); $toc->set('maintainer','ACME Domains, Inc.'); $rc=$dri->domain_update('barca.cat',$toc); is_string($R1,Encode::encode('utf8',$E1.'barca.catns2.example.commak21Payment overdue.ns1.example.comsh8013sh80132BARfoobàrca.catbarça.catACME Domains, Inc.ABC-12345'.$E2),'domain_update build'); ##p.58 $R2=Encode::encode('utf8',$E1.''.r().'barca.catBARCA-REPjd1234sh8013sh8013sh8013ns1.example.comns1.example.netns1.barca.catns2.barca.catClientXClientY2006-04-03T22:00:00.0ZClientX2006-12-03T09:00:00.0Z2007-04-03T22:00:00.0Z2006-04-08T09:00:00.0Z2fooBARbàrca.catbarça.catcasponsor1@example.comsponsor2@example.netsponsor3@example.orgstandardWebsite dedicated about sailing around BarcelonaABC-1234554322-XYZ'.$E2); $rc=$dri->domain_info('barca.cat',{auth=>{pw=>'2fooBAR'}}); is($dri->get_info('exist'),1,'domain_info get_info(exist)'); is($dri->get_info('roid'),'BARCA-REP','domain_info get_info(roid)'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','domain_info get_info(status)'); is_deeply([$s->list_status()],['ok'],'domain_info get_info(status) list'); is($s->is_active(),1,'domain_info get_info(status) is_active'); $s=$dri->get_info('contact'); isa_ok($s,'Net::DRI::Data::ContactSet','domain_info get_info(contact)'); is_deeply([$s->types()],['admin','billing','registrant','tech'],'domain_info get_info(contact) types'); is($s->get('registrant')->srid(),'jd1234','domain_info get_info(contact) registrant srid'); is($s->get('admin')->srid(),'sh8013','domain_info get_info(contact) admin srid'); is($s->get('tech')->srid(),'sh8013','domain_info get_info(contact) tech srid'); is($s->get('billing')->srid(),'sh8013','domain_info get_info(contact) billing srid'); $dh=$dri->get_info('host'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(host)'); @c=$dh->get_names(); is_deeply(\@c,['ns1.barca.cat','ns2.barca.cat'],'domain_info get_info(host) get_names'); $dh=$dri->get_info('ns'); isa_ok($dh,'Net::DRI::Data::Hosts','domain_info get_info(ns)'); @c=$dh->get_names(); is_deeply(\@c,['ns1.example.com','ns1.example.net'],'domain_info get_info(ns) get_names'); is($dri->get_info('clID'),'ClientX','domain_info get_info(clID)'); is($dri->get_info('crID'),'ClientY','domain_info get_info(crID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','domain_info get_info(crDate)'); is("".$d,'2006-04-03T22:00:00','domain_info get_info(crDate) value'); is($dri->get_info('upID'),'ClientX','domain_info get_info(upID)'); $d=$dri->get_info('upDate'); isa_ok($d,'DateTime','domain_info get_info(upDate)'); is("".$d,'2006-12-03T09:00:00','domain_info get_info(upDate) value'); $d=$dri->get_info('exDate'); isa_ok($d,'DateTime','domain_info get_info(exDate)'); is("".$d,'2007-04-03T22:00:00','domain_info get_info(exDate) value'); $d=$dri->get_info('trDate'); isa_ok($d,'DateTime','domain_info get_info(trDate)'); is("".$d,'2006-04-08T09:00:00','domain_info get_info(trDate) value'); is_deeply($dri->get_info('auth'),{pw=>'2fooBAR'},'domain_info get_info(auth)'); is_deeply($dri->get_info('name_variant'),['bàrca.cat','barça.cat'],'domain_info get_info(name_variant)'); is($dri->get_info('lang'),'ca','domain_info get_info(lang)'); is(ref($dri->get_info('ens')),'HASH','domain_info get_info(ens) HASH'); my %ens=%{$dri->get_info('ens')}; is_deeply($ens{sponsor},['sponsor1@example.com','sponsor2@example.net','sponsor3@example.org'],'domain_info get_info(ens) sponsor'); is($ens{registration_type},'standard','domain_info get_info(ens) registration_type'); is($ens{intended_use},'Website dedicated about sailing around Barcelona','domain_info get_info(ens) intended_use'); #################################################################################################### ## Defensive Registration # p.71 my $ro=$dri->remote_object('defreg'); $cs=$dri->local_object('contactset'); $c1=$dri->local_object('contact')->srid('C100004'); $cs->set($c1,'registrant'); $cs->set($c1,'admin'); $cs->set($c1,'billing'); $rc=$ro->create('test28-id',{duration=>DateTime::Duration->new(years=>2),pattern=>'coca-cola',contact=>$cs,auth=>{pw=>'123456'},maintainer=>'myDomains Inc',trademark=>{name=>'Coca Cola',issue_date=>DateTime->new(year=>1923,month=>12,day=>30),country=>'US',number=>12345}}); is_string($R1,$E1.'test28-id2coca-colaC100004C100004C100004123456myDomains IncCoca Cola1923-12-30US12345ABC-12345'.$E2,'defreg_create build'); # p.73 $ro=$dri->remote_object('defreg','test18-id'); $toc=$dri->local_object('changes'); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('C100004'),'admin'); $toc->add('contact',$cs); $toc->add('status',$dri->local_object('status')->no('update')); $cs=$dri->local_object('contactset'); $cs->set($dri->local_object('contact')->srid('C100005'),'admin'); $toc->del('contact',$cs); $toc->set('registrant',$dri->local_object('contact')->srid('C39392')); $toc->set('auth',{pw=>'1234567'}); $toc->set('maintainer','test'); $toc->set('trademark',{name=>'ACMED',issue_date=>DateTime->new(year=>2005,month=>12,day=>31),country=>'DE',number=>123456}); $rc=$ro->update($toc); is_string($R1,$E1.'test18-idC100004C100005C393921234567testACMED2005-12-31DE123456ABC-12345'.$E2,'defreg_update build'); # p.74 $ro=$dri->remote_object('defreg','DR39533'); $rc=$ro->delete(); is_string($R1,$E1.'DR39533ABC-12345'.$E2,'defreg_delete build'); # p.75 $ro=$dri->remote_object('defreg','DR38328'); $rc=$ro->renew({duration=>DateTime::Duration->new(years=>2),current_expiration=>DateTime->new(year=>2009,month=>01,day=>23)}); is_string($R1,$E1.'DR383282009-01-232ABC-12345'.$E2,'defreg_renew build'); # p.76 $R2=$E1.''.r().'A2948339483-Acoca-colajd1234sh8013sh80132fooBARmyDomains.catACMED2005-12-31DE123456R-123R-1232006-04-03T22:00:00.0ZABC-1234554322-XYZ'.$E2; $ro=$dri->remote_object('defreg','A29483'); $rc=$ro->info({auth=>{pw=>'mySecret',roid=>'DR-5932'}}); is_string($R1,$E1.'A29483mySecretABC-12345'.$E2,'defreg_info build'); is($rc->is_success(),1,'defreg_info is_success'); is($dri->get_info('action'),'info','defreg_info get_info(action)'); is($dri->get_info('exist'),1,'defreg_info get_info(exist)'); is($dri->get_info('id'),'A29483','defreg_info get_info(id)'); is($dri->get_info('roid'),'39483-A','defreg_info get_info(roid)'); is($dri->get_info('pattern'),'coca-cola','defreg_info get_info(pattern)'); $s=$dri->get_info('status'); isa_ok($s,'Net::DRI::Data::StatusList','defreg_info get_info(status)'); is_deeply([$s->list_status()],['serverDeleteProhibited','serverUpdateProhibited'],'defreg_info get_info(status) list'); is($s->can_update(),0,'defreg_info get_info(status) can_update'); is($s->can_delete(),0,'defreg_info get_info(status) can_delete'); $s=$dri->get_info('contact'); isa_ok($s,'Net::DRI::Data::ContactSet','defreg_info get_info(contact)'); is_deeply([$s->types()],['admin','billing','registrant'],'defreg_info get_info(contact) types'); is($s->get('registrant')->srid(),'jd1234','defreg_info get_info(contact) registrant srid'); is($s->get('admin')->srid(),'sh8013','defreg_info get_info(contact) admin srid'); is($s->get('billing')->srid(),'sh8013','defreg_info get_info(contact) billing srid'); is_deeply($dri->get_info('auth'),{pw=>'2fooBAR'},'defreg_info get_info(auth)'); is($dri->get_info('maintainer'),'myDomains.cat','defreg_info get_info(maintainer)'); is(ref($dri->get_info('trademark')),'HASH','defreg_info get_info(trademark) HASH'); my %t=%{$dri->get_info('trademark')}; is_deeply([sort(keys(%t))],['country','issue_date','name','number'],'defreg_info get_info(trademark) KEYS'); is($t{name},'ACMED','defreg_info get_info(trademark) name'); is(''.$t{issue_date},'2005-12-31T00:00:00','defreg_info get_info(trademark) issue_date'); is($t{country},'DE','defreg_info get_info(trademark) country'); is($t{number},'123456','defreg_info get_info(trademark) number'); is($dri->get_info('clID'),'R-123','defreg_info get_info(clID)'); is($dri->get_info('crID'),'R-123','defreg_info get_info(crID)'); $d=$dri->get_info('crDate'); isa_ok($d,'DateTime','defreg_info get_info(crDate)'); is("".$d,'2006-04-03T22:00:00','defreg_info get_info(crDate) value'); # p.78 $R2=$E1.''.r().'DR3958DR3959In useREG-38245ReservedABC-1234554322-XYZ'.$E2; $ro=$dri->remote_object('defreg'); $rc=$ro->check('DR3958','DR3959','REG-38245'); is_string($R1,$E1.'DR3958DR3959REG-38245ABC-12345'.$E2,'defreg_check build'); is($rc->is_success(),1,'defreg_check is_success'); is($dri->get_info('action','defreg','DR3958'),'check','defreg_check get_info(action)'); is($dri->get_info('exist','defreg','DR3958'),0,'defreg_check get_info(exist) 1'); is($dri->get_info('exist','defreg','DR3959'),1,'defreg_check get_info(exist) 2'); is($dri->get_info('exist_reason','defreg','DR3959'),'In use','defreg_check get_info(exist_reason) 1'); is($dri->get_info('exist','defreg','REG-38245'),1,'defreg_check get_info(exist) 3'); is($dri->get_info('exist_reason','defreg','REG-38245'),'Reserved','defreg_check get_info(exist_reason) 2'); exit 0; sub r { my ($c,$m)=@_; return ''.($m || 'Command completed successfully').''; } Net-DRI-0.96/SUPPORT0000644000175000017500000000061010326250332013556 0ustar patrickpatrickSUPPORT ------- Free, best effort support is available by email to netdri@dotandco.com or through Dot and Co newsgroups, for which you will find all information on http://www.dotandco.net/newsgroups.en Net::DRI is being sponsored by Dot and Co (http://www.dotandco.com/). Professionnal support and specific development are available. Please contact netdri@dotandco.com for any information. Net-DRI-0.96/Changes0000644000175000017500000017253111352534252013774 0ustar patrickpatrick0.96 2010-03-25 + DRD/SIDN & associated modules : .NL EPP full support (work sponsored by SIDN) + DRD/CIRA & associated modules : .CA EPP full support (work sponsored by CIRA) + .IT EPP extensions contributed by Alessandro Zummo, with some changes + Logging/Syslog : contributed by Jørgen Thomsen + .GL EPP support contributed by Jørgen Thomsen + Protocol/EPP/Util : some utility functions previously in Protocol/EPP/Message Protocol/EPP Protocol/EPP/Core/{Contact,Domain}, but needed in other places (various EPP extensions that has been modified to use this new module) + XML::LibXML version 1.61 is needed for getChildrenByTagName('*') (reported by Cipriano Groenendal) = Data/Contact/AFNIC : relax test on country, as TLD is opening to French abroad = Protocol/EPP/Extensions/AFNIC/Domain : during create make sure to test contacts validity = .NO updates by UNINETT Norid ( http://www.norid.no ), consisting of the following = .NO : Adaptions to XML-schema for host: All 'ownerID/ownerid/Owner ID' replaced by 'sponsoringClientID/sponsoringclientid/Sponsor ID' = .NO : Added facets support, facets are available for all EPP-commands/operations, including poll/ack. = .NO : Updated the test client eg/epp_client_no.pl to support setting of facets for all operations. The client has been used for testing and verification of the implementation. = .NO : Added some tests to t/633norid_epp.t to verify some operations without and with facets. Added module test for domain_withdraw. = .NO : Improved parsing of various service messages. = .SE various updates (contributed by Jørgen Thomsen, with some changes) = Protocol/ResultStatus::get_extended_results() : change of output API, now gets back an array of ref hashes (previously: array of scalars) = Protocol/EPP/Message : new add_to_extra_info() internal method = Protocol/EPP/Message : changing the API of data parsed out of value/extValue nodes + better parse of extValue nodes in EPP = Protocol/RRI/Message,Protocol/EPP/Extensions/VeriSign/NameStore,Protocol/EPP/Extensions/{PL,NO}/Message : update to new API for registry extra_info, and use of add_to_extra_info() = Protocol/EPP/Extensions/Nominet : various update per instructions from http://www.nominet.org.uk/registrars/systems/nominetepp/changestoepp/ = Protocol/Whois/Domain/EU : detection of registry rate limiting (after report from Denise Clampitt) = Transport/HTTP : better error message if remote_url not correctly defined (suggested by Andreas Wittkemper) = Protocol/EPP/Extensions/SE : added SecDNS as default extension (from Andreas Wittkemper) = Protocol/IRIS/LWZ : removing fallback to RFC1950 as Denic server should be fixed by now (to use RFC1951 as mandatory by the LWZ RFC) = Protocol/ResultStatus::as_string() : changed the output format = DRD/{SE,SIDN} : various updates regarding durations (contributed by Jørgen Thomsen) = DRD/BE : add proper methods for transfer_quarantine,trade,reactivate,undelete (reported by Andreas Wittkemper) = DRD/ICANN : add .CAT for allowed 1 and 2 characters domain names = Protocol/EPP/Extensions/SWITCH : add the SecDNS extension = DRD + DRD/* : check_name() verify_name_{host,domain}() enforce_{domain,host}_name_constraints() _verify_name_rules() : return error string instead of error code for better error tracking = DRD/NO : remove verify_name_host() the superclass version is the same = DRD/{AT,IENUMAT} : verify_name_domain() converted to new framework = Logging framework : internal changes for simplicity and less context passing, only external change: key "driver" used in header format is now named "transport" (prompted by bugreport from Jørgen Thomse regarding Transport->ping() missing logging context) = Transport : login/logout exchanges use the same "namespace" for the TRID than the relevant profil, instead of the transport name = Transport : added some more transport logging in all subclasses (besides Socket & HTTP that had it already) = Transport/Socket : remove use of eof() in _get as introduced in previous version as it seems to only create problems = Protocol/EPP/Extensions/PL/Connection : now renamed to Protocol/EPP/Extensions/HTTP as it is also used by .IT - DRD domain_create : bugfix for domain_check when pure_create!=1 (reported by Gerben Versluis) - Protocol/EPP/Extensions/Nominet/Host : update() bugfix (contributed by Marc Winoto) - Protocol/EPP/Extensions/{AFNIC,ARNES,DNSBE,EURid,PL}/Domain,Protocol/EPP/Extensions/{FCCN,Nominet}/Contact,Protocol/EPP/Extensions/Nominet/Account,Protocol/EPP/Extensions,CAT/DefensiveRegistration : correct test of contact class - Protocol/EPP/Connection find_code : correct (and better) regex when some extension is present (bugfix by Michael Braunoeder from NIC.AT, applied with changes) - Contact, Contact/AT : correct validation tests - Shell : correct domain_update for registrant change (from bugreport by Jonathan Eshel) 0.95 2009-08-15 If you are upgrading your Net::DRI installation, from version 0.92 or older we advise you to first upgrade to 0.92_01, test everything, adapt your program to use the new API (see below), and then upgrade to 0.95 which introduce some incompatibilities with prior versions. If you test first with version 0.92_01 you will be able to make sure your programs work the same way from old to new API, without changing versions and you will be warned if you are using deprecated features. + DRD/IT & associated modules : only core EPP features, no extensions, no tests + DRD/IRegistry & associated modules : registry driver and extensions for .CO.CZ, contributed by Vitezslav Novy, not tested + Protocol/Whois/Domain/PT : see eg/whois.pl + Protocol/DAS/AU : see eg/das.pl + Protocol/DAS/AdamsNames : see eg/das.pl + Protocol/DAS/SIDN : see eg/das.pl + Protocol/AdamsNames/WS : only domain_info (see t/705adamsnames_ws_live.t) + Contact/OpenSRS : contributed by Richard Siddall + eg/das.pl : new file, testing various DAS server, superset of previous eurid_das.pl which is now removed + Protocol/EPP/Extensions/EURid/{Domain,Notifications,Registrar} : updates for release 5.6 (registry notifications, domain overwrite date delete, registrar info, domain transfer/trade reminders) + DRI::installed_registries() : new method to list all installed registries drivers + DRI::add_current_registry() : new method, same API as add_registry() which is called and a target is done after to switch to the newly added registry + Contact::clone() new method + Util : new functions xml_traverse() xml_list_children() xml_child_content() deepcopy() decode_latin1() normalize_name() + Protocol : new utility functions parse_iso8601() build_parser_strptime() + Protocol/ResultStatus::last() new method to go directly to the lowest object in case of chains = Started to put "use warnings" in some modules = Shell new commands (see module documentation) : show types, domain_update, host_update, contact_update = Shell : various additions in autocompletion, after a domain_info command, nameservers and contacts are also stored for future completions requests = Shell : tries to fallback on default domain commands for all extensions = Logging/Files : change in filenames used, the PID is always added, and only one dot = DRD/* : removed transport_protocol_compatible() + updates to transport_protocol_default() + add profile_types() = DRD,DRD/* : added enforce_{domain,host}_name_constraints() replacing err_invalid_domain_name()+verify_name_domain() and similar for hostnames (so that we have better error messages); all DRD methods needed are updated to take into account this new framework = DRD : domain_create() domain_delete() do not return an array anymore, always a single object with a chain of siblings as needed through the next()/last() methods; the object returned is always the top one not the last one, so ->last() may be used to retrieve the last one and test its success = DRD : removed the %PROTOCOL_DEFAULT_* hashes, defaults are now properly handled in each registry driver class, each protocol subclass and protocol subclass connection class, with the transport_default() method = DRD::verify_name_host() : by default does not check TLD against registry TLDs anymore = DRD/BookMyName : DAS service = DRD/AFNIC::tlds() : added asso.fr com.fr tm.fr gouv.fr = DRD/AFNIC : EPP in full production + bugfix in domain_create + added domain_trade_stop() = DRD/EURid : added profile types das-registrar and whois-registrar for the specific das and whois services restricted to current .EU registrars = DRD/EURid : new methods registrar_info() domain_remind() = DRD/ICANN : one and two characters .BIZ .PRO domain names are now allowed = DRD/Nominet : added domain_unrenew() account_list_domains() = Contact::validate() : better error messages, more specific = Contact,Contact/{SWITCH,NO,AT}::validate() : not testing roid anymore as useless, testing srid instead = Contact/AFNIC : not using pragma encoding anymore, as it is advised in Perl documentation to avoid it in modules, due to its global scope = Contact/AFNIC : new attribues vat and id_status + new method validate_registrant(), replacing validate_is_french() + new method init() to automatically set default srid = Contact/AFNIC::validate() : calls SUPER::validate + added test on srid() vat(), better validation of contact data and standardization of API after addition of EPP at registry (per discussion with Jim Driscoll) = ContactSet::get_all() new method = Registry : add_profile() now completely replaces add_current_test_profile(), new_current_profile() and new_profile(); see files in eg/ and t/ for examples = Registry : better logging in profile creation and process()/process_back() methods = Transport : change of defaults, retry=2 (this means 2 tries totally) and timeout=60 now, instead of 1 and 0 (no timeout) + better default try_again() = Transport subclasses : the new() input API is normalized with only a context and a ref hash in all cases = Transport,Transport/HTTP,Transport/Socket,Protocol connection classes read_data() : better information in error messages = Transport/Socket : you can use ssl_passwd_cb if you need to decrypt the SSL key before using it = Transport/Socket : the ssl_verify_callback called gets the transport object as first parameter, before IO::Socket::SSL parameters = Transport/Socket : more logging + better handling of connection closing/sensing EOF = Protocol : add many default factories + new methods parse_iso8601() build_parser_strptime() to simplify subclasses work + new method has_module() = Protocol connection classes : added transport_default() methods where needed = Protocol classes : new() API expects a ref hash = Protocol/ResultStatus : for get_data methods, the previous "command" attribute is now "raw_command", and "reply" is "raw_reply", "action" is "object_action", "type" is "object_type", and added "object_name" "registry" "profile" "protocol" "transport" "trid" = Protocol/ResultStatus : in get_data() get_data_collection() keys are normalized so that domain and host names can be used in lower or upper case (same as for DRD::get_info), see examples at bottom of t/601vnds_epp.t = Protocol/ResultStatus : new last() method = Protocol/OpenSRS/XCP/Domain : added operations check create delete renew transfer_request transfer_query transfer_cancel (contributed by Richard Siddall) = Protocol/BookMyName/WS : implemented domain_check = Protocol/Gandi/WS : implemented domain_check = Protocol/OVH/WS : implemented domain_check + using now Transport::HTTP::SOAPLite instead of SOAPWSDL (API change of SOAP::WSDL and/or of OVH ?) and related changes = Protocol/Whois/Connection::read_data() : we now suppose the data is in iso-latin-1 encoding instead of ascii = Protocol/Whois/Domain/* : use of $po->build_parser_strptime() instead of directly using DateTime::Format::Strptime = Protocol/Whois/Domain/SE : parse registrar name = Protocol/Whois/Domain/EU : adapt to new format = Protocol/DAS : better handling of registries with more than one TLDs (adhoc, no universal specifications of DAS protocol), and those wanting a domain without a TLD in query (what a great idea ... not !), like BE/EU = Protocol/DAS/Message : handle slightly different format for .EU = Protocol/AFNIC/Email/Domain : PM activated now only with legal_id defined, line 3a is always name() not org(), srids must be provided instead of roids hence without -FRNIC = Protocol/{EPP,RRI}/Connection : better handling & more debug information in error messages while attempting to read the first 4 bytes = Protocol/{EPP,Whois} : use of $drd->set_factories() if possible (factorization of contact factories) = Protocol/EPP : better handling of modules to load through 2 new methods, core_modules() and default_extensions() + add a setup() method for subclasses = Protocol/EPP/Message : various simplifications/rewrites and changes for performances and readability = Protocol/EPP/Extensions/* : huge simplification of instantiation with setup() + default_extensions() instead of new() = Protocol/EPP/Extensions/SecDNS::format_validation() : better error message = Protocol/EPP/Extensions/SE,Contact/SE,DRD/SE : various updates by Ulrich Wisser from NIC.SE = Protocol/EPP/Extensions/AFNIC/{Domain,Contact} : various updates to latest production specifications (trade cancel, PM activated now only with legal_id defined) = Protocol/EPP/Extensions/AFNIC/Notifications : added parsing of all messages related to contact identification = Protocol/EPP/Extensions/EURid/Domain::transferq_request() : use key duration instead of key period = Protocol/EPP/Extensions/Nominet/Domain : unrenew operation = Protocol/EPP/Extensions/Nominet/Account : list_domains operation = Protocol,Protocol/*/* : cleanup in the use of factories()/create_local_object() = Protocol/EPP/Core/*,some EPP/Extensions/*,Protocol/Whois/Domain/* : no more hardcoding of Data modules, using Protocol->create_local_object() instead = Protocol/EPP/Core/*,some EPP/Extensions/*,Protocol/Whois/Domain/* : use of Protocol->parse_iso8601 instead of calling directly DateTime::Format::ISO8601 = Protocol/EPP/Core/*,some EPP/Extensions/* : use of textContent() instead of getFirstChild()->getData() = Protocol/EPP/Core/*,some EPP/Extensions/* : use of Util::xml_list_children() Util::xml_child_content() = Protocol/EPP/Core/RegistryMessage::parse_poll() : better handling of non recursion barrier = Protocol/EPP/Extensions/Nominet/Domain : unrenew operation - Protocol/EPP/Extensions/Nominet/Account : correctly handle empty account:contact nodes (bugreport by Jim Driscoll) - Protocol/Gandi/WS/Domain : correct parsing of contacts - DRD::domain_create() : various bugfixes in case of pure_delete=0 - Transport/HTTP/XMLRPCLite : various bugfixes - Protocol/Whois/Domain : removed as not used - Shell : crash for some tab completion conditions (add_current_profile,contact_create) - Contact::loc2int() : make sure not to create an undef instead of an empty ref array in street structure, when empty street - Contact/AFNIC::validate() : correct test for name() legal_form_other() birth() - Protocol/EPP/Extensions/Nominet : we handle the namespaces versions mix and mess locally - Registry::get_info_all() : make a copy of the hash before starting to delete keys 0.92_01 2009-01-31 DEVELOPMENT RELEASE (not to be used in production without extensive testing if upgrading from some previous version) UPGRADE instructions from previous versions: - use add_profile/add_current_profile instead of new_profile/new_current_profile (warning: you may hit different APIs, depending on how you used new_profile/new_current_profile !) - remove use of log_fh attribute during transport setup, and use instead the new Logging framework (see Net::DRI and Net::DRI::Logging modules documentation) Detailed changes: + Registry add_profile()/add_current_profile() : new methods that will replace in the future new_profile()/new_current_profile() with a better API; this will also make it possible to have DRD protocol agnostic again the future (when old API completely removed) ; all scripts in eg/ and test files in t/ have been updated + Logging : a new framework has been put in place, for better extensibility ; fix of encoding bug ; various logging has been added, at debug level, to facilitate debugging (such as methods called, cache handling, transport loops/timeouts/retries) ; see document of modules Net::DRI, Net::DRI::Logging and Net::DRI::Logging::{Stderr,Files,Null} + Protocol/ResultStatus : $rc objects returned from most operations do also contain now all data retrieved with the operation (including the raw messages exchange), which can be accessed by get_data()/get_data_collection() method on the the $rc object, see module documentation + Shell autocompletion support for commands and parameters (domain names, contacts, hostnames, local filenames), see Net::DRI::Shell documentation + Shell new commands: add, record, set, show config, !cmd, help and add_current_profile (replacing new_current_profile) + backticks for batch operations ; see Net::DRI::Shell documentation + .IM support (EPP) : interoperability not tested + .SI support (EPP) : interoperability not tested + Data/Contact (and all subclasses) : a new method attributes() allows to know what attributes exist for this specific class of contact data + Data/Contact as_string() : better handling of subclasses attributes, now also automatically included in output, as well as class name (to know the contact type) + DRD/EURid : add registrar DAS (type=das-registrar) & registrar Whois (type=whois-registrar) profile types + DRD/CoCCA : .NA and .NG added + DRD/DENIC : add 9.4.e164.arpa in list of tlds, as they can be queried with IRIS DCHK + DRD/ICANN : .MOBI and .COOP can have one character domain name + DRD/WS : domain transfer operations are now possible + DRI del_registry() : to properly close all profiles in a given registry name (or the current one if no parameter given) + Registry del_profile() : deletes the current profile (or the name specified as input), which will also close transport connections associated with the profile as needed + Protocol/IRIS/XCP (RFC4992) : prototype implementation (no publicly known server uses this for now), only SASL PLAIN is supported + Protocol/IRIS/Core parse_authentication() : to support SASL in IRIS (RFC4991 authentication messages) + Shell : if we detect the server has closed connection, we try to reopen it at next command + DRI : cache() method to return the current underlying cache object + Cache : ttl() accessor/mutator to query or change the current time to live for cached data + DRD registry_can() : returns 1 or 0 if the operation given as input parameter (ex: domain_create) is available for the currently selected registry + Protocol/ResultStatus : new method is_closing() returns 1 if the server has closed connection (after successful operation or not) + Protocol/ResultStatus : new method is() to check symbolic return codes, see module documentation + Protocol/IRIS/LWZ : now supports compressed responses (with some help by Felix Antonius Wilhelm Ostmann) ; nicely handling of current mismatch between RFC LWZ compression method (RFC1951) and DENIC IRIS DCHK server (RFC1950) + Protocol/EPP/Extensions/Neulevel/IDNLanguage (contributed by Jouanne Mickael) + Protocol/EPP/Message : added a message/info/checked_on key always there with a DateTime object to know when we got information on number of messages waiting = Protocol/EPP/Message : we always set message/info/count attribute, including to 0 if nothing pending = Protocol/.../Connection classes : we use EPP code 2500 instead of 2400 (through ResultStatus new COMMAND_FAILED_CLOSING symbolic name) to warn where we were not able to get registry response, probably due to a closed connection = Protocol/.../Message classes : as_string() is now mandatory to be implemented (for logging purposes), so add it where needed = Protocol/EPP/Extensions/DNSBE/Domain : trade operation now needs op=>'request' (bugfix by Roger Heykoop) = Protocol/IRIS/Message : add xml preambule to outgoing messages = Registry available_profiles() : returns list of fullnames (profile name + protocol name + transport name) if passed a true value = Protocol/ResultStatus info() has been renamed to get_extended_results() = DRI trid_factory() accessor/mutator, this is a coderef used everywhere (including in Transport classes) to generate transaction identificators such as clTRID in EPP (all Transport classed have been modified to use that) = Caching changes (see Registry::try_restore_from_cache, DRD and various DRD subclasses): Registry::set_info_from_cache() disappears and its features are subsumed by try_restore_from_cache() ; two major changes (that will make the cache less often used) : we use it only for the same action, and we use data from the same profile only ; logging is done (at debug level) to be able to track each cache miss or hit ; when results are given from the cache, the result_from_cache (in branch session/exchange) key has a value of 1, otherwise 0 = Transport + DRD/Registry : total rework of sending/receiving messages, better handling of timeouts and retries ; this is specially needed for servers difficult to reach, like public Whois/IRIS/DAS ones = Registry : after exchange with registry, add in ResultStatus data a session+exchange branch with keys: duration_seconds (the duration in seconds of the exchange), command (a string representation of what has been sent to the registry), reply (a string representation of what has been received from registry), result_from_cache (=0), action (name of action that has been done) and type (type of object on which this operation has been done) = DRD {domain,host,contact}_check_multi() : if the currently selected protocol does not support check_multi, we emulate by doing multiple check calls, as needed = DRD domain_create() : if not pure_create, we start by doing a domain_check and stop there if domain exists already (so that we do not trigger an hitpoint at registry like EURid) = DRD/NO : verify_name_domain() updates = DRD/DENIC : better parameters for IRIS DCHK timeouts and retries = Util : fulltime() and xml_indent() methods added, used by Logging framework = Util : encode() encode_utf8() encode_ascii() decode() decode_utf8() decode_ascii() methods added, as wrapper around Encode = When using Encode::{encode,decode}(), use check=1 (die on malformed data) = Protocol : the name key is only set for domain and host object types, not in all cases = Connection classes for EPP,RRI,IRIS : using sysread() instead of read(), since we do not want any buffering = Connection classes for EPP/Extensions/PL,OpenSRS/XCP : using HTTP::Response::decoded_content() method instead of just content() = Connection classes read_data method : make sure to translate what we received into perl native strings (Encode::decode & similar stuff) = EPP/Extensions/PL/Connection write_message() : encode perl string in utf8 before putting in HTTP::Message::content = DRD : add a default verify_name_domain() and domain_operation_needs_is_mine() for all subclasses, this make many DRD subclasses simpler and shorter = DRD classes : various simplifications and removals (verify_duration_transfer, is_my_tld, domain_operation_needs_is_mine), plus use of BaseClass::make_exception_for_unavailable_operations = DRD classes : sanitization of the internal API for verify_name_domain, and rewrite in the new framework (using DRD::_verify_name_rules) = Protocol/EPP/Extensions/AFNIC : various updates following registry new prototype = Protocol/AFNIC/Email : various updates for form version 2.5.0 (notably: authinfo mandatory, nameservers not mandatory) - DRD contact_check_multi() : make sure to allow a ref hash for optional parameters, as with all other contact methods - Protocol/IRIS/LWZ : make sure to start with a clean empty DNS resolver - DRD/DENIC : make sure to use "de." and not "de" for DNS queries (finding NAPTR servers) - Protocol/EPP/Core/RegistryMessage pollack() : message ids are not necessarily numbers, but XML token (RT#41032 reported by Joaquim Carandell) - Protocol/EPP/Core/{Contact,Domain,Host} : for registry notifications (poll messages), we do not set the exist key anymore as the operation may be related to a creation or something else ; this would need to be handled by extensions - Shell : properly take into account quit commands in script files (reported by Eberhard Lisse) - DRD domain_{delete,create}_only() : deprecated methods, now removed (see previous version) - Protocol/{EPP,RRI,IRIS}/Connection : use strict utf8 ("UTF-8") and not Perl lax utf8 ("utf8") when encoding before sending to server (through Util::encode_utf8 function) - Protocol Connection classes login() logout() keepalive() methods : now they return the message, and do not call write_message themselves, this is done by Transport class (for homogeneity and logging reasons) - Protocol/IRIS/Core parse_error() : correct parsing of messages/languages (they were swapped) - Protocol/EPP/Extensions/BR/Contact : allow update of pure contacts (no orgid) 0.92 2008-10-08 + IRIS support (RFC3981) with LWZ transport (RFC4993) for DCHK (RFC5144): currently only DENIC registry (.DE) provide this service, but this new set of protocols have been created to replace the current sad state of whois (a change that will probably take years) See eg/iris_dchk.pl + Net::DRI::Shell : a new version of the earlier prototype, now revamped, extended, documented, with support for all Net::DRI operations, and batch feature for domain name operations with logging and time statistics. See its documentation for all details ; it can very easily be used to leverage all power of Net::DRI without writing any line of code! + .UK EPP support : added new registry operations (account fork and merge, registry notifications), upgraded to version 1.1 of their local schema and correctly handle login + .PT EPP support, with domain and contact extensions (see t/640pt_epp.t) + Preliminary CoCCA support (.CX .GS .TL .KI .MS .MU .NF .HT) : interoperability tested with registry ; in the future the general CoCCA DRD should be replaced by multiple DRDs, one for each TLD, implementing each the specific country policy on its ccTLD + Full CentralNic EPP support, interoperability tested with registry (see t/621centralnic_epp.t) + .BR various updates and interoperability tested with registry + .NO various updates: improved contact validation and more refined service message parse for delayed domain transfer responses (submitted by Trond Haugen) + Transport/Defer : preliminary prototype for debugging ; can also be used in production to simulate operations without sending anything to the registries = DRD::domain_create_only() is now deprecated (and will be removed in later versions), you should use domain_create with a pure_create key and value of 1 ; examples and tests have been updated = DRD::domain_delete_only() is now deprecated (and will be removed in later versions), you should use domain_delete with a pure_delete key and value of 1 ; examples and tests have been updated = DRD/ME : 1 year registrations allowed since October 1st = Transport/Socket : UDP support (for LWZ needed by IRIS.DCHK) = Transport/Socket : dynamic remote_host/remote_port possible (needed for IRIS.DCHK) = Data/Changes : add() del() set() returns the object itself now = Protocol/EPP/Core/RegistryMessage : handle notifications completely and only inside the node ; add error message if no ID given for message to delete = Protocol/ResultStatus : changed as_string() output format and better handling of no message case = EPP/Core/Message & RRI/Core/Message : factorization of _toxml and transplantation into Net::DRI::Util = Protocol : do no set result_status if already set inside parse functions (like in IRIS DCHK) = Registry : allow to use local_object() for a DateTime or DateTime::Duration instance/has_object = Data/Contact : little change in as_string() format output = DRD : domain_create() will create contacts if needed, passed and not pure_create = DRD/US : contact internationalized data, either INT+LOC or INT only = DRD/VNDS : do not use RRP any more = DRD/COOP : use ICANN policies for reserved names, and allow 2 characters domain names = Data/Contact/AFNIC : new firstname method, the name() method should store only the lastname (this impacts both email and EPP operations) = EPP/Extensions/AFNIC : various updates for next iteration of .FR EPP beta server - DRD/*::object_types various fixes (removal of 'ns' when hosts are only attributes at registry) - Transport : bugfix for encoding during logging (submitted by Trond Haugen) ; should probably be only temporary before a better logging system - DRD : bugfix for host_update_name_set and has_object - DRD/US : correct contact I18N (bugfix by Marc Winoto) - EPP/Connection : handle newlines before closing node (bugfix by Marc Winoto) - EPP/Connection : handle empty line(s) at end of message 0.91 2008-07-30 + .BR EPP support, with Domain and Organization extensions (see t/635br_epp.t) + OpenSRS XCP protocol (resellers interface): preliminary implementation, only domain_info and account_list_domains (see t/639opensrs_xcp.t and t/704opensrs_xcp_live.t) + .US whois support + Experimental Net::DRI shell limited to domain check operations for now, see Net::DRI::Shell for details + Net::DRI::TrapExceptions, for easier tests/debugging (not considered to be part of official API, to use only inside t/*) + EPP/Core/RegistryMessage : for poll responses (all registries), info is now also available through keys related to the object queried, and not only just through the message retrieved. See tests around message_retrieve in t/635br_epp.t for examples + .JOBS Contact support and NameStore domain extension for contacts (contributed by Tonnerre Lombard) + .PRO support, with domain activations (contributed by Tonnerre Lombard) + .AT Domain keydate extension support (contributed by Tonnerre Lombard) + .NO updates (submitted by Trond Haugen) + Transport/HTTP : new transport needed for pure HTTP/HTTPS registries (OpenSRS, .PL, .ES, etc.) + EPP/Extensions/PL/Connection : needed to be able to use HTTPS transport for .PL EPP + .FR EPP extensions (currently not in production at the registry) and related needed updates in DRD/AFNIC and Data/Contact/AFNIC = */Connection Transport/Socket : get_data is now read_data, and write_message is mandatory (done previously somehow in corresponding Message classes) ; other methods expect the transport object as first parameter = */Connection : EPP error code COMMAND_FAILED instead of COMMAND_SYNTAX_ERROR in most places = DRD/PL : use EPP over HTTPS not over TLS = EPP/Extensions/PL : updated to latest registry specifications (contributed by Tonnerre Lombard) = Protocol : new API for factories() and capabilities() = DRD : extra parameters allowed in input API for all contact_* methods (needed by some registries) = EPP/Message : internal API (for EPP extensions) changes, removal of get_content(), addition of nsattrs() all EPP modules were modified to fit this new API ; extensions developers should sync their work and always use current EPP/Core/* modules as guidelines = EPP/Core/Domain : no need to provide IPs of nameservers during update in the rem section = EPP/Connection : fix message retrieval for broken registries that send carriage returns (contributed by Tonnerre Lombard) = Contact/AFNIC : take into account various ways to have a date (needed for new EPP extensions) = Data/StatusList : new rem() method to remove a status from the list when really needed - EPP/Message : correct parse of trID blocks in case of multiple occurences (from original bug report by Trond Haugen) ; this prompted a review of various EPP XML parse methods (Core and Extensions), where getElementsByTagNameNS have been changed to getChildrenByTagNameNS, which should improve correctness and speed. - EPP/Core/Domain : domain:null variant should only be used during update and not in other case (from original bug report by Trond Haugen) - EPP/Extensions/{DNSBE,EURid} : correctly handle version 1.0 (from original bug report on .BE by Andreas Wittkemper) 0.90 2008-06-12 + .EU EPP support: updates for Registration guidelines version 1.1B (changes in contact info/update) + release 5.5 (13 May 2008) Added proper methods in DRD/EURid so that remote_object is not needed for .EU operations like transfer from quarantine, trade, undelete, etc. See t/606eurid_epp.t especially for trade operations because of change in API + .UK full support (except registry notifications, not available at registry), including domain creations, domain updates and account updates + .NO ccTLD EPP support added, see t/633norid_epp. Also added a command line EPP client for .NO with some POD documentation, see eg/epp_client_no.pl and also a filter utility eg/xmlfilter.pl to present the xml-sequences (submitted by Trond Haugen) + .DE support (contributed by Tonnerre Lombard) + .CH/.LI support (contributed by Tonnerre Lombard) + .HN/.SC/.VC/.AG/.BZ/.LC/.MN support with Afilias extensions IDNLanguage & Restore (from original work by Tonnerre Lombard) + .ME and .CZ support (contributed by Tonnerre Lombard) + .TRAVEL UIN support (contributed by Tonnerre Lombard) + .TRAVEL whois support (see eg/whois.pl) = Protocol/EPP/Extensions/PIR* renamed to Protocol/EPP/Extensions/Afilias = Remove use of remote_object by creating appropriate extra methods in DRD/LU (the same should be done for extensions defining new actions/subjects) = EPP/Message : better handling of pure extension messages (no command) = EPP/Core/{Domain,Contact} : better handling of authinfo (2 variants during built when empty, and only parsing RFC defined version during info) = EPP/Core/{Domain,Contact} : for update() do not bother checking pending changes, this has to be done earlier, in DRD, to make sure all extension cases are taken into account = EPP/Core/Contact : handling registries not following EPP RFC by omitting the type parameter for postalinfo data (like .CZ) = EPP/Message : better handling of pure extension messages (without a command node) = DRD/ICANN : some gTLD registries are now allowed to create one or two characters domain names = DRD/VNDS : add .bz/.jobs (contributed by Tonnerre Lombard) = DRD/*::verify_name_domain() : homogenize error codes (if your code depends on them, please update it based on new values) = EPP/Extensions/{DNSBE,EURid}/Domain::transferq_request() : use key 'duration' instead of 'period' = EPP/Extensions/AT/Domain : use of Message cltrid, no need to create a new one = Transport/Socket : handle registries without greeting, like DENIC = Data/Changes : added method is_empty() = Data/Hosts : removal of the roid() accesor, added extra parameters for each nameserver, as a ref hash, which can have, for example, a roid key = DRD::is_my_tld() is more strict in default case = DRD::check_name() allow to check multiple cases of number of dots in name being checked = DRD::*_update() : better take into account all capabilities to check the content of the changes being done (from original bugreport by Tonnerre Lombard) = DRD::message_count(): we try to use information already gathered (as EPP registries can give information with msgQ during any command response) before attempting a new message retrieve; same for message_waiting which calls message_count ; see end of t/601vnds_epp for example = DRD::err_invalid_* are now proper class methods = EPP/Core/RegistryMessage various optimizations - Updated examples in eg/ for correct use of local_object() : no need to call new() on it - DRD : fix host_create not to check TLD of hostname being created (from original bugreport by Magnus Lind) - DRD/NAME : contact internationalization (reported by Tonnerre Lombard) - DRD::is_thick() removed - DRD, DRD/NAME : fix test of domain names in registries with multiple zones (number of dots) - EPP/Extensions/{AT,ASIA} various bugfixes (contributed by Tonnerre Lombard) - .FR various bugfixes on domain operations - Removal of all Protocol/*/Message::get_name_from_message() ugly hack for something less ugly but still kind of an hack. - Factorization of various verify_rd() methods into Net::DRI::Util::has_key,has_contactset,has_ns,has_auth,has_duration,isa_contactset,isa_contact,isa_hosts,isa_changes ; this simplifies of lot of code under Protocol/* 0.85 2008-02-12 + .UK EPP support: only some operations for now, see t/626nominet_epp.t (not implemented for now: domain & account updates, domain creations, registry notifications) + .AU EPP support (submitted by Rony Meyer) + OVH : implemented resellers Web Services API (2 functions only for now: account_list_domains and domain_info), see t/623ovh_ws_live.t + BookMyName (aka Free/ProXad/Online/Dedibox/Iliad) : implemented resellers Web Services API (2 functions only for now: account_list_domains and domain_info), see t/624bookmyname_ws_live.t + Gandi : implemented resellers Web Services API (2 functions only for now: account_list_domains and domain_info), see t/625gandi_ws_live.t + Registry : yet another API for new_profile/new_current_profile ! This should have been the only one since the beginning. See files in eg/* Previous API may be deprecated in the future to keep only two: full one (profile name, transport name, transport params, protocol name, protocol params) and the new one (profile name, profile type, transport params, protocol params) + Added Whois support for: .LU .WS .SE .CAT .AT + Implemented RFC5076 (ENUM Validation Information) in Net::DRI::Protocol::EPP::Extensions::E164Validation and Net::DRI::Protocol::EPP::Extensions::E164Validation::RFC5076 (the RFC allows numerous ways to encode validation information,hence the example inside the RFC is handled in a separate module. Other examples from registries are welcome) + PIR IDNLanguage extension (work submitted by Tonnerre Lombard, added with modifications) + .NAME EmailFwd operations (work submitted by Tonnerre Lombard, added with modifications) + .US DRD module (work submitted by Tonnerre Lombard, added with modifications) + Added Data/Hosts::as_string() for debugging, and Data/Hosts::roid() + Additional API for domain_renew in line with other parts with just a domain name and an optional extension as ref hash; see example in t/622vnds_epp_e164validation.t = Better handling of EPP contacts internationalization : each DRD module can specify what the registry expects for contacts data. By default, all 3 cases allowed, except for : .BE .EU .LU (localized only), .AT (internationalized only) and .BIZ (internationalized only or internationalized and localized together). When needed the data is contructed with Contact::int2loc() and Contact::loc2int() Contact::_intfirst() is thus removed as useless now = DRD/NAME : 1 year possible in periods() (reported by Alexander Biehl) = Protocol/EPP/Extensions/VeriSign/NameStore : taking into account .CC and .TV (reported by Tonnerre Lombard, added with modifications) = Protocol/EPP/Extensions/US/Contact : update to currently deployed version (work submitted by Tonnerre Lombard) = Protocol/EPP/Extensions/ASIA/CED : remove extraneous ced hash level in domain_create and fix retrieval of maintainerUrl information (work submitted by Tonnerre Lombard) = Protocol/EPP/Extensions/ASIA/IPR : add support for parsing domainRoid in domain:create, replace obsolete ipr:phase with ipr:type (work submitted by Tonnerre Lombard) = Protocol/EPP/Extensions/LU : fix fetching of DNSLU type parameter in certain cases (work submitted by Tonnerre Lombard) = Protocol/EPP/Extensions/AT : parse more information from .AT messages (work submitted by Tonnerre Lombard) = Protocol/EPP/Core/Contact : support registries violating EPP with an empty contact:clID (from original bugreport by Alexander Biehl) = Protocol/EPP : we correctly parse multiple results (in case of errors), and return them if asked for ; this had consequences for result_extra_info, see comments in Message (Core+DNSBE+EURid), and NameStore = Protocol/EPP various parses : better use of date parsing = Protocol/EPP object can be instanciated with overriding core methods (needed for Nominet) = Protocol/EPP hosts parsing : we keep all IPs even private ones = ResultStatus : can handle more than one status, as a linked list (next() method) = Data/Hosts : we remove the final dot from names if present = Protocol::reaction : we create the result_status subkey for all elements in cache created by this action, not only the main element (this is especially useful for registries giving back a lot of information, like Nominet during a domain:info call giving back information useful for a contact:info or host:info) = Registry::result_status() gives back the whole ResultStatus object = Added Registry::get_info_all() and Registry::get_info_keys() = Modules SOAP::Lite, Net::SMTP, MIME::Entity previously required are now optional because used only by some registries not EPP. t/004load_optional will test their presence, warn which are needed for which Net::DRI use, and test their dependencies inside Net::DRI Same for new modules: SOAP::WSDL (needs SOAP::Lite) and XMLRPC::Lite (provided by SOAP::Lite) Later on, a Bundle::NetDRI could be created to install also all optional modules This means for now less hard dependencies for default case, that is EPP registries = DRD->info() can be called through DRI (from initial report by Tonnerre Lombard) = Cache::get & Cache::set : we do not force the key in lowercase anymore, as contact IDs may be case sensitive = No more eval { require }, using UNIVERSAL::require instead - EPP contacts : use of EPP::Message::core_contact_types() to correctly handle case of .EU/.BE - Protocol/EPP/Extensions/ASIA/IPR : removing use of Date::Parse::str2time() - Protocol/EPP/Extensions/LU/Status : allow to use status 'inactive' (registry specific, not in EPP) (from original bugreport by Alexander Biehl), see last test in t/620lu_epp.t - Protocol/EPP/Extensions/LU/Poll : correctly retrieve the type attribute (from original bugreport by Alexander Biehl) - DRD/AT : bugfix for is_my_tld() (reported by Tonnerre Lombard) - README : typos (there is no Net::DRI::Data::Host module) (reported by Trond Haugen) - t/003critic : better loading of module Test::Perl::Critic which is optional (only needed for tests) - Gandi Web scraping : totally removed as it was deprecated since a long time, and thus Transport/Web and its WWW::Mechanize dependency (this can be added back later if needed) - DRD::is_thick : will carp if still used, deprecated - DRD::root_servers() removed, not used (was only in DRD/VNDS) 0.81 2007-11-07 = Updated all RFCs references related to EPP : RFCs 4930,4931,4932,4933,4934 are now obsoleting RFCs 3730,3731,3732,3733,3734 xsi:schemaLocation is not removed in messages created, but may be removed in future releases we do not add an empty domain:chg any more for pure extension update commands = Conformity with Perl critic Best Practices (level 5) + Added support for .ASIA extensions (work submitted by Tonnerre Lombard) + Update for .EU : taking into account new version=2 for domain_info & domain_check (retrieving more data from registry) Warning : this changes some registry reply codes, see registry documentation + Contact : new method _intfirst() (from suggestion by Rony Meyer) + Transport/Socket : new parameter protocol_data, see documentation (from idea by Rony Meyer) + DRD/VNDS : also handle .CC & .TV + DRD/NAME and DRD/NU : provided by Alexander Biehl + 3 new EPP extensions for CentralNic : WebForwarding, TTL & Domain Release (see t/621centralnic_epp.t for examples of use) + Whois support for .MOBI .NAME (see example in eg/whois.pl) + Transport : new way to do logging (send/receive methods receive an extra parameter at beginning, the trid) = DRD : is_my_tld() correctly handles registries with more than one TLD (from initial bugreport by Rony Meyer) = Data/Hosts : new method clear() (patch by Tonnerre Lombard) = Protocol/EPP/Extensions/VeriSign/NameStore : extension not always provided by registry (bugfix from Rony Meyer) = Protocol/EPP/Extensions/VeriSign/IDNLanguage DRD/ICANN : allow use of xn-- domain names (from suggestion by Rony Meyer) [ This may change in the future, depending on how Net::DRI implements IDN ] - DRD : bugfix in domain_can (bugfix from Tonnerre Lombard) - Protocol/EPP/* (various parses) : better handling of XML nodes/elements (from initial bugreport by Tonnerre Lombard for .LU) 0.80 2007-04-19 + DAS support for .EU & .BE : quick lookup of domain availability ; see eg/eurid_das.pl for an example (same interface as domain_check) + Whois support (RFC3912) for thick registries (full) and thin registries (only registry part) ; see eg/whois.pl for an example (same interface as domain_info) ; parse provided for .COM .NET .ORG .BIZ .INFO .AERO .EU + .LU support : all extensions (except startTLS & IDNs) ; we do not enforce policy of only one IPv4 and one IPv6 at most for hosts + Transport/Socket : new parameter ssl_version (suggestion from Rony Meyer) + Transport/Socket {RRP,EPP}/Protocol/Connection : allow changing password at connection (from initial patch by Rony Meyer) + DRD/BIZ (provided by Rony Meyer) = DateTime::Format::ISO8601 : required version is now 0.06 (0.0403 is also ok, but 0.05 is absolutely not ok, hence we upgraded the required version) = .AT updates (contributed by Michael Braunoeder from NIC.AT) = Data/Contact : new as_string() method for quick display = Data/ContactSet : minor changes, rem as alias to del, add/del/set returns the object itself, as new() (with explicit return) = Protocol/EPP/Core/{Domain,Host} VeriSign/PollRGP: make sure to lowercase domain names given back by registry (from bugreport by Rony Meyer) We advise passing to Net::DRI only domain names and hostnames in lowercase. - DRD : bugfix in contact_info for cached values (bugfix from Rony Meyer) - Protocol/EPP/Core/Host : bugfix in parsing IP addresses (bugreport from Rony Meyer) 0.70 2007-03-12 + .COOP full support : all operations with EPP, see included example in eg/coop_epp.pl and t/619coop_epp.t (with help from registry staff member Dan Maharry) + .AT full support : all operations with EPP, contributed by Michael Braunoeder from NIC.AT + .EU (DRD/EURid) : added Bulgaria and Romania + Transport/Socket : a new trid key whose value is a code ref can be provided to generate transaction ids (from Rony Meyer idea) + Transport/Socket : we pass MultiHomed => 1 when opening socket (tcp and tls) in order to try all IPs (suggested by Michael Braunoeder) + Transport/Socket : for TLS, a callback can be specified to verify server credentials + DRD/INFO DRD/ORG : contributed by Rony Meyer + Contact : int2loc() and loc2int() methods to create localized version from internationalized, or the opposite = .MOBI : maintainer url is not mandatory (bugfix from Rony Meyer) = Protocol/EPP/Extensions/SecDNS : during domain create, no secdns data is not a fatal error anymore = Protocol/EPP/Extensions/MOBI/Domain : maintainer_url is not mandatory (bugfix from Rony Meyer) = Protocol/EPP/Message : for poll replies, id of _current_ message is available, like count (see source) = DRD/ICANN : operations (except domain creation) on one-letter and two-letter domain names are now possible (not denied) ; this should really be handled on a per-registry basis (from suggestion by Rony Meyer) = Protocol/EPP/Core/Domain : for some registries (like .AT) we send all nameservers' IP, even if nameserver is in domain = Protocol/EPP/Core/Status : delete/renew/update operations are allowed even if some pending status is set (per draft-hollenbeck-epp-rfc3731bis-05.txt draft-hollenbeck-epp-rfc3732bis-04.txt draft-hollenbeck-epp-rfc3733bis-06.txt) - Protocol/EPP/Core/RegistryMessage : correctly handle case of no message at all, or message without extra data (bugreport by Elias Sidenbladh) ; see end of t/601vnds_epp.t - .SE (Data/Contact/SE DRD/SE) : bugfixes by Elias Sidenbladh - Protocol/EPP/Core/Contact : minor bugfix in contact creation (parse_disclose) from Elias Sidenbladh - Transport/Socket : ssl_verify was not taken into account, bugfix by Rony Meyer - Protocol/EPP/Extensions/{DNSBE,Eurid}/Domain : add op="request" for transferq commands (bugreport and fix from Cedric Dubois) - Transport : use true loops in send() and receive() (bugreport from Elias Sidenbladh) 0.40 2006-09-22 + .BE full support : all operations with EPP except agent update & info (with help from Roger Heykoop) + EPP : better support for results, we parse all replies for which we already have a parse function registered + EPP/Extensions : RGP Notification & Low Balance Notification for VeriSign (poll messages) + DRD : new method message_count() to retrieve the number of messages available + Transport/Socket : added ping(), with autoreconnection if wanted and necessary + EPP & RRP : for all actions returning information, a key action is created whose value is the name of the action that has triggered this reply (see 600vnds_rrp.t 601vnds_epp.t 605vnds_epp_nsgroup.t 613cat_epp.t) = EPP/Core/Contact : correctly handle case of contact:id being chosen by registry during contact:create (see 601vnds_epp.t) = EPP : uses instead of as keepalive message (explicitely allowed in draft-hollenbeck-epp-rfc3730bis-02.txt) = EPP/Extensions/CAT/DefensiveRegistration : better handling of XML namespace = Transport : creation time is available through time_creation() like time_open() and time_used() - Transport : correct month & minutes in logging (bugfix by Rony Meyer & Christian Kratzer) - DRD/VNDS : verify_domain_transfer does not need a full domain_info with hosts=all, none is enough (bugfix by Rony Meyer) - DRD : correct retrieval of result status from cache (bug report by Rony Meyer) - Protocol/EPP/Connection : take into account message language if given by registry (bug report by Rony Meyer) - Protocol/EPP/Extensions/VeriSign/WhoisInfo : handle default value for indirect domain_info calls (bug report by Rony Meyer) - Protocol/EPP/Extensions/GracePeriod : correctly takes into account VeriSign breaking its own RFC (bug report by Rony Meyer) 0.30 2006-06-15 + .FR full support : all operations by email (form version 2.0.0 for both organizations & individuals) + .COM .NET full support in EPP with multiple VeriSign extensions: Sync (see t/610vnds_epp_sync.t) IDN Language (see t/611vnds_epp_idnlang.t) Whois Info (see t/612vnds_epp_whoisinfo.t) NameStore from original patch by Rony Meyer (see t/616vnds_epp_namestore.t) Use Protocol/EPP/Extensions/VeriSign as protocol class to have needed extensions loaded automatically + .MOBI full support : Domain extension for maintainer url (see t/615mobi_epp.t) + .US full support : Contact extension for NEXUS handling (see t/609vnds_epp_us.t) + .AERO full support : Domain & Contact extensions for ENS (see t/614aero_epp.t) + .CAT full support : Domain & Contact extensions, and all operations on Defensive Registrations (see t/613cat_epp.t and eg/cat_epp.pl) thanks to Klaus Malorny & the .CAT registry + Infrastructure ENUM.AT (contributed by Michael Braunoeder from ENUM.AT) + Protocol/EPP/Extensions/SecDNS updated to RFC4310 + .PL updated to latest draft + new_profile / new_current_profile : additional API with only 3 parameters (profile name + 2 ref arrays for parameters, both can be empty) using registry default transport & protocol classes (see transport_protocol_default) + ResultStatus->trid() can also be called in list context to get back for EPP the svTRID along with the clTRID (suggestion by Elias Sidenbladh) = DRD : for transfers, like for creations, the duration is in the duration attribute not period = Protocol/EPP/Extensions/EURid/Domain : multiple nsgroup can be given (patch from Christian Kratzer) = DRD/ICANN : taking care of some lifted restrictions for newest gTLDs (starting with .TRAVEL) = Protocol/EPP/Core/Domain : for domain_info, hosts=all is the default, but you can pass another value (sub, del or none) in the hosts attribute (bugfix from Rony Meyer) = Protocol/EPP/Extensions/E164 : small update to work with IENUMAT relaxed rules from RFC4114 = Util : update in list of country codes, add JE GG IM per http://www.iso.org/iso/en/prods-services/iso3166ma/03updates-on-iso-3166/nlv11-div.html = Transport/Socket : you can optionnally set the local hostname when connecting (suggestion from Brian Drysdale) = Protocol/Gandi : currently deactivated since change of website - Protocol/EPP/Core/Domain : domain:pw may be empty after domain:info for an object we do not own (bugfix from Rony Meyer) - Protocol/EPP : better handling of registries various XML namespaces 0.22 2006-05-12 + EPP Poll from prototype by Elias Sidenbladh (Protocol/EPP/Core/RegistryMessage) : new methods message_retrieve() (=poll request) message_delete() (=poll ack) and message_waiting() in Net::DRI Please see examples at the end of t/601vnds_epp.t on how to retrieve info on a message, and info on all messages (count & first id). + Preliminary support for .FR/.RE by email : only domain creation for now, without parsing of registry emails coming back (Net::DRI::Data::Contact::AFNIC Net::DRI::Protocol::AFNIC::Email Net::DRI::Protocol::AFNIC::Email::Message Net::DRI::Protocol::AFNIC::Email::Domain Net::DRI::Transport::SMTP) For all asynchronous operations, the result status is command successful but pending. + In all result status, new method trid() that stores the (local/client) transaction identifier of the operation that generated this result status, and new method is_pending() to know if the operation has been done or is pending review, which will be the case for all asynchronous registries (Protocol/ResultStatus) = EPP + RRP : we use the nameserver list provided in domain operations only if it is not empty = Data/Contact/EURid : lower limits for name/org length than in EPP - Transport/Socket : correctly shut down alarms in end() (thanks to Sten Spans) - Protocol/EPP/Extensions/EURid/Domain : bugfix for transfer/transferq/trade requests when specifying nameservers, from bug report by Andreas Wittkemper - Protocol/EPP/Connection : bugfix when there is no svcExtension (found by Michael Braunoeder) - Protocol/EPP/Core/Contact : correctly handle all cases of empty fax (and tel for that matter), bug report from Brian 0.21 2006-03-04 + Support for .SE (based on EPP) thanks to Elias Sidenbladh and the NIC SE team + Support for .PL (based on EPP) except the Future object (interoperability with registry not tested) + Data/Contact,Protocol/EPP/Core/Contact : we now handle both internationalized and localized data, for registries handling both. Changes are backwards compatible with previous version, but make sure to test on your systems before installing in production. + Protocol/ResultStatus : new print_full() method to have all details from registry + Data/Hosts : new set() method + Transport : we keep time of last use (idea from Brian), with method time_used() = Transport/Socket : if sending fails, and retry > 1, we try to reconnect ; this is a crude way to handle registry timeouts = local_object() enables you to create any kind of local objects, including hosts, contacts, contactsets, changes, etc... without having to load and directly call Net::DRI::Data::Hosts,Contact,ContactSet,Changes Please see the modified t/606eurid_epp.t for examples = better error debugging in new_profile() when loading Transport and Protocol classes = Transport/Socket : do not use IO::Socket::SSL::context_init anymore, it is marked as deprecated in module - Protocol/EPP/Message : correct creation of commands (bug found by Elias Sidenbladh) - Protocol/{EPP,RRP}/Message : correct encoding of outgoing messages with Encode::encode() - eg/eurid_epp.pl : the filehandle used for logging must be closed after $dri->end() not before 0.20 2005-12-02 + EURid/Sunrise : we automatically reconnect after each apply command (successful or not), when needed, since the connection is dropped by registry (bug reported by Lucas Vossberg) + Transport/Socket : a client certificate is no more mandatory, the default verification level is lowered, better error message for SSL problems (suggested by Peter van Dijk) - Protocol/EPP/Extensions/EURid/Sunrise : various bugfixes for documentaryevidence=thirdparty (found by Yves Cartenstadt) = EURid : the sample provided (eurid_epp.pl) dumps all exchanges to a file 0.19 2005-11-14 + Updates for conformity with latest EURid specifications : # extra information in result of apply during Sunrise (reference, code, crDate) # new action apply_info during Sunrise to get back information on previously submitted applications (reference, code, crDate, application_status, contact, ns, docsReceivedDate, adr) + Protocol/Resultatus : extra information from registry (error messages) is available with info() + EPP/Extensions/EURid : we parse eurid:msg for extra information, especially useful if errors - EPP/Extensions/EURid/Sunrise : invalid call for nsgroup (bug found & fixed by Jørgen Thomsen) = Data/Hosts has 2 significative changes : you can use get_details with a name and you can add a nameserver already in the list, in which case the new IP addresses are added with existing ones (without duplicates) 0.18 2005-11-06 + Many improvements for .EU support : no need to specify empty useless values needed for EPP but not used by EURid (domain/contact auth), no status handling for domains, example for test systems (eg/eurid_epp.pl) - EPP/Message : use bytes is necessary for correct length calculation = Transport : if a server closes the connection on us (at protocol level, not socket one), we note the fact and will try to reconnect later if needed = RRP : take into account PENDINGRESTORE PENDINGDELETE PENDINGTRANSFER status 0.17 2005-10-24 + Full support for EURid (.EU) with Net::DRI::DRD::EURid, Net::DRI::Data::Contact::EURid, Net::DRI::Protocol::EPP::Extensions::EURid and Net::DRI::Protocol::EPP::Extensions::EURid::* + Query list of object types managed by registry (ex: domain, contact, etc...) with $dri->has_object() + A copy of all exchanges can be sent to the filehandle of your choice (see log_fh in Net::DRI::Transport) - BUGFIX in handling of dates in EPP : we switch to UTC before printing - BUGFIX in Net::DRI::Protocol::EPP::Connection : data may come in multiple chunks - BUGFIX in Net::DRI::Protocol::EPP::Core::Domain : handling of hosts as attributes = Net::DRI::Data::Hosts::add() returns the object itself (useful for chains) = Net::DRI::Data::Contact::validate() verifies the country code against the list in Util = No more hardcoding of various xml namespaces names in various modules, the list is set during protocol object creation. = domain_create() : a duration is not mandatory 0.16 2005-10-04 + Three new EPP extensions : SecDNS (for DNSSEC), E164 (for ENUM) and NSgroup (for .BE & .EU) + New registry : .WS + New API in addition to the existing one, with Net::DRI::Data::RegistryObject : needed for extensions that handle new types of objects, such as NSgroup + Take into account new error codes for AFNIC Web Services (technical note RP-20050913/DT-01) + Add a name() and loid() accessor in Net::DRI::Data::Hosts - In EPP, we load host commands only if hosts are handled as an object by the registry - For domain_info(), host_info() and contact_info() we use data from cache, if we really did an *_info() before. - Various bugfixes in DRD and RRP protocol. = Rework of Net:DRI::Protocol::ResultStatus & associated classes to handle more cases by directly passing the EPP code = Simpler in-memory XML nodes representation in Net::DRI::Protocol::EPP::Message = Rework of Net::DRI::Protocol::{EPP,RRP}::Connection & Net::DRI::Transport::Socket (send_login) to die with a Net::DRI::Protocol::ResultStatus in case of problems + Changes in Net::DRI::Registry::new{,_current}_profile to return a ResultStatus object = Change in EPP domain_update as RFC3731 is ambigous (text & XML schema do not agree) With this change, we now conform to the XML schema, which seems normative per provreg mailing-list consensus. This will break with any server implementing the text part 0.15 2005-07-20 + New protocol: EPP, with Grace Period extension (other can easily be added) + Better way to create statuses (no() function in StatusList), see README for domain_update_status_add and statuses name are not put in uppercase automatically + Handling of contacts : modules Contact & ContactSet + new functions in DRD (contact_*) + New functions: domain_check_multi, host_check_multi (if registry supports, check multiple objects at once) - BUGFIX in Net::DRI::Util::is_ipv6 - BUGFIX : better checks of references with UNIVERSAL::isa instead of pure ref() = Rework of Net::DRI::Transport::Socket & associated connection classes 0.12 2005-05-31 + New ``registries'': 1) AFNIC (through web services, domain check only) 2) Gandi (through web site, domain nameservers update only) + New transport: SOAP (HTTP/HTTPS only) + New transport: Web (Web Scraping) + New protocol: Gandi Web Site (domain update only) + New protocol: AFNIC web services (domain check only) + New way of using profiles in Net::DRI::Registry : an auto switch functionnality is provided so that the calling app does not have to call target() explicitely over and over (see README for details) - BUGFIX for RRP : order of elements is now exactly as specified by standard - BUGFIX for Net::DRI::DRD in host_is_mine: parameters (warning not triggered in some perls) - BUGFIX for Net::DRI::DRD in err_invalid_domain_name/err_invalid_host_name: correct message & really raise an exception if a problem is found ! - BUGFIX for Net::DRI::DRD in check_name: correct count of dots + Net::DRI::Transport::Socket : require on the protocol connection class to make sure it works - DOCFIX for Net::DRI::Data::Hosts (a ] was missing for the ref array of IPs) + New tests for Net::DRI::Protocol::RRP::Connection, Net::DRI::Protocol::AFNIC::WS::Message, Net::DRI::Protocol::Gandi::Web::Message, Net::DRI::Protocol::Gandi::Web::Connection - BUGFIX : no more warnings in tests, we use the TODO block of Test::More 0.11 2005-04-25 + POD NAME section for each file with a short description - BUGFIX for VERSION (. missing) + New files: Changes, TODO = No changes in code 0.10 2005-04-24 = First version on CPAN Net-DRI-0.96/lib/0002755000175000017500000000000011352534417013243 5ustar patrickpatrickNet-DRI-0.96/lib/Net/0002755000175000017500000000000011352534417013771 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/0002755000175000017500000000000011352534417014407 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Cache.pm0000644000175000017500000000737011352534376015761 0ustar patrickpatrick## Domain Registry Interface, local global cache ## ## Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Cache; use strict; use warnings; use base qw(Class::Accessor::Chained::Fast); __PACKAGE__->mk_accessors(qw/ttl/); use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.10 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Cache - Local cache for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $c=shift; my ($ttl)=@_; my $self={ ttl => $ttl, ## if negative, never use cache data => {}, }; bless($self,$c); return $self; } sub set { my ($self,$regname,$type,$key,$data,$ttl)=@_; Net::DRI::Exception::err_insufficient_parameters() unless Net::DRI::Util::all_valid($regname,$type,$key); my $now=Net::DRI::Util::microtime(); $ttl=$self->{ttl} unless defined($ttl); my $until=($ttl==0)? 0 : $now+1000000*$ttl; my %c=(_on => $now, _from => $regname, _until => $until, ); if ($data && (ref($data) eq 'HASH')) { while(my ($k,$v)=each(%$data)) { $c{$k}=$v; } } if ($self->{ttl} >= 0) ## we really store something { $self->{data}->{$type}={} unless exists($self->{data}->{$type}); ## We store only the last version of a given key, so start from scratch $self->{data}->{$type}->{$key}=\%c; } return \%c; } sub get { my ($self,$type,$key,$data,$from)=@_; return if ($self->{ttl} < 0); Net::DRI::Exception::err_insufficient_parameters() unless Net::DRI::Util::all_valid($type,$key); ($type,$key)=Net::DRI::Util::normalize_name($type,$key); return unless exists($self->{data}->{$type}); return unless exists($self->{data}->{$type}->{$key}); my $c=$self->{data}->{$type}->{$key}; if ($c->{_until} > 0 && (Net::DRI::Util::microtime() > $c->{_until})) { delete($self->{data}->{$type}->{$key}); return; } return if (defined($from) && ($c->{_from} ne $from)); if (defined($data)) { return $c->{$data} if exists($c->{$data}); } else { return $c; } return; } sub delete_expired { my $self=shift; my $now=Net::DRI::Util::microtime(); my $c=$self->{data}; while(my ($type,$c1)=each(%$c)) { while(my ($key,$c2)=each(%{$c1})) { delete($c->{$type}->{$key}) if ($c2->{_until} > 0 && ($now > $c2->{_until})); } } } sub delete { my $self=shift; $self->{data}={}; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Logging.pm0000644000175000017500000001766111352534376016350 0ustar patrickpatrick## Domain Registry Interface, Logging operations for Net::DRI ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Logging; use strict; use warnings; use base qw/Net::DRI::BaseClass/; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf '%d'.('.%02d' x $#r), @r; }; __PACKAGE__->make_exception_if_not_implemented(qw/name setup_channel output/); ## Taken from Log::Log4Perl our %LEVELS=qw/debug 0 info 1 notice 2 warning 3 error 4 critical 5 alert 6 emergency 7/; #################################################################################################### ## Public API sub new { my $c=shift; my $self=shift || {}; if (! exists $self->{level} || ! defined $self->{level} ) { $self->{level} =3; } if (! exists $self->{xml_indent} || ! defined $self->{xml_indent} ) { $self->{xml_indent} =0; } if (! exists $self->{encoding} || ! defined $self->{encoding} ) { $self->{encoding} ='UTF-8'; } if (! exists $self->{format_header} || ! defined $self->{format_header} ) { $self->{format_header} ='%FULLTIME [%ULEVEL] <%TYPE>'; } if (! exists $self->{format_transport} || ! defined $self->{format_transport} ) { $self->{format_transport}='%TRID %UDIRECTION %MESSAGE'; } bless $self,$c; $self->level($self->{level}); ## convert the level token to a numerical value return $self; } sub level { my ($self,$level)=@_; if (defined $level) { if (exists $LEVELS{$level}) { $level=$LEVELS{$level}; } if ($level!~/^\d+$/ || $level > 7) { $self->output('error','logging','Invalid level value "'.$level.'", switching to default'); $level=3; } $self->{level}=$level; } return $self->{level}; } #################################################################################################### ## Internal API sub string_header { my ($self,$level,$type,$data)=@_; my $f=$self->{format_header}; $f=~s/%FULLTIME/Net::DRI::Util::fulltime()/eg; $f=~s/%ULEVEL/uc($level)/eg; $f=~s/%TYPE/$type/g; return $f; } sub string_data { my ($self,$hdr,$type,$data)=@_; if (! ref $data || ! exists $self->{'format_'.$type}) { return $hdr.q{ }.$data; } my $msg=$data->{message}; my $ct=q{}; my $ref=ref $msg; if ($ref) { if ($ref eq 'Net::DRI::Data::Raw') { $ct=$msg->hint(); } else { if (! $msg->can('as_string')) { Net::DRI::Exception::err_method_not_implemented('as_string in '.ref $msg); } } $msg=$msg->as_string(); } ## If this is deemed to be too brittle, a type() method could be added to Protocol/Message and correctly set to "xml" by Message classes in RRI,EPP,OpenSRS/XCP,IRIS/{XCP,LWZ} if (! length($ct) && substr($msg,0,5) eq '{xml_indent}) { $msg=Net::DRI::Util::xml_indent($msg); } else { $msg=~s/^\s+//mg; $msg=~s/\s+$//mg; $msg=~s/\n/ /g; $msg=~s/> {all}=join q{ },map { $_.q{=}.(defined $data->{$_} ? $data->{$_} : '') } sort { $a cmp $b } keys %{$data}; ## this should be handy during debugging if (exists $data->{direction}) { $data->{udirection}=uc $data->{direction}; $data->{adirection}=$data->{direction} eq 'in'? 'C<=S' : 'C=>S';} my @r; foreach my $l (split /\n/,$msg) { my $f=$hdr.q{ }.$self->{'format_'.$type}; $data->{message}=$l; $f=~s/%([A-Z]+)/$data->{lc $1} || ''/eg; push @r,$f; } return join qq{\n}, @r; } sub tostring { my ($self,$level,$type,$data)=@_; my $hdr=$self->string_header($level,$type); my $r=$self->string_data($hdr,$type,$data); return Net::DRI::Util::encode($self->{encoding},$r); } sub should_log { my ($self,$level)=@_; return ($LEVELS{$level} >= $self->{level})? 1 : 0; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Logging - Logging Operations for Net::DRI =head1 VERSION This documentation refers to Net::DRI::Logging version 1.02 =head1 SYNOPSIS This module is never used directly, only its subclasses are used. See the subclasses documentation: L, L and L. See also L documentation and its C method. =head1 DESCRIPTION This is the superclass of all logging modules (under the L namespace). =head1 EXAMPLES See L documentation. =head1 SUBROUTINES/METHODS This is mostly a pure virtual superclass. All subclasses should have the following methods: =over =item new() a ref hash is passed with some keys ; besides keys specifically related to the logging class used, some keys are (or should be) understood by all clases. They are: =over =item level current level of logging (no messages below this level would be dumped), between: debug info notice warning error critical alert emergency ; default: warning It can be changed anytime later by using the level() method =item xml_indent 0 or 1 depending if you want your XML strings to be dumped as a long line (0) or indented for humans (1) ; default: 0 =item encoding if needed, name of encoding to use to convert data stream ; default: UTF-8 =back =item name() returns the name as string of the logging modules =item setup_channel(SOURCE,TYPE,DATA) prepare for a new channel of data comming from SOURCE (package name), of TYPE ; DATA is a ref hash of additional parameter, such as filenames, etc. =item output(LEVEL,TYPE,DATA1,DATA2,...) add data to channel type TYPE at level LEVEL ('debug', 'info', 'notice', etc.) ; DATA is a ref hash with all data to log or a simple string (the message) ; the logging module should know what to do with it and how to format it (which may depend on the TYPE attribute, which itself is tied to the SOURCE attribute of C). =back =head1 DIAGNOSTICS None. =head1 CONFIGURATION AND ENVIRONMENT See the C method. =head1 DEPENDENCIES This module has to be used inside the Net::DRI framework and needs the following components: =over =item L =item L =item L =back =head1 INCOMPATIBILITIES None. =head1 BUGS AND LIMITATIONS No known bugs. Please report problems to author (see below) or use CPAN RT system. Patches are welcome. The interface could be later changed to suit Log::Log4Perl or other Perl standard logging modules, if needed. Other subclasses should be created to cater for other logging destinations (such as a RDBMS). L expects these logging modules to be non-blocking and returning immediately. This logging framework is currently only used by L, it should get applied to other transports and other internal parts of L. When LocalStorage do appear inside Net::DRI, logging should probably use it (TODO). =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 LICENSE AND COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Transport/0002755000175000017500000000000011352534417016403 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Transport/SMTP.pm0000644000175000017500000000705711352534376017537 0ustar patrickpatrick## Domain Registry Interface, SMTP Transport ## ## Copyright (c) 2006,2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Transport::SMTP; use strict; use warnings; use base qw/Net::DRI::Transport/; ## we are a subclass use Net::SMTP; use Email::Valid; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::SMTP - SMTP transport for Net::DRI =head1 DESCRIPTION The following options are available at creation: =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$rp)=@_; my %opts=%$rp; my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance $self->has_state(0); ## We could be stateful by keeping a live connection to the SMTP host. But it would be useful only for high volumes $self->is_sync(0); $self->name('smtp'); $self->version('0.1'); $self->current_state(0); ## Now deal with specifics for this transport my %t; $t{smtphost}=exists($opts{smtphost})? $opts{smtphost} : 'localhost'; $t{cc}=$opts{cc} if (exists($opts{cc}) && Email::Valid->rfc822($opts{cc})); ## Will be added as Cc: to all messages $t{bcc}=$opts{bcc} if (exists($opts{bcc}) && Email::Valid->rfc822($opts{bcc})); ## Ditto as Bcc: $self->{transport}=\%t; ## Bless again, but now in this package bless($self,$class); return $self; } #################################################################################################### sub end { } sub send { my ($self,$ctx,$tosend)=@_; $self->SUPER::send($ctx,$tosend,\&_send,undef); } sub _send { my ($self,$count,$tosend)=@_; my $rt=$self->{transport}; my $mime=$tosend->as_mime(); my $head=$mime->head(); $head->add('Cc',$rt->{cc}) if exists($rt->{cc}); $head->add('Bcc',$rt->{bcc}) if exists($rt->{bcc}); my %rcpts=map { $_ => 1 } map { $head->get_all($_) } ('To','Cc','Bcc'); $head->delete('Bcc'); my $smtp=Net::SMTP->new($rt->{smtphost}); my $ok=$smtp->mail($head->get('From'),Bits=>8) && $smtp->to(keys(%rcpts)) && $smtp->data($mime->stringify()) && $smtp->quit(); Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send message') unless $ok; return 1; } sub receive { my ($self,$ctx,$count)=@_; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport/HTTP.pm0000644000175000017500000002654111352534376017532 0ustar patrickpatrick## Domain Registry Interface, HTTP/HTTPS Transport ## ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Transport::HTTP; use strict; use warnings; use base qw(Net::DRI::Transport); use Net::DRI::Exception; use Net::DRI::Util; use LWP::UserAgent; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::HTTP - HTTP/HTTPS Transport for Net::DRI =head1 DESCRIPTION This module implements an HTTP/HTTPS transport for establishing connections in Net::DRI =head1 METHODS At creation (see Net::DRI C) you pass a reference to an hash, with the following available keys: =head2 timeout time to wait (in seconds) for server reply =head2 https_debug https_version https_cert_file https_key_file https_ca_file https_ca_dir all key materials for https access, if needed =head2 remote_url URL to access =head2 client_login client_password protocol login & password =head2 client_newpassword (optional) new password if you want to change password on login for registries handling that at connection =head2 protocol_connection Net::DRI class handling protocol connection details. Specifying it should not be needed, as the registry driver should have correct default values. =head2 protocol_data (optional) opaque data given to protocol_connection class. For EPP, a key login_service_filter may exist, whose value is a code ref. It will be given an array of services, and should give back a similar array; it can be used to filter out some services from those given by the registry. =head2 verify_response (optional) a callback (code ref) executed after each exchange with the registry, being called with the following parameters: the transport object, the phase (1 for greeting+login, 2 for all normal operations, 3 for logout), the count (if we retried multiple times to send the same message), the message sent (HTTP::Request object) and the response received (HTTP::Response object). This can be used to verify/diagnose SSL details, see example in file t/704opensrs_xcp_live.t =head2 local_host (optional) the local address (hostname or IP) you want to use to connect (if you are multihomed) =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### ## These ENV keys will be set each time just before doing HTTP stuff, making sure to remove pre-existing ones beforehand ## This should enable us to deal with multiple endpoints with various parameters at the same time (BUT this should be really tested) our @HTTPS_ENV=qw/HTTPS_DEBUG HTTPS_VERSION HTTPS_CERT_FILE HTTPS_KEY_FILE HTTPS_CA_FILE HTTPS_CA_DIR/; sub new { my ($class,$ctx,$rp)=@_; my %opts=%$rp; my $ndr=$ctx->{registry}; my $pname=$ctx->{profile}; my $po=$ctx->{protocol}; my %t=(message_factory => $po->factories()->{message}); Net::DRI::Exception::usererr_insufficient_parameters('protocol_connection') unless (exists($opts{protocol_connection}) && $opts{protocol_connection}); $t{pc}=$opts{protocol_connection}; $t{pc}->require() or Net::DRI::Exception::err_failed_load_module('transport/http',$t{pc},$@); if ($t{pc}->can('transport_default')) { %opts=($t{pc}->transport_default('http'),%opts); } my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance $self->has_state(1); ## some registries need login (like .PL) some not (like .ES) ; see end of method & call to open_connection() $self->is_sync(1); $self->name('http'); $self->version($VERSION); foreach my $k (qw/client_login client_password client_newpassword protocol_data/) { $t{$k}=$opts{$k} if exists($opts{$k}); } my @need=qw/read_data write_message/; Net::DRI::Exception::usererr_invalid_parameters('protocol_connection class must have: '.join(' ',@need)) if (grep { ! $t{pc}->can($_) } @need); $t{protocol_data}=$opts{protocol_data} if (exists($opts{protocol_data}) && $opts{protocol_data}); Net::DRI::Exception::usererr_insufficient_parameters('remote_url must be defined') unless (exists $opts{'remote_url'} && defined $opts{'remote_url'}); Net::DRI::Exception::usererr_invalid_parameters('remote_url must be an uri starting with http:// or https:// with a proper path') unless $opts{remote_url}=~m!^https?://\S+/\S*$!; $t{remote_url}=$opts{remote_url}; $t{remote_uri}=$t{remote_url}; ## only used for error messages my $ua=LWP::UserAgent->new(); $ua->agent(sprintf('Net::DRI/%s Net::DRI::Transport::HTTP/%s ',$Net::DRI::VERSION,$VERSION)); ## the final space triggers LWP::UserAgent to add its own string $ua->cookie_jar({}); ## Cookies needed by some registries, like .PL (how strange !) ## Now some security settings $ua->max_redirect(0); $ua->parse_head(0); $ua->protocols_allowed(['http','https']); $ua->timeout($self->timeout()) if $self->timeout(); ## problem with our own alarm ? $t{ua}=$ua; $t{local_host}=$opts{local_host} if (exists($opts{local_host}) && $opts{local_host}); $t{setenv}=0; foreach my $k (map { lc } @HTTPS_ENV) ## Backport this stuff to other Transport modules in order to handle multiple differents sets of env values ? { next unless (exists($opts{$k}) && defined($opts{$k})); $t{setenv}=1; $t{$k}=$opts{$k}; } $t{verify_response}=$opts{verify_response} if (exists($opts{verify_response}) && defined($opts{verify_response}) && (ref($opts{verify_response}) eq 'CODE')); $self->{transport}=\%t; $t{pc}->init($self) if $t{pc}->can('init'); $self->open_connection($ctx); ## noop for registries without login, will properly setup has_state() return $self; } sub send_login { my ($self,$ctx)=@_; my $t=$self->transport_data(); my $pc=$t->{pc}; my ($cltrid,$dr); ## Get registry greeting, if available if ($pc->can('greeting') && $pc->can('parse_greeting')) { $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); ## not used for greeting ( has no clTRID), but used in logging my $greeting=$pc->greeting($t->{message_factory}); $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'out',message=>$greeting}); Net::DRI::Exception->die(0,'transport/http',4,'Unable to send greeting message to '.$t->{remote_uri}) unless $self->_http_send(1,$greeting,1); $dr=$self->_http_receive(1); $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr}); my $rc1=$pc->parse_greeting($dr); ## gives back a Net::DRI::Protocol::ResultStatus die($rc1) unless $rc1->is_success(); } my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid,$dr,$t->{client_newpassword},$t->{protocol_data}); $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'out',message=>$login}); Net::DRI::Exception->die(0,'transport/http',4,'Unable to send login message to '.$t->{remote_uri}) unless $self->_http_send(1,$login,1); $dr=$self->_http_receive(1); $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr}); my $rc2=$pc->parse_login($dr); ## gives back a Net::DRI::Protocol::ResultStatus die($rc2) unless $rc2->is_success(); } sub open_connection { my ($self,$ctx)=@_; my $t=$self->transport_data(); my $pc=$t->{pc}; $self->has_state(0); if ($pc->can('login') && $pc->can('parse_login')) { $self->send_login($ctx); $self->has_state(1); $self->current_state(1); } $self->time_open(time()); $self->time_used(time()); $self->transport_data()->{exchanges_done}=0; } sub send_logout { my ($self)=@_; my $t=$self->transport_data(); my $pc=$t->{pc}; return unless ($pc->can('logout') && $pc->can('parse_logout')); my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $logout=$pc->logout($t->{message_factory},$cltrid); $self->log_output('notice','transport',{otype=>'session',oaction=>'logout'},{trid=>$cltrid,phase=>'closing',direction=>'out',message=>$logout}); Net::DRI::Exception->die(0,'transport/http',4,'Unable to send logout message to '.$t->{remote_uri}) unless $self->_http_send(1,$logout,3); my $dr=$self->_http_receive(1); $self->log_output('notice','transport',{otype=>'session',oaction=>'logout'},{trid=>$cltrid,phase=>'closing',direction=>'in',message=>$dr}); my $rc1=$pc->parse_logout($dr); die($rc1) unless $rc1->is_success(); } sub close_connection { my ($self)=@_; $self->send_logout() if ($self->has_state() && $self->current_state()); $self->transport_data()->{ua}->cookie_jar({}); $self->current_state(0); } sub end { my ($self)=@_; if ($self->current_state()) { eval { local $SIG{ALRM}=sub { die 'timeout' }; alarm(10); $self->close_connection(); }; alarm(0); ## since close_connection may die, this must be outside of eval to be executed in all cases } } sub send { my ($self,$ctx,$tosend)=@_; $self->SUPER::send($ctx,$tosend,\&_http_send,sub {}); } sub _http_send { my ($self,$count,$tosend,$phase)=@_; $phase=2 unless defined($phase); ## Phase 2 = normal operations (1=greeting+login, 3=logout) my $t=$self->transport_data(); ## Having two lines put the warnings away. This module is loaded by LWP::UserAgent anyway. @LWP::Protocol::http::EXTRA_SOCK_OPTS=(); @LWP::Protocol::http::EXTRA_SOCK_OPTS=( LocalAddr => $t->{local_host} ) if exists($t->{local_host}); if ($t->{setenv}) { foreach my $k (map { lc } @HTTPS_ENV) { delete($ENV{uc($k)}); next unless exists($t->{$k}); $ENV{uc($k)}=$t->{$k}; } } ## Content-Length is automatically computed and added during the request() call, no need to do it before my $req=$t->{pc}->write_message($self,$tosend); ## gives back an HTTP::Request object Net::DRI::Util::check_isa($req,'HTTP::Request'); my $ans=$t->{ua}->request($req); $t->{verify_response}->($self,$phase,$count,$req,$ans) if exists($t->{verify_response}); $t->{last_reply}=$ans; return 1; ## very important } sub receive { my ($self,$ctx,$count)=@_; return $self->SUPER::receive($ctx,\&_http_receive); } sub _http_receive { my ($self,$count)=@_; my $t=$self->transport_data(); ## Convert answer in a Net::DRI::Data::Raw object my $dr=$t->{pc}->read_data($self,$t->{last_reply}); Net::DRI::Util::check_isa($dr,'Net::DRI::Data::Raw'); $t->{last_reply}=undef; $t->{exchanges_done}++; return $dr; } ##################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport/Socket.pm0000644000175000017500000003751711352534376020210 0ustar patrickpatrick## Domain Registry Interface, TCP/SSL Socket Transport ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Transport::Socket; use base qw(Net::DRI::Transport); use strict; use warnings; use IO::Socket::INET; ## At least this version is needed, to have getline() use IO::Socket::SSL 0.90; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Data::Raw; our $VERSION=do { my @r=(q$Revision: 1.32 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::Socket - TCP/TLS Socket connection for Net::DRI =head1 DESCRIPTION This module implements a socket (tcp or tls) for establishing connections in Net::DRI =head1 METHODS At creation (see Net::DRI C) you pass a reference to an hash, with the following available keys: =head2 socktype ssl, tcp or udp =head2 ssl_key_file ssl_cert_file ssl_ca_file ssl_ca_path ssl_cipher_list ssl_version ssl_passwd_cb if C is 'ssl', all key materials, see IO::Socket::SSL documentation for corresponding options =head2 ssl_verify see IO::Socket::SSL documentation about verify_mode (by default 0x00 here) =head2 ssl_verify_callback see IO::Socket::SSL documentation about verify_callback, it gets here as first parameter the transport object then all parameter given by IO::Socket::SSL; it is explicitely verified that the subroutine returns a true value, and if not the connection is aborted. =head2 remote_host remote_port hostname (or IP address) & port number of endpoint =head2 client_login client_password protocol login & password =head2 client_newpassword (optional) new password if you want to change password on login for registries handling that at connection =head2 protocol_connection Net::DRI class handling protocol connection details. (Ex: C or C) =head2 protocol_data (optional) opaque data given to protocol_connection class. For EPP, a key login_service_filter may exist, whose value is a code ref. It will be given an array of services, and should give back a similar array; it can be used to filter out some services from those given by the registry. =head2 close_after number of protocol commands to send to server (we will automatically close and re-open connection if needed) =head2 local_host (optional) the local address (hostname or IP) you want to use to connect =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$rp)=@_; my %opts=%$rp; my $po=$ctx->{protocol}; my %t=(message_factory => $po->factories()->{message}); Net::DRI::Exception::usererr_insufficient_parameters('protocol_connection') unless (exists($opts{protocol_connection}) && $opts{protocol_connection}); $t{pc}=$opts{protocol_connection}; $t{pc}->require or Net::DRI::Exception::err_failed_load_module('transport/socket',$t{pc},$@); if ($t{pc}->can('transport_default')) { %opts=($t{pc}->transport_default('socket_inet'),%opts); } my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance $self->has_state(exists $opts{has_state}? $opts{has_state} : 1); $self->is_sync(1); $self->name('socket_inet'); $self->version('0.3'); delete($ctx->{protocol}); delete($ctx->{registry}); delete($ctx->{profile}); Net::DRI::Exception::usererr_insufficient_parameters('socktype must be defined') unless (exists($opts{socktype})); Net::DRI::Exception::usererr_invalid_parameters('socktype must be ssl, tcp or udp') unless ($opts{socktype}=~m/^(ssl|tcp|udp)$/); $t{socktype}=$opts{socktype}; $t{client_login}=$opts{client_login}; $t{client_password}=$opts{client_password}; $t{client_newpassword}=$opts{client_newpassword} if (exists($opts{client_newpassword}) && $opts{client_newpassword}); $t{protocol_data}=$opts{protocol_data} if (exists($opts{protocol_data}) && $opts{protocol_data}); my @need=qw/read_data write_message/; Net::DRI::Exception::usererr_invalid_parameters('protocol_connection class ('.$t{pc}.') must have: '.join(' ',@need)) if (grep { ! $t{pc}->can($_) } @need); if (exists($opts{find_remote_server}) && defined($opts{find_remote_server}) && $t{pc}->can('find_remote_server')) { ($opts{remote_host},$opts{remote_port})=$t{pc}->find_remote_server($self,$opts{find_remote_server}); $self->log_output('notice','transport',$ctx,{phase=>'opening',message=>'Found the following remote_host:remote_port = '.$opts{remote_host}.':'.$opts{remote_port}}); } foreach my $p ('remote_host','remote_port','protocol_version') { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($opts{$p}) && $opts{$p}); $t{$p}=$opts{$p}; } Net::DRI::Exception::usererr_invalid_parameters('close_after must be an integer') if ($opts{close_after} && !Net::DRI::Util::isint($opts{close_after})); $t{close_after}=$opts{close_after} || 0; if ($t{socktype} eq 'ssl') { $IO::Socket::SSL::DEBUG=$opts{ssl_debug} if exists($opts{ssl_debug}); my %s=(SSL_use_cert => 0); $s{SSL_verify_mode}=(exists($opts{ssl_verify}))? $opts{ssl_verify} : 0x00; ## by default, no authentication whatsoever $s{SSL_verify_callback}=sub { my $r=$opts{ssl_verify_callback}->($self,@_); Net::DRI::Exception->die(1,'transport/socket',6,'SSL certificate user verification failed, aborting connection') unless $r; 1; } if (exists $opts{ssl_verify_callback} && defined $opts{ssl_verify_callback}); foreach my $s (qw/key_file cert_file ca_file ca_path version passwd_cb/) { next unless exists($opts{'ssl_'.$s}); $s{'SSL_'.$s}=$opts{'ssl_'.$s}; } $s{SSL_use_cert}=1 if exists($s{SSL_cert_file}); ## Library default: ALL:!ADH:RC4+RSA:+HIGH:+MEDIUM:+LOW:+SSLv2:+EXP $s{SSL_cipher_list}=(exists($opts{ssl_cipher_list}))? $opts{ssl_cipher_list} : 'ALL:!ADH:!LOW:+HIGH:+MEDIUM:+SSLv3'; $t{ssl_context}=\%s; } $t{local_host}=$opts{local_host} if (exists($opts{local_host}) && $opts{local_host}); $t{remote_uri}=sprintf('%s://%s:%d',$t{socktype},$t{remote_host},$t{remote_port}); ## handy shortcust only used for error messages $self->{transport}=\%t; bless($self,$class); ## rebless in my class if ($self->defer()) ## we will open, but later { $self->current_state(0); } else ## we will open NOW { $self->open_connection($ctx); $self->current_state(1); } return $self; } sub sock { my ($self,$v)=@_; $self->transport_data()->{sock}=$v if defined($v); return $self->transport_data()->{sock}; } ## TODO (for IRIS DCHK1 + NAPTR/SRV) ## Wrap in an eval to handle timeout (see if outer eval already for that ?) ## Handle remote_host/port being ref array of ordered strings to try (in which case defer should be 0 probably as the list of things to try have been determined now, not later) ## Or specify a callback to call when doing socket open to find the correct host+ports to use at that time sub open_socket { my ($self,$ctx)=@_; my $t=$self->transport_data(); my $type=$t->{socktype}; my $sock; my %n=( PeerAddr => $t->{remote_host}, PeerPort => $t->{remote_port}, Proto => $t->{socktype} eq 'udp'? 'udp' : 'tcp', Blocking => 1, MultiHomed => 1, ); $n{LocalAddr}=$t->{local_host} if exists($t->{local_host}); if ($type eq 'ssl') { $sock=IO::Socket::SSL->new(%{$t->{ssl_context}}, %n, ); } if ($type eq 'tcp' || $type eq 'udp') { $sock=IO::Socket::INET->new(%n); } Net::DRI::Exception->die(1,'transport/socket',6,'Unable to setup the socket for '.$t->{remote_uri}.' with error: "'.$!.($type eq 'ssl'? '" and SSL error: "'.IO::Socket::SSL::errstr().'"' : '"')) unless defined $sock; $sock->autoflush(1); $self->sock($sock); $self->log_output('notice','transport',$ctx,{phase=>'opening',message=>'Successfully opened socket to '.$t->{remote_uri}}); return; } sub send_login { my ($self,$ctx)=@_; my $t=$self->transport_data(); my $sock=$self->sock(); my $pc=$t->{pc}; my $dr; my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); ## Get server greeting, if any if ($pc->can('parse_greeting')) { $dr=$pc->read_data($self,$sock); $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr}); my $rc1=$pc->parse_greeting($dr); ## gives back a Net::DRI::Protocol::ResultStatus die($rc1) unless $rc1->is_success(); } return unless ($pc->can('login') && $pc->can('parse_login')); foreach my $p (qw/client_login client_password/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p}); } $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid,$dr,$t->{client_newpassword},$t->{protocol_data}); $self->log_output('notice','transport',$ctx,{otype=>'session',oaction=>'login',trid=>$cltrid,phase=>'opening',direction=>'out',message=>$login}); Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send login message to '.$t->{remote_uri}) unless ($sock->print($pc->write_message($self,$login))); ## Verify login successful $dr=$pc->read_data($self,$sock); $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr}); my $rc2=$pc->parse_login($dr); ## gives back a Net::DRI::Protocol::ResultStatus die($rc2) unless $rc2->is_success(); } sub send_logout { my ($self)=@_; my $t=$self->transport_data(); my $sock=$self->sock(); my $pc=$t->{pc}; return unless ($pc->can('logout') && $pc->can('parse_logout')); my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $logout=$pc->logout($t->{message_factory},$cltrid); $self->log_output('notice','transport',{otype=>'session',oaction=>'logout'},{trid=>$cltrid,phase=>'closing',direction=>'out',message=>$logout}); Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send logout message to '.$t->{remote_uri}) unless ($sock->print($pc->write_message($self,$logout))); my $dr=$pc->read_data($self,$sock); ## We expect this to throw an exception, since the server will probably cut the connection $self->log_output('notice','transport',{otype=>'session',oaction=>'logout'},{trid=>$cltrid,phase=>'closing',direction=>'in',message=>$dr}); my $rc1=$pc->parse_logout($dr); die($rc1) unless $rc1->is_success(); } sub open_connection { my ($self,$ctx)=@_; $self->open_socket($ctx); $self->send_login($ctx); $self->current_state(1); $self->time_open(time()); $self->time_used(time()); $self->transport_data()->{exchanges_done}=0; } sub ping { my ($self,$autorecon)=@_; $autorecon=0 unless defined $autorecon; my $t=$self->transport_data(); my $sock=$self->sock(); my $pc=$t->{pc}; Net::DRI::Exception::err_method_not_implemented() unless ($pc->can('keepalive') && $pc->can('parse_keepalive')); my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); eval { local $SIG{ALRM}=sub { die 'timeout' }; alarm(10); my $noop=$pc->keepalive($t->{message_factory},$cltrid); $self->log_output('notice','transport',{otype=>'session',oaction=>'keepalive'},{trid=>$cltrid,phase=>'keepalive',direction=>'out',message=>$noop}); Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send ping message to '.$t->{remote_uri}) unless ($sock->print($pc->write_message($self,$noop))); $self->time_used(time()); $t->{exchanges_done}++; my $dr=$pc->read_data($self,$sock); $self->log_output('notice','transport',{otype=>'session',oaction=>'keepalive'},{trid=>$cltrid,phase=>'keepalive',direction=>'in',message=>$dr}); my $rc=$pc->parse_keepalive($dr); die($rc) unless $rc->is_success(); }; alarm(0); if ($@) { $self->current_state(0); $self->open_connection({}) if $autorecon; } else { $self->current_state(1); } return $self->current_state(); } sub close_socket { my ($self)=@_; my $t=$self->transport_data(); $self->sock()->close(); $self->log_output('notice','transport',{},{phase=>'closing',message=>'Successfully closed socket for '.$t->{remote_uri}}); $self->sock(undef); } sub close_connection { my ($self)=@_; $self->send_logout(); $self->close_socket(); $self->current_state(0); } sub end { my ($self)=@_; if ($self->current_state()) { eval { local $SIG{ALRM}=sub { die 'timeout' }; alarm(10); $self->close_connection(); }; alarm(0); ## since close_connection may die, this must be outside of eval to be executed in all cases } } #################################################################################################### sub send { my ($self,$ctx,$tosend,$count)=@_; ## We do a very crude error handling : if first send fails, we reset connection. ## Thus if you put retry=>2 when creating this object, the connection will be re-established and the message resent $self->SUPER::send($ctx,$tosend,\&_print,sub { shift->current_state(0) },$count); } sub _print ## here we are sure open_connection() was called before { my ($self,$count,$tosend,$ctx)=@_; my $pc=$self->transport_data('pc'); my $sock=$self->sock(); my $m=($self->transport_data('socktype') eq 'udp')? 'send' : 'print'; Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send message to '.$self->transport_data('remote_uri').' because of error: '.$!) unless ($sock->$m($pc->write_message($self,$tosend))); return 1; ## very important } sub receive { my ($self,$ctx,$count)=@_; return $self->SUPER::receive($ctx,\&_get,undef,$count); } sub _get { my ($self,$count,$ctx)=@_; my $t=$self->transport_data(); my $sock=$self->sock(); my $pc=$t->{pc}; ## Answer my $dr=$pc->read_data($self,$sock); $t->{exchanges_done}++; if ($t->{exchanges_done}==$t->{close_after} && $self->has_state() && $self->current_state()) { $self->log_output('notice','transport',$ctx,{phase=>'closing',message=>'Due to maximum number of exchanges reached, closing connection to '.$t->{remote_uri}}); $self->close_connection(); } return $dr; } sub try_again { my ($self,$ctx,$po,$err,$count,$istimeout,$step,$rpause,$rtimeout)=@_; if ($step==0) ## sending not already done, hence error during send { $self->current_state(0); return 1; } ## We do a more agressive retry procedure in case of udp (that is IRIS basically) ## See RFC4993 section 4 if ($step==1 && $istimeout==1 && $self->transport_data()->{socktype} eq 'udp') { $self->log_output('debug','transport',$ctx,{phase=>'active',message=>sprintf('In try_again, currently: pause=%f timeout=%f',$$rpause,$$rtimeout)}); $$rtimeout=2*$$rtimeout; $$rpause+=rand(1+int($$rpause/2)); $self->log_output('debug','transport',$ctx,{phase=>'active',message=>sprintf('In try_again, new values: pause=%f timeout=%f',$$rpause,$$rtimeout)}); return 1; ## we will retry } return 0; ## we do not handle other cases, hence no retry and fatal error } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport/Dummy.pm0000644000175000017500000000604411352534376020042 0ustar patrickpatrick## Domain Registry Interface, Dummy transport for tests & debug ## ## Copyright (c) 2005,2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Transport::Dummy; use strict; use warnings; use base qw(Net::DRI::Transport); use Net::DRI::Data::Raw; our $VERSION=do { my @r=(q$Revision: 1.12 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::Dummy - Net::DRI dummy transport for tests & debug =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$rh)=@_; my $self=$class->SUPER::new($ctx,$rh); ## We are now officially a Net::DRI::Transport instance $self->has_state(0); $self->is_sync(1); $self->name('dummy'); $self->version('0.1'); $self->{f_send}=(exists($rh->{f_send}))? $rh->{f_send} : \&_print; $self->{f_recv}=(exists($rh->{f_recv}))? $rh->{f_recv} : \&_got_ok; bless($self,$class); ## rebless in my class return $self; } sub send { my ($self,$ctx,$tosend)=@_; $self->SUPER::send($ctx,$tosend,$self->{f_send},\&handle_error); } sub handle_error { my ($self,$err,$c,$is_timeout,$ok)=@_; die($err->as_string()); } sub _print { my ($self,$count,$tosend)=@_; print STDOUT ">>>>>>>>>>>>>>>>>> (Net::DRI::Transport::Dummy) (count=$count)\n"; print STDOUT $tosend->as_string(); print STDOUT ">>>>>>>>>>>>>>>>>>\n\n"; return 1; ## very important } sub receive { my ($self,$ctx,$count)=@_; return $self->SUPER::receive($ctx,$self->{f_recv}); } sub _got_ok { my ($self,$count)=@_; my $m="200 OK\r\n.\r\n"; print STDOUT "<<<<<<<<<<<<<<<<<< (Net::DRI::Transport::Dummy) (count=$count)\n"; print STDOUT $m; print STDOUT "<<<<<<<<<<<<<<<<<<\n\n"; return Net::DRI::Data::Raw->new_from_string($m); } ###################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport/SOAP.pm0000644000175000017500000001266611352534376017520 0ustar patrickpatrick## Domain Registry Interface, SOAP Transport (HTTP/HTTPS) ## ## Copyright (c) 2005,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Transport::SOAP; use strict; use warnings; use base qw(Net::DRI::Transport); use Net::DRI::Exception; use SOAP::Lite; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::SOAP - SOAP (HTTP/HTTPS) Transport for Net::DRI =head1 DESCRIPTION When calling new_current_profile with this transport, in ref array of parameters for transport, pass an hash ref with the following keys, as needed: =over =item * C is a string giving the url to use (mostly worthless since using services, but needed to setup credentials) =item * C is an array ref with four items in this order: sitename:port,realm,username,password ex: C<< credentials=>['soap-adh.nic.fr:443','Webservices Adherents AFNIC','USERNAME','PASSWORD'] >> =item * C is an hash ref : the key is a string used in Protocol classes, value is an url to the corresponding WSDL file ex: C<< service_wsdl=>{Domain=>'file:./Domain-perl.wsdl'} >> =item * C is a string giving the local path to the CA certificate file, if using https =back =head2 CURRENT LIMITATIONS =over =item * only for SOAP over HTTP/HTTPS =item * only one CA certificate can be used in each given instance of Net::DRI (because it is given through %ENV) =back =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$rp)=@_; my %opts=%$rp; my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance $self->has_state(0); $self->is_sync(1); $self->name('soap'); $self->version($VERSION); my %t; Net::DRI::Exception::usererr_insufficient_parameters('proxy_url must be defined') unless (exists($opts{proxy_url})); Net::DRI::Exception::usererr_invalid_parameters('proxy_url must be http:// or https://') unless ($opts{proxy_url}=~m!^https?://!); Net::DRI::Exception::usererr_insufficient_parameters('service_wsdl') unless (exists($opts{service_wsdl})); Net::DRI::Exception::usererr_invalid_parameters('service_wsdl must be a ref hash') unless (ref($opts{service_wsdl}) eq 'HASH'); ## Name (without .wsdl),ex: Domain => Path to corresponding wsdl file my $service=SOAP::Lite->on_fault(\&soap_fault); my %st; while(my ($k,$v)=each(%{$opts{service_wsdl}})) { my $go=$service->service($v); my $t=$go->transport(); $t->agent(sprintf('Net::DRI/%s Net::DRI::Transport::SOAP/%s',$Net::DRI::VERSION,$VERSION).$t->agent()); if ($self->timeout()) { $t->proxy($opts{proxy_url},timeout => $self->timeout()); } else { $t->proxy($opts{proxy_url}); } # name:port,realm,user,login $t->credentials(@{$opts{credentials}}) if ($opts{credentials} && (ref($opts{credentials}) eq 'ARRAY')); $st{$k}=$go; } $t{service_wsdl}=\%st; if (exists($opts{ssl_ca_file}) && (-s $opts{ssl_ca_file})) { $ENV{HTTPS_CA_FILE}=$opts{ssl_ca_file}; ## How to handle multiple SOAP instances in the same process ?? } $t{soap}=$service; $self->{transport}=\%t; bless($self,$class); return $self; } sub soap_fault { my($soap,$res)=@_; my $msg=ref $res ? $res->faultstring() : $soap->transport()->status(); Net::DRI::Exception->die(1,'transport/soap',7,'SOAP fault: '.$msg); } sub send { my ($self,$ctx,$tosend)=@_; $self->SUPER::send($ctx,$tosend,\&_soap_send,sub {}); } sub _soap_send { my ($self,$count,$tosend)=@_; my $t=$self->{transport}; my $so=$t->{soap}; my $sw=$t->{service_wsdl}; ## a ref hash my $service=$tosend->service(); Net::DRI::Exception::usererr_insufficient_parameters("No wsdl file specified for service $service") unless (exists($sw->{$service})); my $m=$tosend->method(); my $r=$sw->{$service}->$m(@{$tosend->params()}); $t->{last_reply}=$r; return 1; ## very important } sub receive { my ($self,$ctx,$count)=@_; return $self->SUPER::receive($ctx,\&_soap_receive); } sub _soap_receive { my ($self,$count)=@_; my $t=$self->{transport}; my $so=$t->{service}; my $r=$t->{last_reply}; $t->{last_reply}=undef; return $r; ## will we need one day access to $so ? } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport/Defer.pm0000644000175000017500000000757511352534376020006 0ustar patrickpatrick## Domain Registry Interface, Deferred Transport ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Transport::Defer; use strict; use warnings; use base qw(Net::DRI::Transport); use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::Defer - Deferred Transport for Net::DRI =head1 DESCRIPTION This module implements a deferred transport in Net::DRI. For now it just dumps all data to a given filehandle, and reports back to Net::DRI that the message has been sent. This is useful for debugging, and also to validate all parameters of an operation without actually sending anything to the registry ; in such way, it is kind of a "simulate" operation where everything is done (parameters validation, message building, etc...) without touching the registry. =head1 METHODS At creation (see Net::DRI C) you pass a reference to an hash, with the following available keys: =head2 protocol_connection Net::DRI class handling protocol connection details. (Ex: C or C) =head2 dump_fh (optional) a filehandle (ex: \*STDERR or an anonymous filehandle) on something already opened for write ; if not defined, defaults to \*STDERR =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$rp)=@_; my %opts=%$rp; my %t=(); Net::DRI::Exception::usererr_insufficient_parameters('protocol_connection') unless (exists($opts{protocol_connection}) && $opts{protocol_connection}); $t{pc}=$opts{protocol_connection}; $t{pc}->require or Net::DRI::Exception::err_failed_load_module('transport/socket',$t{pc},$@); if ($t{pc}->can('transport_default')) { %opts=($t{pc}->transport_default('defer'),%opts); } my $self=$class->SUPER::new($ctx,\%opts); $self->name('defer'); $self->version('0.1'); $self->has_state(0); $self->is_sync(0); $self->defer(0); $self->current_state(0); $self->time_open(time()); $self->time_used(time()); $t{exchanges_done}=0; $t{dump_fh}=(exists($opts{dump_fh}))? $opts{dump_fh} : \*STDERR; my @need=qw/read_data write_message/; Net::DRI::Exception::usererr_invalid_parameters('protocol_connection class ('.$t{pc}.') must have: '.join(' ',@need)) if (grep { ! $t{pc}->can($_) } @need); $self->{transport}=\%t; return $self; } sub ping { return 1; } sub send { my ($self,$ctx,$tosend)=@_; my $t=$self->transport_data(); my $pc=$t->{pc}; print { $t->{dump_fh} } "\n",$pc->write_message($self,$tosend),"\n"; return 1; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport/HTTP/0002755000175000017500000000000011352534417017162 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Transport/HTTP/SOAPWSDL.pm0000644000175000017500000002063311352534376020762 0ustar patrickpatrick## Domain Registry Interface, SOAP+WSDL Transport ## ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Transport::HTTP::SOAPWSDL; use strict; use warnings; use base qw(Net::DRI::Transport); use Net::DRI::Exception; use Net::DRI::Data::Raw; use Net::DRI::Util; use SOAP::WSDL; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::HTTP::SOAPWSDL - SOAP+WSDL Transport for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$rp)=@_; my %opts=%$rp; my $po=$ctx->{protocol}; my %t=(message_factory => $po->factories()->{message}); if (exists($opts{protocol_connection}) && $opts{protocol_connection}) { $t{protocol_connection}=$opts{protocol_connection}; $t{protocol_connection}->require or Net::DRI::Exception::err_failed_load_module('transport/socket',$t{protocol_connection},$@); if ($t{protocol_connection}->can('transport_default')) { %opts=($t{protocol_connection}->transport_default('soapwsdl'),%opts); } } my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance $self->is_sync(1); $self->name('soapwsdl'); $self->version($VERSION); $t{has_login}=(exists($opts{has_login}) && defined($opts{has_login}))? $opts{has_login} : 0; $t{has_logout}=(exists($opts{has_logout}) && defined($opts{has_logout}))? $opts{has_logout} : 0; $self->has_state($t{has_login}); if ($t{has_login}) { foreach my $p (qw/client_login client_password/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p})); $t{$p}=$opts{$p}; } $t{session_data}={}; } foreach my $p (qw/protocol_connection wsdl_uri proxy_uri servicename portname/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p})); $t{$p}=$opts{$p}; } Net::DRI::Exception::usererr_invalid_parameters('proxy_uri must be http:// or https://') unless ($t{proxy_uri}=~m!^https?://!); my $pc=$t{protocol_connection}; if ($t{has_login}) { foreach my $m (qw/login parse_login extract_session/) { Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_login=1') unless ($pc->can($m)); } } if ($t{has_logout}) { foreach my $m (qw/logout parse_logout/) { Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_logout=1') unless ($pc->can($m)); } } $self->{transport}=\%t; bless($self,$class); if ($self->has_state()) { if ($self->defer()) ## we will open, but later { $self->current_state(0); } else ## we will open NOW { $self->open_connection($ctx); } } else { $self->init(); $self->time_open(time()); } return $self; } sub soap { my ($self,$v)=@_; $self->{transport}->{soap}=$v if @_==2; return $self->{transport}->{soap}; } sub session_data { my ($self,$v)=@_; $self->{transport}->{session_data}=$v if @_==2; return $self->{transport}->{session_data}; } sub init { my ($self)=@_; return if defined($self->soap()); my $soap=SOAP::WSDL->new(); $soap->wsdl($self->{transport}->{wsdl_uri}); $soap->proxy($self->{transport}->{proxy_uri}); $soap->wsdlinit(); $soap->servicename($self->{transport}->{servicename}); $soap->portname($self->{transport}->{portname}); $soap->get_client()->get_transport()->agent(sprintf('Net::DRI/%s Net::DRI::Transport::HTTP::SOAPWSDL/%s ',$Net::DRI::VERSION,$VERSION).$soap->get_client()->get_transport()->agent()); $self->soap($soap); } sub send_login { my ($self,$ctx)=@_; my $t=$self->{transport}; return unless $t->{has_login}; foreach my $p (qw/client_login client_password/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p}); } my $pc=$t->{protocol_connection}; my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid); my $res=$self->_send_receive({otype=>'session',oaction=>'login',trid=>$cltrid,phase=>'opening'},$login); my $msg=$t->{message_factory}->(); $msg->parse(Net::DRI::Data::Raw->new(1,[$res->result()])); my $rc=$pc->parse_login($msg); die($rc) unless $rc->is_success(); $self->session_data($pc->extract_session($msg)); } sub send_logout { my ($self)=@_; my $t=$self->{transport}; return unless $t->{has_logout}; my $pc=$t->{protocol_connection}; my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $logout=$pc->logout($t->{message_factory},$cltrid,$t->{session_data}); my $res=$self->_send_receive({otype=>'session',oaction=>'logout',trid=>$cltrid,phase=>'closing'},$logout); my $msg=$t->{message_factory}->(); $msg->parse(Net::DRI::Data::Raw->new(1,[$res->result()])); my $rc=$pc->parse_logout($msg); die($rc) unless $rc->is_success(); $self->session_data({}); } sub _send_receive { my ($self,$ctx,$msg)=@_; my $soap=$self->soap(); my $res=$soap->call($msg->method(),%{$msg->params()}); if (my $httpres=$soap->get_client()->get_transport()->http_response()) { $self->log_output('notice','transport',$ctx,{direction=>'out',message=>$httpres->request()}); $self->log_output('notice','transport',$ctx,{direction=>'in', message=>$httpres}); } else { $soap->no_dispatch(1); $self->log_output('error','transport',$ctx,{direction=>'out',message=>'No response for message '.$soap->call($msg->method(), %{$msg->params()})}); $soap->no_dispatch(0); } return $res if $res; ## SOAP::WSDL::Client returns a fault object on errors, even on transport layer errors. Net::DRI::Exception->die(1,'transport/soapwsdl',4,'Unable to send message due to SOAP fault: '.$res->faultcode().' '.$res->faultstring()); } sub open_connection { my ($self,$ctx)=@_; $self->init(); $self->send_login($ctx); $self->current_state(1); $self->time_open(time()); $self->time_used(time()); } sub close_connection { my ($self)=@_; $self->send_logout(); $self->soap(undef); $self->current_state(0); } sub end { my ($self)=@_; if ($self->has_state() && $self->current_state()) { eval { local $SIG{ALRM}=sub { die 'timeout' }; alarm(10); $self->close_connection(); }; alarm(0); ## since close_connection may die, this must be outside of eval to be executed in all cases } } #################################################################################################### sub send { my ($self,$ctx,$tosend)=@_; $self->SUPER::send($ctx,$tosend,\&_soap_send,sub {}); } sub _soap_send { my ($self,$count,$tosend,$ctx)=@_; my $t=$self->{transport}; $tosend->add_session($self->session_data()); my $res=$self->_send_receive($ctx,$tosend); $t->{last_reply}=$res; return 1; ## very important } sub receive { my ($self,$ctx,$count)=@_; return $self->SUPER::receive($ctx,\&_soap_receive); } sub _soap_receive { my ($self,$count)=@_; my $t=$self->{transport}; my $r=$t->{last_reply}; $t->{last_reply}=undef; return Net::DRI::Data::Raw->new(6,[$r->result()]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport/HTTP/SOAPLite.pm0000644000175000017500000002125611352534376021110 0ustar patrickpatrick## Domain Registry Interface, SOAP Transport ## ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Transport::HTTP::SOAPLite; use strict; use warnings; use base qw(Net::DRI::Transport); use Net::DRI::Exception; use Net::DRI::Data::Raw; use Net::DRI::Util; use SOAP::Lite; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::HTTP::SOAPLite - SOAP Transport for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$rp)=@_; my %opts=%$rp; my $po=$ctx->{protocol}; my %t=(message_factory => $po->factories()->{message}); if (exists($opts{protocol_connection}) && $opts{protocol_connection}) { $t{protocol_connection}=$opts{protocol_connection}; $t{protocol_connection}->require or Net::DRI::Exception::err_failed_load_module('transport/socket',$t{protocol_connection},$@); if ($t{protocol_connection}->can('transport_default')) { %opts=($t{protocol_connection}->transport_default('soaplite'),%opts); } } my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance $self->is_sync(1); $self->name('soaplite'); $self->version($VERSION); $t{has_login}=(exists($opts{has_login}) && defined($opts{has_login}))? $opts{has_login} : 0; $t{has_logout}=(exists($opts{has_logout}) && defined($opts{has_logout}))? $opts{has_logout} : 0; $self->has_state($t{has_login}); foreach my $p (qw/client_login client_password/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p})); $t{$p}=$opts{$p}; } $t{session_data}=$t{has_login}? {} : { id => $t{client_login}, pass => $t{client_password} }; foreach my $p (qw/uri proxy_uri/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p})); $t{$p}=$opts{$p}; } Net::DRI::Exception::usererr_invalid_parameters('proxy_uri must be http:// or https://') unless ($t{proxy_uri}=~m!^https?://!); my $pc=$opts{protocol_connection}; if ($t{has_login} || $t{has_logout}) { Net::DRI::Exception::usererr_insufficient_parameters('protocol_connection must be provided') unless (defined($pc)); } if ($t{has_login}) { foreach my $m (qw/login parse_login extract_session/) { Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_login=1') unless ($pc->can($m)); } } if ($t{has_logout}) { foreach my $m (qw/logout parse_logout/) { Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_logout=1') unless ($pc->can($m)); } } $self->{transport}=\%t; bless($self,$class); if ($self->has_state()) { if ($self->defer()) ## we will open, but later { $self->current_state(0); } else ## we will open NOW { $self->open_connection($ctx); } } else { $self->init(); $self->time_open(time()); } return $self; } sub soap { my ($self,$v)=@_; $self->{transport}->{soap}=$v if @_==2; return $self->{transport}->{soap}; } sub session_data { my ($self,$v)=@_; $self->{transport}->{session_data}=$v if @_==2; return $self->{transport}->{session_data}; } sub init { my ($self)=@_; return if defined($self->soap()); my $soap=SOAP::Lite->new()->uri($self->{transport}->{uri})->proxy($self->{transport}->{proxy_uri}); $soap->transport()->agent(sprintf('Net::DRI/%s Net::DRI::Transport::HTTP::SOAPLite/%s ',$Net::DRI::VERSION,$VERSION).$soap->transport()->agent()); $self->soap($soap); } sub send_login { my ($self,$ctx)=@_; my $t=$self->{transport}; return unless $t->{has_login}; foreach my $p (qw/client_login client_password/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p}); } my $pc=$t->{protocol_connection}; my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid); my $res=$self->_send_receive({otype=>'session',oaction=>'login',trid=>$cltrid,phase=>'opening'},$login); my $msg=$t->{message_factory}->(); $msg->parse(Net::DRI::Data::Raw->new(1,[$res->result()])); my $rc=$pc->parse_login($msg); die($rc) unless $rc->is_success(); $self->session_data($pc->extract_session($msg)); } sub send_logout { my ($self)=@_; my $t=$self->{transport}; return unless $t->{has_logout}; my $pc=$t->{protocol_connection}; my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $logout=$pc->logout($t->{message_factory},$cltrid,$t->{session_data}); my $res=$self->_send_receive({otype=>'session',oaction=>'logout',trid=>$cltrid,phase=>'closing'},$logout); my $msg=$t->{message_factory}->(); $msg->parse(Net::DRI::Data::Raw->new(1,[$res->result()])); my $rc=$pc->parse_logout($msg); die($rc) unless $rc->is_success(); $self->session_data({}); } sub _send_receive { my ($self,$ctx,$msg)=@_; my $soap=$self->soap(); my $err; my $res=$soap->on_fault(sub { (undef,$err)=@_; return; })->call($msg->method(),@{$msg->params()}); if (my $httpres=$soap->transport()->http_response()) { $self->log_output('notice','transport',$ctx,{direction=>'out',message=>$httpres->request()}); $self->log_output('notice','transport',$ctx,{direction=>'in', message=>$httpres}); } else { $self->log_output('error','transport',$ctx,{direction=>'out',message=>'No response for message '.$soap->serializer()->envelope(method => $msg->method(), @{$msg->params()})}); } return $res if defined $res && ref $res && ! $res->fault() && ! defined $err; Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP fault: '.$err->faultcode().' '.$err->faultstring()) if defined $err && ref $err; Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP transport error: '.$soap->transport()->status()) unless $soap->transport()->is_success(); Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP deserialization error: '.$err); } sub open_connection { my ($self,$ctx)=@_; $self->init(); $self->send_login($ctx); $self->current_state(1); $self->time_open(time()); $self->time_used(time()); } sub close_connection { my ($self)=@_; $self->send_logout(); $self->soap(undef); $self->current_state(0); } sub end { my ($self)=@_; if ($self->has_state() && $self->current_state()) { eval { local $SIG{ALRM}=sub { die 'timeout' }; alarm(10); $self->close_connection(); }; alarm(0); ## since close_connection may die, this must be outside of eval to be executed in all cases } } #################################################################################################### sub send { my ($self,$ctx,$tosend)=@_; $self->SUPER::send($ctx,$tosend,\&_soap_send,sub {}); } sub _soap_send { my ($self,$count,$tosend,$ctx)=@_; my $t=$self->{transport}; $tosend->add_session($self->session_data()); my $res=$self->_send_receive($ctx,$tosend); $t->{last_reply}=$res; return 1; ## very important } sub receive { my ($self,$ctx,$count)=@_; return $self->SUPER::receive($ctx,\&_soap_receive); } sub _soap_receive { my ($self,$count)=@_; my $t=$self->{transport}; my $r=$t->{last_reply}; $t->{last_reply}=undef; return Net::DRI::Data::Raw->new(6,[$r->result()]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport/HTTP/XMLRPCLite.pm0000644000175000017500000002075211352534376021353 0ustar patrickpatrick## Domain Registry Interface, XML-RPC Transport ## ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Transport::HTTP::XMLRPCLite; use strict; use warnings; use base qw(Net::DRI::Transport); use Net::DRI::Exception; use Net::DRI::Data::Raw; use Net::DRI::Util; use XMLRPC::Lite; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport::HTTP::XMLRPCLite - XML-RPC Transport for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$rp)=@_; my %opts=%$rp; my $po=$ctx->{protocol}; my %t=(message_factory => $po->factories()->{message}); if (exists($opts{protocol_connection}) && $opts{protocol_connection}) { $t{protocol_connection}=$opts{protocol_connection}; $t{protocol_connection}->require or Net::DRI::Exception::err_failed_load_module('transport/socket',$t{protocol_connection},$@); if ($t{protocol_connection}->can('transport_default')) { %opts=($t{protocol_connection}->transport_default('xmlrpclite'),%opts); } } my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance $self->is_sync(1); $self->name('xmlrpclite'); $self->version($VERSION); $t{has_login}=(exists($opts{has_login}) && defined($opts{has_login}))? $opts{has_login} : 0; $t{has_logout}=(exists($opts{has_logout}) && defined($opts{has_logout}))? $opts{has_logout} : 0; $self->has_state($t{has_login}); if ($t{has_login}) { foreach my $p (qw/client_login client_password/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p})); $t{$p}=$opts{$p}; } $t{session_data}={}; } foreach my $p (qw/protocol_connection proxy_uri/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p})); $t{$p}=$opts{$p}; } Net::DRI::Exception::usererr_invalid_parameters('proxy_uri must be http:// or https://') unless ($t{proxy_uri}=~m!^https?://!); my $pc=$t{protocol_connection}; if ($t{has_login}) { foreach my $m (qw/login parse_login extract_session/) { Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_login=1') unless ($pc->can($m)); } } if ($t{has_logout}) { foreach my $m (qw/logout parse_logout/) { Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_logout=1') unless ($pc->can($m)); } } $self->{transport}=\%t; bless($self,$class); if ($self->has_state()) { if ($self->defer()) ## we will open, but later { $self->current_state(0); } else ## we will open NOW { $self->open_connection($ctx); } } else { $self->init(); $self->time_open(time()); } return $self; } sub soap { my ($self,$v)=@_; $self->{transport}->{soap}=$v if @_==2; return $self->{transport}->{soap}; } sub session_data { my ($self,$v)=@_; $self->{transport}->{session_data}=$v if @_==2; return $self->{transport}->{session_data}; } sub init { my ($self)=@_; return if defined($self->soap()); my $soap=XMLRPC::Lite->new(); $soap->proxy($self->{transport}->{proxy_uri}); $soap->transport()->agent(sprintf('Net::DRI/%s Net::DRI::Transport::HTTP::XMLRPCLite/%s ',$Net::DRI::VERSION,$VERSION).$soap->transport()->agent()); $self->soap($soap); } sub send_login { my ($self,$ctx)=@_; my $t=$self->{transport}; return unless $t->{has_login}; foreach my $p (qw/client_login client_password/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p}); } my $pc=$t->{protocol_connection}; my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid); my $res=$self->_send_receive({otype=>'session',oaction=>'login',trid=>$cltrid,phase=>'opening'},$login); my $msg=$t->{message_factory}->(); $msg->parse(Net::DRI::Data::Raw->new(1,[$res])); my $rc=$pc->parse_login($msg); die($rc) unless $rc->is_success(); $self->session_data($pc->extract_session($msg)); } sub send_logout { my ($self)=@_; my $t=$self->{transport}; return unless $t->{has_logout}; my $pc=$t->{protocol_connection}; my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); my $logout=$pc->logout($t->{message_factory},$cltrid,$t->{session_data}); my $res=$self->_send_receive({otype=>'session',oaction=>'logout',trid=>$cltrid,phase=>'closing'},$logout); my $msg=$t->{message_factory}->(); $msg->parse(Net::DRI::Data::Raw->new(1,[$res])); my $rc=$pc->parse_logout($msg); die($rc) unless $rc->is_success(); $self->session_data({}); } sub _send_receive { my ($self,$ctx,$msg)=@_; my $soap=$self->soap(); my $err; my $res=$soap->on_fault(sub { (undef,$err)=@_; return; })->call($msg->method(),@{$msg->params()}); if (my $httpres=$soap->transport()->http_response()) { $self->log_output('notice','transport',$ctx,{direction=>'out',message=>$httpres->request()}); $self->log_output('notice','transport',$ctx,{direction=>'in', message=>$httpres}); } else { $self->log_output('error','transport',$ctx,{direction=>'out',message=>'No response for message '.$soap->serializer()->envelope(method => $msg->method(), @{$msg->params()})}); } return $res if defined $res && ref $res && ! $res->fault() && ! defined $err; Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP fault: '.$err->faultcode().' '.$err->faultstring()) if defined $err && ref $err; Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP transport error: '.$soap->transport()->status()) unless $soap->transport()->is_success(); Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP deserialization error: '.$err); } sub open_connection { my ($self,$ctx)=@_; $self->init(); $self->send_login($ctx); $self->current_state(1); $self->time_open(time()); $self->time_used(time()); } sub close_connection { my ($self)=@_; $self->send_logout(); $self->soap(undef); $self->current_state(0); } sub end { my ($self)=@_; if ($self->has_state() && $self->current_state()) { eval { local $SIG{ALRM}=sub { die 'timeout' }; alarm(10); $self->close_connection(); }; alarm(0); ## since close_connection may die, this must be outside of eval to be executed in all cases } } #################################################################################################### sub send { my ($self,$ctx,$tosend)=@_; $self->SUPER::send($ctx,$tosend,\&_soap_send,sub {}); } sub _soap_send { my ($self,$count,$tosend,$ctx)=@_; my $t=$self->{transport}; $tosend->add_session($self->session_data()) if $tosend->can('add_session'); my $res=$self->_send_receive($ctx,$tosend); $t->{last_reply}=$res; return 1; ## very important } sub receive { my ($self,$ctx,$count)=@_; return $self->SUPER::receive($ctx,\&_soap_receive); } sub _soap_receive { my ($self,$count)=@_; my $t=$self->{transport}; my $r=$t->{last_reply}; $t->{last_reply}=undef; return Net::DRI::Data::Raw->new(6,[$r]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Logging/0002755000175000017500000000000011352534417015775 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Logging/Syslog.pm0000644000175000017500000001103011352534376017610 0ustar patrickpatrick## Domain Registry Interface, SYSLOG Logging operations for Net::DRI ## ## Copyright (c) 2009 Jørgen Thomsen . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Logging::Syslog; use strict; use warnings; use base qw/Net::DRI::Logging/; use Sys::Syslog qw(:DEFAULT); our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/gxm); sprintf '%d'.('.%02d' x $#r), @r; }; #################################################################################################### sub new { my ($class,$data)=@_; my $self=$class->SUPER::new($data); if (! exists $self->{ident} || ! defined $self->{ident} ) { $self->{ident} = 'NetDRI'; } if (! exists $self->{priority} || ! defined $self->{priority} ) { $self->{priority} = 'info'; } if (! exists $self->{options} || ! defined $self->{options} ) { $self->{options} = 'pid,nofatal'; } if (! exists $self->{facility} || ! defined $self->{facility} ) { $self->{facility} = 'local3'; } if (! exists $self->{logopened} || ! defined $self->{logopened} ) { $self->{logopened} = 0; } return $self; } sub name { return 'syslog'; } sub setup_channel { my ($self,$source,$type,$data)=@_; $self->{format_header} ='[%ULEVEL] <%TYPE>'; # either opened by caller: 1 or opened here: 2 if (exists $self->{logopened} && defined($self->{logopened}) && $self->{logopened} > 0) { return; } openlog($self->{ident}, $self->{options}, $self->{facility}); $self->{logopened} = 2; return; } sub output { my ($self,$level,$type,$data)=@_; if ($self->should_log($level)) { my @lines = split( /\n/, $self->tostring($level,$type,$data) ); # log each indented line when xml_indent => 1 foreach (@lines) { syslog($self->{priority}.'|'.$self->{facility}, ($self->{logopened} != 2 ? $self->{ident}.': ':'')."%s", $_); } } return; } sub DESTROY { my ($self)=@_; closelog() if $self->{logopened} == 2; # we opened it return; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Logging::Syslog - SYSLOG Logging Operations for Net::DRI =head1 VERSION This documentation refers to Net::DRI::Logging::Syslog version 1.01 Read e.g. with pod2text Net/DRI/Logging/Syslog.pm|less =head1 SYNOPSIS See L =head1 DESCRIPTION This class dumps all logging information to SYSLOG. =head1 EXAMPLES $dri=Net::DRI->new({cache_ttl => 10, logging => ['syslog', { level => 'warning', xml_indent => 0, ident => 'NetDRI', priority => 'info', facility => 'local3', options => 'pid,nofatal', logopened => 0 } ] }); The values above are the default =over 2 =item - level, xml_ident refer to L =item - ident, priority, facility, options refer to L =item - logopened Value 1: Sys::Syslog::openlog() already called, so do not call it in this module, but still specify ident, priority, and facility, if the defaults are not wanted =back =head1 SUBROUTINES/METHODS All mandated by superclass L. =head1 DIAGNOSTICS None. =head1 CONFIGURATION AND ENVIRONMENT None. =head1 DEPENDENCIES This modules has to be used inside the Net::DRI framework and needs the following components: Sys::Syslog =over =item L =back =head1 INCOMPATIBILITIES None =head1 BUGS AND LIMITATIONS No known bugs. Please report problems to author (see below) or use CPAN RT system. Patches are welcome. =head1 SUPPORT For now, support questions should be sent to: Enetdri@jth.netE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Jørgen Thomsen, Enetdri@jth.netE =head1 LICENSE AND COPYRIGHT Copyright (c) 2009 Jørgen Thomsen . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Logging/Null.pm0000644000175000017500000000534211352534376017253 0ustar patrickpatrick## Domain Registry Interface, Null Logging operations for Net::DRI ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Logging::Null; use strict; use warnings; use base qw/Net::DRI::Logging/; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf '%d'.('.%02d' x $#r), @r; }; #################################################################################################### sub name { return 'null'; } sub setup_channel { return; } sub output { return; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Logging::Null - Null Logging Operations for Net::DRI =head1 VERSION This documentation refers to Net::DRI::Logging::Null version 1.01 =head1 SYNOPSIS See L =head1 DESCRIPTION This is the default logging class used by L if nothing else is specified, It discards everything (no logging at all). =head1 EXAMPLES $dri->new({..., logging => 'null' ,...}); If not provided during C, this is the default behaviour. =head1 SUBROUTINES/METHODS All mandated by superclass L. =head1 DIAGNOSTICS None. =head1 CONFIGURATION AND ENVIRONMENT None. =head1 DEPENDENCIES This module has to be used inside the Net::DRI framework and needs the following components: =over =item L =back =head1 INCOMPATIBILITIES None =head1 BUGS AND LIMITATIONS No known bugs. Please report problems to author (see below) or use CPAN RT system. Patches are welcome. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 LICENSE AND COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Logging/Stderr.pm0000644000175000017500000000551311352534376017604 0ustar patrickpatrick## Domain Registry Interface, STDERR Logging operations for Net::DRI ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Logging::Stderr; use strict; use warnings; use base qw/Net::DRI::Logging/; use IO::Handle; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/gxm); sprintf '%d'.('.%02d' x $#r), @r; }; *STDERR->autoflush(); #################################################################################################### sub name { return 'stderr'; } sub setup_channel { my ($self,$source,$type,$data)=@_; return; } ## nothing to do really sub output { my ($self,$level,$type,$data)=@_; if ($self->should_log($level)) { *STDERR->print($self->tostring($level,$type,$data),"\n"); } return; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Logging::Stderr - STDERR Logging Operations for Net::DRI =head1 VERSION This documentation refers to Net::DRI::Logging::Stderr version 1.01 =head1 SYNOPSIS See L =head1 DESCRIPTION This class dumps all logging information to STDERR. =head1 EXAMPLES $dri->new({..., logging => 'stderr' ,...}); =head1 SUBROUTINES/METHODS All mandated by superclass L. =head1 DIAGNOSTICS None. =head1 CONFIGURATION AND ENVIRONMENT None. =head1 DEPENDENCIES This modules has to be used inside the Net::DRI framework and needs the following composants: =over =item L =back =head1 INCOMPATIBILITIES None =head1 BUGS AND LIMITATIONS No known bugs. Please report problems to author (see below) or use CPAN RT system. Patches are welcome. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 LICENSE AND COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Logging/Files.pm0000644000175000017500000001041411352534376017377 0ustar patrickpatrick## Domain Registry Interface, Logging into files ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Logging::Files; use strict; use warnings; use base qw/Net::DRI::Logging/; use Net::DRI::Exception; use IO::Handle; ## needed for the autoflush method on any lexical $fh our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf('%d'.'.%02d' x $#r, @r); }; #################################################################################################### sub new { my ($class,$data)=@_; my $self=$class->SUPER::new($data); if (! exists $self->{output_directory} || ! defined $self->{output_directory} ) { $self->{output_directory}='.'; } if (! -d $self->{output_directory}) { Net::DRI::Exception->die(0,'logging',1,'Directory '.$self->{output_directory}.' does not exist'); } if (! -w $self->{output_directory}) { Net::DRI::Exception->die(0,'logging',2,'Directory '.$self->{output_directory}.' is not writable'); } $self->{fh}={}; return $self; } sub name { return 'files'; } sub setup_channel { my ($self,$source,$type,$data)=@_; my $name=$self->generate_filename($type,$data); if (exists $self->{fh}->{$name}) { return; } my $fh; open $fh,'>>',$name or Net::DRI::Exception->die(0,'logging',3,'File '.$name.' can not be open for writing: '.$!); $fh->autoflush(1); ## this is possible thanks to IO::Handle $self->{fh}->{$name}=$fh; return; } sub output { my ($self,$level,$type,$data)=@_; if (! $self->should_log($level)) { return; } my $name=$self->generate_filename($type,$data); print { $self->{fh}->{$name} } $self->tostring($level,$type,$data),"\n"; return; } #################################################################################################### sub generate_filename { my ($self,$type,$ctx)=@_; my $name=(defined $ctx && ref $ctx eq 'HASH')? sprintf('%s-%s',$ctx->{registry},$ctx->{profile}) : $type; return sprintf '%s/%d-%s.log',$self->{output_directory},$$,$name; } sub DESTROY { my ($self)=@_; foreach my $fh (values %{$self->{fh}}) { close $fh or 1; } return; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Logging::Files - Logging to Files for Net::DRI =head1 VERSION This documentation refers to Net::DRI::Logging::Files version 1.01 =head1 SYNOPSIS See L =head1 DESCRIPTION This class dumps all logging information to various files. =head1 EXAMPLES $dri->new({..., logging => ['files',{output_directory => '/tmp'}] ,...}); If not defined, output_directory defaults to the current working directory. =head1 SUBROUTINES/METHODS All mandated by superclass L. =head1 DIAGNOSTICS None. =head1 CONFIGURATION AND ENVIRONMENT None. =head1 DEPENDENCIES This modules has to be used inside the Net::DRI framework and needs the following components: =over =item L =back It also uses IO::Handle, from Perl core. =head1 INCOMPATIBILITIES None =head1 BUGS AND LIMITATIONS No known bugs. Please report problems to author (see below) or use CPAN RT system. Patches are welcome. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 LICENSE AND COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Registry.pm0000644000175000017500000006127611352534376016573 0ustar patrickpatrick## Domain Registry Interface, Registry object ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Registry; use strict; use warnings; use base qw(Class::Accessor::Chained::Fast Net::DRI::BaseClass); __PACKAGE__->mk_ro_accessors(qw(name driver profile trid_factory logging)); ## READ-ONLY !! use Time::HiRes (); use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Data::RegistryObject; our $AUTOLOAD; our $VERSION=do { my @r=(q$Revision: 1.32 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Registry - Specific Registry Driver Instance inside Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$name,$drd,$cache,$trid,$logging)=@_; my $self={name => $name, driver => $drd, cache => $cache, profiles => {}, ## { profile name => { protocol => X ## transport => X ## status => Net::DRI::Protocol::ResultStatus ## %extra ## } ## } profile => undef, ## current profile auto_target => {}, last_data => {}, last_process => {}, trid_factory => $trid, logging => $logging, }; bless($self,$class); return $self; } sub available_profile { my $self=shift; return (defined($self->{profile}))? 1 : 0; } sub available_profiles { my ($self,$full)=@_; $full||=0; return sort($full ? map { $_->{fullname} } values(%{$self->{profiles}}) : keys(%{$self->{profiles}})); } sub exist_profile { my ($self,$name)=@_; return (defined($name) && exists($self->{profiles}->{$name})); } sub err_no_current_profile { Net::DRI::Exception->die(0,'DRI',3,'No current profile available'); } sub err_profile_name_does_not_exist { Net::DRI::Exception->die(0,'DRI',4,'Profile name '.$_[0].' does not exist'); } sub remote_object { my $self=shift; return Net::DRI::Data::RegistryObject->new($self,@_); } sub _current { my ($self,$what,$tostore)=@_; err_no_current_profile() unless (defined($self->{profile})); err_profile_name_does_not_exist($self->{profile}) unless (exists($self->{profiles}->{$self->{profile}})); Net::DRI::Exception::err_method_not_implemented($what) unless (exists($self->{profiles}->{$self->{profile}}->{$what})); if (($what eq 'status') && $tostore) { $self->{profiles}->{$self->{profile}}->{$what}=$tostore; } return $self->{profiles}->{$self->{profile}}->{$what}; } sub transport { return shift->_current('transport'); } sub protocol { return shift->_current('protocol'); } sub status { return shift->_current('status',@_); } sub protocol_transport { my $self=shift; return ($self->protocol(),$self->transport()); } sub local_object { my $self=shift; my $f=shift; return unless $self && $f; return $self->_current('protocol')->create_local_object($f,@_); } sub _result { my ($self,$f)=@_; my $p=$self->profile(); err_no_current_profile() unless (defined($p)); Net::DRI::Exception->die(0,'DRI',6,'No last status code available for current registry and profile') unless (exists($self->{profiles}->{$p}->{status})); my $rc=$self->{profiles}->{$p}->{status}; ## a Net::DRI::Protocol::ResultStatus object ! Net::DRI::Exception->die(1,'DRI',5,'Status key is not a Net::DRI::Protocol::ResultStatus object') unless UNIVERSAL::isa($rc,'Net::DRI::Protocol::ResultStatus'); return $rc if ($f eq 'self'); Net::DRI::Exception->die(1,'DRI',5,'Method '.$f.' not implemented in Net::DRI::Protocol::ResultStatus') unless ($f && $rc->can($f)); return $rc->$f(); } sub result_is_success { return shift->_result('is_success'); } sub is_success { return shift->_result('is_success'); } ## Alias sub result_code { return shift->_result('code'); } sub result_native_code { return shift->_result('native_code'); } sub result_message { return shift->_result('message'); } sub result_lang { return shift->_result('lang'); } sub result_status { return shift->_result('self'); } sub result_extra_info { return shift->_result('info'); } sub cache_expire { return shift->{cache}->delete_expired(); } sub cache_clear { return shift->{cache}->delete(); } sub set_info { my ($self,$type,$key,$data,$ttl)=@_; my $p=$self->profile(); err_no_current_profile() unless defined($p); my $regname=$self->name(); my $c=$self->{cache}->set($regname.'.'.$p,$type,$key,$data,$ttl); $self->{last_data}=$c; ## the hash exists, since we called clear_info somewhere before return $c; } ## Returns a $rc object or undef if nothing found in cache for the specific object ($type/$key) and action ($action) sub try_restore_from_cache { my ($self,$type,$key,$action)=@_; if (! Net::DRI::Util::all_valid($type,$key,$action)) { Net::DRI::Exception::err_assert('try_restore_from_cache improperly called'); } my $a=$self->get_info('action',$type,$key); ## not in cache or in cache but for some other action if (! defined $a || ($a ne $action)) { $self->log_output('debug','core',sprintf('Cache MISS (empty cache or other action) for type=%s key=%s',$type,$key)); return; } ## retrieve from cache, copy, and do some cleanup $self->{last_data}=$self->get_info_all($type,$key); ## since we passed the above test on get_info('action'), we know here we received something defined by get_info_all, ## but we test explicitely again (get_info_all returns an empty ref hash on problem, not undef), to avoid race conditions and such if (! keys(%{$self->{last_data}})) { $self->log_output('debug','core',sprintf('Cache MISS (no last_data content) for type=%s key=%s',$type,$key)); return; } ## get_info_all makes a copy, but only at first level ! so this high level change is ok (no pollution), but be warned for below ! $self->{last_data}->{result_from_cache}=1; ## however we must take care of what we do in levels further below, as the same data is probably in the original $rc object (if not thrown away by application) my $rd=$self->{last_data}->{result_status}->get_data_collection(); ## we first make a copy (here it is a plain ref hash, no objects inside, otherwise a proper clone() would be needed, see Clone::* modules), then we can update it. ## If something more complex is needed, a proper clone() should be implemented $rd->{session}={ %{$rd->{session}} }; ## (if there are other keys than exchange, we do not need to copy them, since we do not change their content) $rd->{session}->{exchange}={ %{$rd->{session}->{exchange}} }; $rd->{session}->{exchange}->{result_from_cache}=1; ## Should we delete the raw exchange (session/exchange/command,duration,reply) data too ? $self->log_output('debug','core',sprintf('Cache HIT for type=%s key=%s',$type,$key)); return $self->get_info('result_status'); } sub clear_info { shift->{last_data}={}; } sub get_info { my ($self,$what,$type,$key)=@_; return unless (defined($what) && $what); if (Net::DRI::Util::all_valid($type,$key)) ## search the cache, by default same registry & profile ! { my $p=$self->profile(); err_no_current_profile() unless defined($p); my $regname=$self->name(); return $self->{cache}->get($type,$key,$what,$regname.'.'.$p); } else { return unless exists($self->{last_data}->{$what}); return $self->{last_data}->{$what}; } } sub get_info_all { my ($self,$type,$key)=@_; my $rh; if (Net::DRI::Util::all_valid($type,$key)) { my $p=$self->profile(); err_no_current_profile() unless defined($p); my $regname=$self->name(); $rh=$self->{cache}->get($type,$key,undef,$regname.'.'.$p); } else { $rh=$self->{last_data}; } return {} unless (defined($rh) && ref($rh) && keys(%$rh)); my %h=%{ $rh }; ## create a copy, as we will delete content... ## BUGFIX !! foreach my $k (grep { /^_/ } keys(%h)) { delete($h{$k}); } return \%h; } sub get_info_keys { my ($self,$type,$key)=@_; my $rh=$self->get_info_all($type,$key); return sort { $a cmp $b } keys(%$rh); } #################################################################################################### ## Change profile sub target { my ($self,$profile)=@_; err_profile_name_does_not_exist($profile) unless ($profile && exists($self->{profiles}->{$profile})); $self->{profile}=$profile; } sub profile_auto_switch { my ($self,$otype,$oaction)=@_; my $p=$self->get_auto_target($otype,$oaction); return unless defined($p); $self->target($p); return; } sub set_auto_target { my ($self,$profile,$otype,$oaction)=@_; ## $otype/$oaction may be undef err_profile_name_does_not_exist($profile) unless ($profile && exists($self->{profiles}->{$profile})); my $rh=$self->{auto_target}; $otype||='_default'; $oaction||='_default'; $rh->{$otype}={} unless (exists($rh->{$otype})); $rh->{$otype}->{$oaction}=$profile; } sub get_auto_target { my ($self,$otype,$oaction)=@_; my $at=$self->{auto_target}; $otype='_default' unless (exists($at->{$otype})); return unless (exists($at->{$otype})); my $ac=$at->{$otype}; return unless (defined($ac) && ref($ac)); $oaction='_default' unless (exists($ac->{$oaction})); return unless (exists($ac->{$oaction})); return $ac->{$oaction}; } sub add_current_profile { my ($self,@p)=@_; my $rc=$self->add_profile(@p); if ($rc->is_success()) { $self->target($p[0]); } return $rc; } ## Transport and Protocol parameters are merged (semantically but not chronologically, parameters coming later erase previous ones) in this order; ## - TransportConnectionClass->transport_default() [only for transport parameters] ## - Protocol->transport_default() [only for transport parameters] ## - DRD->transport_protocol_default() ## - user specified parameters to add_profile (they always have precedence over defaults stored in the 3 previous cases) ## API: profile name, profile type (types starting with "test=" are only for internal tests, and should not be used in production), transport params {}, protocol params {} sub add_profile { my ($self,$name,$type,$trans_p,$prot_p)=@_; if (! Net::DRI::Util::all_valid($name,$type)) { Net::DRI::Exception::usererr_insufficient_parameters('add_profile needs at least 2 parameters: new profile name and type'); } if (defined $trans_p && ref $trans_p ne 'HASH') { Net::DRI::Exception::usererr_invalid_parameters('If provided, 3rd parameter of add_profile (transport data) must be a ref hash'); } if (defined $prot_p && ref $prot_p ne 'HASH') { Net::DRI::Exception::usererr_invalid_parameters('If provided, 4th parameter of add_profile (protocol data) must be a ref hash'); } if ($self->exist_profile($name)) { Net::DRI::Exception::usererr_invalid_parameters('New profile name "'.$name.'" already in use'); } my $drd=$self->driver(); my ($test)=($type=~s/^test=//)? 1 : 0; my ($tc,$tp,$pc,$pp); ## Transport Class, Transport Params, Protocol Class, Protocol Params ($tc,$tp,$pc,$pp)=$drd->transport_protocol_default($type) if (!$test || $type!~m/[A-Z]/); if ($test) { $self->log_output('emergency','core','For profile "'.$name.'", using INTERNAL TESTING configuration! This should not happen in production, but only during "make test"!'); Net::DRI::Exception::err_assert('test profile types are to be used only during internal tests') unless exists $INC{'Test/More.pm'}; $tc='Dummy'; $tp=$trans_p; $trans_p=undef; if ($type=~m/[A-Z]/) { $pc=$type; $pp=defined $prot_p ? $prot_p : {}; $prot_p=undef; } } if (!Net::DRI::Util::all_valid($tc,$tp,$pc,$pp) || ref $tp ne 'HASH' || ref $pp ne 'HASH') { Net::DRI::Exception::usererr_invalid_parameters(sprintf('Registry "%s" does not provide profile type "%s")',$self->name(),$type)); } $tp={ %$tp, %$trans_p } if defined $trans_p; $pp={ %$pp, %$prot_p } if defined $prot_p; $tc='Net::DRI::Transport::'.$tc unless ($tc=~m/::/); $pc='Net::DRI::Protocol::'.$pc unless ($pc=~m/::/); $drd->transport_protocol_init($type,$tc,$tp,$pc,$pp,$test) if $drd->can('transport_protocol_init'); $tc->require() or Net::DRI::Exception::err_failed_load_module('DRI',$tc,$@); $pc->require() or Net::DRI::Exception::err_failed_load_module('DRI',$pc,$@); $self->log_output('debug','core',sprintf('For profile "%s" attempting to initialize transport "%s" and protocol "%s"',$name,$tc,$pc)); my $po=$pc->new($drd,$pp); ## Protocol must come first, as it may be needed during transport setup; it should not die $tp={ $po->transport_default(), %$tp } if ($po->can('transport_default')); my $to; eval { $to=$tc->new({registry=>$self,profile=>$name,protocol=>$po},$tp); ## this may die ! }; if ($@) ## some kind of error happened { return $@ if (ref($@) eq 'Net::DRI::Protocol::ResultStatus'); $@=Net::DRI::Exception->new(1,'internal',0,'Error not handled: '.$@) unless ref($@); die($@); } my $fullname=sprintf('%s (%s/%s + %s/%s)',$name,$po->name(),$po->version(),$to->name(),$to->version()); $self->{profiles}->{$name}={ fullname => $fullname, transport => $to, protocol => $po, status => undef }; $self->log_output('notice','core','Successfully added profile "'.$fullname.'"'); return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL','Profile "'.$name.'" added successfully'); } sub del_profile { my ($self,$name)=@_; if (defined($name)) { err_profile_name_does_not_exist($name) unless ($self->exist_profile($name)); } else { err_no_current_profile() unless (defined($self->{profile})); $name=$self->{profile}; } my $p=$self->{profiles}->{$name}; $p->{protocol}->end() if (ref($p->{protocol}) && $p->{protocol}->can('end')); $p->{transport}->end({registry => $self, profile => $name}) if (ref($p->{transport}) && $p->{transport}->can('end')); delete($self->{profiles}->{$name}); $self->{profile}=undef if $self->{profile} eq $name; ## current profile is not defined anymore return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL','Profile '.$name.' deleted successfully'); } sub end { my $self=shift; foreach my $name (keys(%{$self->{profiles}})) { my $p=$self->{profiles}->{$name}; $p->{protocol}->end() if (ref($p->{protocol}) && $p->{protocol}->can('end')); $p->{transport}->end() if (ref($p->{transport}) && $p->{transport}->can('end')); delete $self->{profiles}->{$name} } $self->{driver}->end() if $self->{driver}->can('end'); } sub can { my ($self,$what)=@_; return $self->UNIVERSAL::can($what) || $self->driver->can($what); } #################################################################################################### #################################################################################################### sub has_action { my ($self,$otype,$oaction)=@_; my ($po,$to)=$self->protocol_transport(); return $po->has_action($otype,$oaction); } sub process { my ($self,$otype,$oaction)=@_[0,1,2]; my $pa=$_[3] || []; ## store them ? my $ta=$_[4] || []; $self->{last_process}=[$otype,$oaction,$pa,$ta]; ## should be handled more generally by LocalStorage/Exchange ## Automated switch, if enabled $self->profile_auto_switch($otype,$oaction); ## Current protocol/transport objects for current profile my ($po,$to)=$self->protocol_transport(); my $trid=$self->generate_trid(); my $ctx={trid => $trid, otype => $otype, oaction => $oaction, phase => 'active' }; my $tosend; eval { $tosend=$po->action($otype,$oaction,$trid,@$pa); }; ## TODO : this may need to be pushed in loop below if we need to change message to send when failure return $self->format_error($@) if $@; $self->{ops}->{$trid}=[0,$tosend,undef]; ## 0 = todo, not sent ## This will be done in/with LocalStorage my $timeout=$to->timeout(); my $prevalarm=alarm(0); ## removes current alarm my $pause=$to->pause(); my $start=Time::HiRes::time(); $self->{ops}->{$trid}->[2]=$start; my $count=0; my $r; while (++$count <= $to->retry()) { $self->log_output('debug','core',sprintf('New process loop iteration for TRID=%s with count=%d pause=%f timeout=%f',$trid,$count,$pause,$timeout)); Time::HiRes::sleep($pause) if (defined($pause) && $pause && ($count > 1)); $self->log_output('warning','core',sprintf('Starting try #%d for TRID=%s',$count,$trid)) if $count>1; $r=eval { local $SIG{ALRM}=sub { die 'timeout' }; alarm($timeout) if ($timeout); $self->log_output('debug','core',sprintf('Attempting to send data for TRID=%s',$trid)); ## Should we also pass the current registry driver (or at least its name), and the current profile name ? This may be useful in logging $to->send($ctx,$tosend,$count,$ta); ## either success or exception, no result code $self->log_output('debug','core','Successfully sent data to registry for TRID='.$trid); $self->{ops}->{$trid}->[0]=1; ## now it is sent return $self->process_back($trid,$po,$to,$otype,$oaction,$count) if $to->is_sync(); my $rc=Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL_PENDING'); $rc->_set_trid([ $trid ]); $self->status($rc); return $rc; }; alarm(0) if ($timeout); ## removes our alarm if ($@) ## some die happened inside the eval { return $self->format_error($@) if (ref($@) eq 'Net::DRI::Protocol::ResultStatus'); ## should probably be a return here see below TODOXXX my $is_timeout=(!ref($@) && ($@=~m/timeout/))? 1 : 0; $@=$is_timeout? Net::DRI::Exception->new(1,'transport',1,'timeout') : Net::DRI::Exception->new(1,'internal',0,'Error not handled: '.$@) unless ref($@); $self->log_output('debug','core',$is_timeout? 'Got timeout for TRID='.$trid : 'Got error for TRID='.$trid.' : '.$@->as_string()); next if $to->try_again($ctx,$po,$@,$count,$is_timeout,$self->{ops}->{$trid}->[0],\$pause,\$timeout); ## will determine if 1) we break now the loop/we propagate the error (fatal error) 2) we retry die($@); } last if defined($r); } ## end of while alarm($prevalarm) if $prevalarm; ## re-enable previous alarm (warning, time is off !!) Net::DRI::Exception->die(0,'transport',1,sprintf('Unable to communicate with registry after %d tries for a total delay of %.03f seconds',$to->retry(),Time::HiRes::time()-$start)) unless defined $r; return $r; } sub format_error { my ($self,$err)=@_; if (ref($err) eq 'Net::DRI::Protocol::ResultStatus') { $self->status($err); ## should that be done above also ? TODOXXX return $err; } $err=Net::DRI::Exception->new(1,'internal',0,'Error not handled: '.$err) unless ref($err); die($err); } ## also called directly , when we found something to do for asynchronous case, through TRID (TODO) ## We are already in an eval here, and a while loop for retries sub process_back { my ($self,$trid,$po,$to,$otype,$oaction,$count)=@_; my $ctx={trid => $trid, otype => $otype, oaction => $oaction }; ## How will we fill that in case of async operation (direct call here) ? my ($rc,$ri,$oname); $self->log_output('debug','core','Attempting to receive data from registry for TRID='.$trid); my $res=$to->receive($ctx,$count); ## a Net::DRI::Data::Raw or die inside my $stop=Time::HiRes::time(); $self->log_output('debug','core','Successfully received data from registry for TRID='.$trid); Net::DRI::Exception->die(0,'transport',5,'Unable to receive message from registry') unless defined($res); $self->{ops}->{$trid}->[0]=2; ## now it is received $self->clear_info(); ## make sure we will overwrite current latest info $oname=_extract_oname($otype,$oaction,$self->{last_process}->[2]); ## lc() would be good here but this breaks a lot of things ! ($rc,$ri)=$po->reaction($otype,$oaction,$res,$self->{ops}->{$trid}->[1],$oname); ## $tosend needed to propagate EPP version, for example $rc->_set_trid([ $trid ]) unless $rc->trid(); ## if not done inside Protocol::*::Message::result_status, make sure we save at least our transaction id if ($rc->is_closing() || (exists($ri->{_internal}) && exists($ri->{_internal}->{must_reconnect}) && $ri->{_internal}->{must_reconnect})) { $self->log_output('notice','core','Registry closed connection, we will automatically reconnect during next exchange'); $to->current_state(0); } delete($ri->{_internal}); ## Set latest status from what we got $self->status($rc); $ri->{session}->{exchange}->{result_from_cache}=0; $ri->{session}->{exchange}->{protocol}=$po->name().'/'.$po->version(); $ri->{session}->{exchange}->{transport}=$to->name().'/'.$to->version(); $ri->{session}->{exchange}->{registry}=$self->name(); $ri->{session}->{exchange}->{profile}=$self->profile(); $ri->{session}->{exchange}->{trid}=$trid; ## set_info stores also data in last_data, so we make sure to call last for current object foreach my $type (keys(%$ri)) { foreach my $key (keys(%{$ri->{$type}})) { next if ($oname && ($type eq $otype) && ($key eq $oname)); $self->set_info($type,$key,$ri->{$type}->{$key}); } } ## Now set the last info, the one regarding directly the object if ($oname && $otype) { my $rli={ result_status => $rc }; $rli=$ri->{$otype}->{$oname} if (exists($ri->{$otype}) && exists($ri->{$otype}->{$oname})); ## result_status already done in Protocol $self->set_info($otype,$oname,$rli); } ## Not before ! ## Remove all ResultStatus object, to avoid all circular references foreach my $v1 (values(%$ri)) { foreach my $v2 (values(%{$v1})) { delete($v2->{result_status}) if exists($v2->{result_status}); } } $ri->{session}->{exchange}={ %{$ri->{session}->{exchange}}, duration_seconds => $stop-$self->{ops}->{$trid}->[2], raw_command => $self->{ops}->{$trid}->[1]->as_string(), raw_reply => $res->as_string(), object_type => $otype, object_action => $oaction }; $ri->{session}->{exchange}->{object_name}=$oname if $oname; $rc->_set_data($ri); delete($self->{ops}->{$trid}); return $rc; } sub _extract_oname { my ($otype,$oaction,$pa)=@_; return 'domains' if ($otype eq 'account' && $oaction eq 'list_domains'); my $o=$pa->[0]; return 'session' unless defined($o); $o=$o->[1] if (ref($o) eq 'ARRAY'); ## should be enough for _multi but still a little strange return (Net::DRI::Util::normalize_name($otype,$o))[1] unless ref($o); ## ?? ## TODO ## this fails t/626nominet line 306 return (Net::DRI::Util::normalize_name('nsgroup',$otype eq 'nsgroup'? $o->name() : $o->get_details(1)))[1] if Net::DRI::Util::isa_hosts($o); return $o->srid() if Net::DRI::Util::isa_contact($o); return 'session'; } #################################################################################################### sub protocol_capable { my ($ndr,$op,$subop,$action)=@_; return 0 unless ($op && $subop); ## $action may be undefined my $po=$ndr->protocol(); my $cap=$po->capabilities(); ## hashref return 0 unless ($cap && (ref($cap) eq 'HASH') && exists($cap->{$op}) && (ref($cap->{$op}) eq 'HASH') && exists($cap->{$op}->{$subop}) && (ref($cap->{$op}->{$subop}) eq 'ARRAY')); return 1 unless (defined($action) && $action); foreach my $a (@{$cap->{$op}->{$subop}}) { return 1 if ($a eq $action); } return 0; } sub log_output { my ($self,$level,$where,$msg)=@_; my $r=$self->name(); $r.='.'.$self->{profile} if (defined $self->{profile}); $msg='('.$r.') '.$msg; return $self->SUPER::log_output($level,$where,$msg); } #################################################################################################### sub AUTOLOAD { my $self=shift; my $attr=$AUTOLOAD; $attr=~s/.*:://; return unless $attr=~m/[^A-Z]/; ## skip DESTROY and all-cap methods my $drd=$self->driver(); ## This is a DRD object Net::DRI::Exception::err_method_not_implemented($attr.' in '.$drd) unless (ref($drd) && $drd->can($attr)); $self->log_output('debug','core',sprintf('Calling %s from Net::DRI::Registry',$attr)); return $drd->$attr($self,@_); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/0002755000175000017500000000000011352534417015020 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/DRD/AT.pm0000644000175000017500000001071711352534376015672 0ustar patrickpatrick## Domain Registry Interface, .AT policy ## Contributed by Michael Braunoeder from NIC.AT ## ## Copyright (c) 2006-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::AT; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use Net::DRI::Data::Contact::AT; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_accept domain_transfer_refuse domain_renew contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse contact_check/); =pod =head1 NAME Net::DRI::DRD::AT - .AT policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=2; ## this means we want IPs in all cases (even for nameservers in domain name) $self->{info}->{contact_i18n}=2; ## INT only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1); } sub name { return 'NICAT'; } sub tlds { return ('at'); } sub object_types { return ('domain','contact'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::AT',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.nic.at'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } sub set_factories { my ($self,$po)=@_; $po->factories('contact',sub { return Net::DRI::Data::Contact::AT->new(@_); }); } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name_no_dots => 1, ## is this correct? my_tld_not_strict => 1, ## is this correct? }); } sub domain_withdraw { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'withdraw'); $rd={} unless (defined($rd) && (ref($rd) eq 'HASH')); $rd->{transactionname} = 'withdraw'; my $rc=$ndr->process('domain','nocommand',[$domain,$rd]); return $rc; } sub domain_transfer_execute { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_execute'); $rd={} unless (defined($rd) && (ref($rd) eq 'HASH')); $rd->{transactionname} = 'transfer_execute'; my $rc=$ndr->process('domain','nocommand',[$domain,$rd]); return $rc; } sub message_retrieve { my ($self,$ndr,$id)=@_; my $rc=$ndr->process('message','atretrieve',[$id]); return $rc; } sub message_delete { my ($self,$ndr,$id)=@_; my $rc=$ndr->process('message','atdelete',[$id]); return $rc; } sub message_count { my ($self,$ndr)=@_; my $rc=$ndr->process('message','atretrieve'); return unless $rc->is_success(); my $count=$ndr->get_info('count','message','info'); return (defined($count) && $count)? $count : 0; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/PL.pm0000644000175000017500000000633511352534376015702 0ustar patrickpatrick## Domain Registry Interface, .PL policies ## ## Copyright (c) 2006,2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::PL; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Exception; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_stop domain_transfer_query domain_transfer_accept domain_transfer_refuse contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse/); =pod =head1 NAME Net::DRI::DRD::PL - .PL policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'NASK'; } ## See http://www.dns.pl/english/dns-funk.html sub tlds { return ('pl',map { $_.'.pl'} qw/aid agro atm auto biz com edu gmina gsm info mail miasta media mil net nieruchomosci nom org pc powiat priv realestate rel sex shop sklep sos szkola targi tm tourism travel turystyka/ ); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::HTTP',{protocol_connection=>'Net::DRI::Protocol::EPP::Extensions::HTTP'},'Net::DRI::Protocol::EPP::Extensions::PL',{}) if $type eq 'epp'; ## EPP is over HTTPS here return; } #################################################################################################### sub message_retrieve { my ($self,$ndr,$id)=@_; my $rc=$ndr->process('message','plretrieve',[$id]); return $rc; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/CoCCA.pm0000644000175000017500000000657111352534376016241 0ustar patrickpatrick## Domain Registry Interface, CoCCA Registry Driver for multiple TLDs ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::CoCCA; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use DateTime; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::CoCCA - CoCCA Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. This is only a prototype for testing purpose. Each TLD registry should have its own DRD module implementing local policies. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub periods { return map { DateTime::Duration->new(years => $_) } (1..5); } sub name { return 'CoCCA'; } sub tlds { return (qw/cx gs tl ki mu nf ht na ng cc cm sb mg/); } sub object_types { return ('domain','ns','contact'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{remote_host => 'ote.epp.cocca.cx'},'Net::DRI::Protocol::EPP',{}) if $type eq 'epp'; return; } #################################################################################################### ## We can not start a transfer, if domain name has already been transfered less than 15 days ago. sub verify_duration_transfer { my ($self,$ndr,$duration,$domain,$op)=@_; ($duration,$domain,$op)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return 0 unless ($op eq 'start'); ## we are not interested by other cases, they are always OK my $rc=$self->domain_info($ndr,$domain,{hosts=>'none'}); return 1 unless ($rc->is_success()); my $trdate=$ndr->get_info('trDate'); return 0 unless ($trdate && $trdate->isa('DateTime')); my $now=DateTime->now(time_zone => $trdate->time_zone()->name()); my $cmp=DateTime->compare($now,$trdate+DateTime::Duration->new(days => 15)); return ($cmp == 1)? 0 : 1; ## we must have : now > transferdate + 15days ## we return 0 if OK, anything else if not } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/US.pm0000644000175000017500000000624411352534376015715 0ustar patrickpatrick## Domain Registry Interface, .US policies ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard , ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::US; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use Net::DRI::Data::Contact::US; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::US - .US policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard Etonnerre.lombard@sygroup.chE, All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=6; ## INT only or INT+LOC (but not LOC only) bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'US'; } sub tlds { return ('us'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::US',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.nic.us'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } sub set_factories { my ($self,$po)=@_; $po->factories('contact',sub { return Net::DRI::Data::Contact::US->new(@_); }); } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/VNDS.pm0000644000175000017500000000754411352534376016144 0ustar patrickpatrick## Domain Registry Interface, "Verisign Naming and Directory Services" Registry Driver for .COM .NET .CC .TV .BZ .JOBS ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::VNDS; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use DateTime; our $VERSION=do { my @r=(q$Revision: 1.19 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::VNDS - Verisign .COM/.NET/.CC/.TV/.BZ/.JOBS Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'VNDS'; } sub tlds { return ('com','net','cc','tv','bz','jobs'); } ## If this changes, VeriSign/NameStore will need to be updated also sub object_types { return ('domain','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::VeriSign',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.verisign-grs.com'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, }); } ## We can not start a transfer, if domain name has already been transfered less than 15 days ago. sub verify_duration_transfer { my ($self,$ndr,$duration,$domain,$op)=@_; ($duration,$domain,$op)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return 0 unless ($op eq 'start'); ## we are not interested by other cases, they are always OK my $rc=$self->domain_info($ndr,$domain,{hosts=>'none'}); return 1 unless ($rc->is_success()); my $trdate=$ndr->get_info('trDate'); return 0 unless ($trdate && $trdate->isa('DateTime')); my $now=DateTime->now(time_zone => $trdate->time_zone()->name()); my $cmp=DateTime->compare($now,$trdate+DateTime::Duration->new(days => 15)); return ($cmp == 1)? 0 : 1; ## we must have : now > transferdate + 15days ## we return 0 if OK, anything else if not } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/ORG.pm0000644000175000017500000000567011352534376016017 0ustar patrickpatrick## Domain Registry Interface, .ORG policies ## ## Copyright (c) 2006,2007,2008,2009 Rony Meyer . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::ORG; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::ORG - .ORG policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Rony Meyer . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'ORG'; } sub tlds { return ('org'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.publicinterestregistry.net'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/NU.pm0000644000175000017500000000474611352534376015715 0ustar patrickpatrick## Domain Registry Interface, .NU policies ## ## Copyright (c) 2007,2008,2009 HEXONET Support GmbH, http://www.hexonet.com, ## Alexander Biehl . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::NU; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::NU - .NU policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 HEXONET Support GmbH, Ehttp://www.hexonet.comE, Alexander Biehl . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (2..10); } sub name { return 'NU'; } sub tlds { return ('nu'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP',{}) if $type eq 'epp'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/CentralNic.pm0000644000175000017500000001133011352534376017400 0ustar patrickpatrick## Domain Registry Interface, CentralNic Registry Driver ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::CentralNic; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use DateTime; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::CentralNic - CentralNic (.LA .EU.COM .UK.COM etc.) Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=2; ## INT only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (2..10); } sub name { return 'CentralNic'; } sub tlds { return (qw/la uk.net se.net gb.net/,map { $_.'.com' } qw/eu uk us cn de jpn kr no za br ar ru sa se hu gb qc uy ae/); } ## see https://www.centralnic.com/names/domains sub object_types { return ('domain','ns','contact'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::CentralNic',{}) if $type eq 'epp'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, min_length => 3, }); } ## We can not start a transfer, if domain name has already been transfered less than 15 days ago. sub verify_duration_transfer { my ($self,$ndr,$duration,$domain,$op)=@_; ($duration,$domain,$op)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return 0 unless ($op eq 'start'); ## we are not interested by other cases, they are always OK my $rc=$self->domain_info($ndr,$domain,{hosts=>'none'}); return 1 unless ($rc->is_success()); my $trdate=$ndr->get_info('trDate'); return 0 unless ($trdate && $trdate->isa('DateTime')); my $now=DateTime->now(time_zone => $trdate->time_zone()->name()); my $cmp=DateTime->compare($now,$trdate+DateTime::Duration->new(days => 15)); return ($cmp == 1)? 0 : 1; ## we must have : now > transferdate + 15days ## we return 0 if OK, anything else if not } sub verify_duration_renew { my ($self,$ndr,$duration,$domain,$curexp)=@_; ($duration,$domain,$curexp)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return 0 unless (defined($duration) && defined($curexp) && UNIVERSAL::isa($curexp,'DateTime')); my $newexp=$curexp+$duration; ## New expiration my $max=DateTime->new(year => 2037, month => 1, day => 1, time_zone => $curexp->time_zone()->name()); my $cmp=DateTime->compare($newexp,$max); return 2 unless ($cmp == -1); ## we must have curexp+duration < 2037 return 0; ## everything ok } #################################################################################################### sub domain_release { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'release'); return $ndr->process('domain','release',[$domain,$rd]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/AERO.pm0000644000175000017500000000525011352534376016110 0ustar patrickpatrick## Domain Registry Interface, .AERO policies ## ## Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::AERO; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use Net::DRI::Data::Contact::AERO; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::AERO - .AERO policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'AERO'; } sub tlds { return ('aero'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::AERO',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.aero'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } sub set_factories { my ($self,$po)=@_; $po->factories('contact',sub { return Net::DRI::Data::Contact::AERO->new(@_); }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/WS.pm0000644000175000017500000000463311352534376015717 0ustar patrickpatrick## Domain Registry Interface, "WorldSite.WS" Registry Driver for .WS ## ## Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::WS; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.11 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::WS - Website.WS .WS Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'WS'; } sub tlds { return ('ws'); } sub object_types { return ('domain','ns'); } sub profile_types { return qw/rrp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::RRP',{}) if $type eq 'rrp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.nic.ws'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/IM.pm0000644000175000017500000000574611352534376015701 0ustar patrickpatrick## Domain Registry Interface, .IM policies ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::IM; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_stop domain_transfer_query domain_transfer_accept domain_transfer_refuse/); =pod =head1 NAME Net::DRI::DRD::IM - .IM policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'IM'; } sub tlds { return (qw/im co.im org.im net.im/); } sub object_types { return ('domain','contact'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{remote_host=>'epp.nic.im'},'Net::DRI::Protocol::EPP',{}) if $type eq 'epp'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, min_length => 3, no_double_hyphen => 1, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/IRegistry.pm0000644000175000017500000000477111352534376017312 0ustar patrickpatrick## Domain Registry Interface, .CO.CZ policies ## ## Copyright (c) 2008 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::IRegistry; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::IRegistry - .CO.CZ policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Einfo@i-registry.czE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Vitezslav Novy, i-registry based on .CZ module by Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=2; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'IRegistry'; } sub tlds { return ('co.cz'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::IRegistry',{}) if $type eq 'epp'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/ARNES.pm0000644000175000017500000000545411352534376016240 0ustar patrickpatrick## Domain Registry Interface, .SI policies # ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::ARNES; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_stop domain_transfer_accept domain_transfer_refuse/); =pod =head1 NAME Net::DRI::DRD::ARNES - ARNES (.SI) policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'ARNES'; } sub tlds { return ('si'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::SI',{}) if $type eq 'epp'; return; } #################################################################################################### sub domain_trade_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); my $rc=$ndr->process('domain','transfer_registrant_request',[$domain,$rd]); return $rc; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/CZ.pm0000644000175000017500000000466111352534376015703 0ustar patrickpatrick## Domain Registry Interface, .CZ policies ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::CZ; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::CZ - .CZ policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=2; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'CZ'; } sub tlds { return ('cz'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::CZ',{}) if $type eq 'epp'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/NO.pm0000644000175000017500000002153711352534376015704 0ustar patrickpatrick## Domain Registry Interface, .NO policies for Net::DRI ## ## Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::NO; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION = do { my @r = ( q$Revision: 1.5 $ =~ /\d+/gxm ); sprintf( "%d" . ".%02d" x $#r, @r ); }; # let contact check support be decided by the server policy __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_accept domain_transfer_refuse contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse/); =pod =head1 NAME Net::DRI::DRD::NO - .NO policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Trond Haugen Einfo@norid.noE =head1 COPYRIGHT Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->{info}->{host_as_attr} = 0; # means make host objects $self->{info}->{use_null_auth}= 1; # means using domain:null for empty authinfo password bless( $self, $class ); return $self; } sub periods { return map { DateTime::Duration->new( years => $_ ) } (1); } sub name { return 'NORID'; } sub tlds { return ('NO'); } sub object_types { return ( 'domain', 'contact', 'ns' ); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::NO',{}) if $type eq 'epp'; # suppress until whois is supported #return ('Net::DRI::Transport::Socket',{remote_host=>'whois.norid.no'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### =head1 verify_name_domain .NO allows country codes in labels on the left, so we need to subclass the verify_name_domain to avoid the CCA2 table check. We then clone the .AT code also here, but remove the dot-count and check in 'check_name'. However, we do not subclass the 'is_my_tld' as .AT has done, but we then have to call it in a non-strict mode to allow for domain names with multiple lables. The combination should then allow multiple labels and also to use CC-codes in lables, like 'se.vgs.no' =cut sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; $self->_verify_name_rules($domain,$op,{check_name_no_dots => 1, my_tld_not_strict => 0, }); } sub verify_duration_renew { my ( $self, $ndr, $duration, $domain, $curexp ) = @_; ( $duration, $domain, $curexp ) = ( $ndr, $duration, $domain ) unless ( defined($ndr) && $ndr && ( ref($ndr) eq 'Net::DRI::Registry' ) ); if ( defined($duration) ) { my ( $y, $m ) = $duration->in_units( 'years', 'months' ); ## Only 1..12m or 1y allowed in a renew unless ( ( $y == 1 && $m == 0 ) || ( $y == 0 && ( $m >= 1 && $m <= 12 ) ) ) { Net::DRI::Exception::usererr_invalid_parameters( 'Invalid duration for renew/transfer_execute, must be 1..12 months' ); return 1; # if exception is removed, return an error } } return 0; ## everything ok } sub domain_operation_needs_is_mine { my ( $self, $ndr, $domain, $op ) = @_; return unless defined($op); return 1 if ( $op =~ m/^(?:renew|update|delete|withdraw)$/mx ); return 0 if ( $op eq 'transfer' ); return; } sub domain_withdraw { my ( $self, $ndr, $domain, $rd ) = @_; $self->enforce_domain_name_constraints($ndr,$domain,'withdraw'); $rd = {} unless ( defined($rd) && ( ref($rd) eq 'HASH' ) ); $rd->{transactionname} = 'withdraw'; my $rc = $ndr->process( 'domain', 'withdraw', [ $domain, $rd ] ); return $rc; } sub domain_transfer_execute { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_execute'); $rd={} unless (defined($rd) && (ref($rd) eq 'HASH')); $rd->{transactionname} = 'transfer_execute'; my $rc=$ndr->process('domain','transfer_execute',[$domain,$rd]); return $rc; } # need to accept also t=contact as an element-type to be updated # sub host_update { my ( $self, $ndr, $dh, $tochange, $rh ) = @_; my $fp = $ndr->protocol->nameversion(); my $name = ( UNIVERSAL::isa( $dh, 'Net::DRI::Data::Hosts' ) ) ? $dh->get_details(1) : $dh; $self->enforce_host_name_constraints($ndr,$name); Net::DRI::Util::check_isa( $tochange, 'Net::DRI::Data::Changes' ); foreach my $t ( $tochange->types() ) { Net::DRI::Exception->die( 0, 'DRD', 6, "Change host_update/${t} not handled" ) unless ( $t =~ m/^(?:ip|status|name|contact|facets)$/mx ); next if $ndr->protocol_capable( 'host_update', $t ); Net::DRI::Exception->die( 0, 'DRD', 5, "Protocol ${fp} is not capable of host_update/${t}" ); } my %what = ( 'ip' => [ $tochange->all_defined('ip') ], 'status' => [ $tochange->all_defined('status') ], 'name' => [ $tochange->all_defined('name') ], ); foreach ( @{ $what{ip} } ) { Net::DRI::Util::check_isa( $_, 'Net::DRI::Data::Hosts' ); } foreach ( @{ $what{status} } ) { Net::DRI::Util::check_isa( $_, 'Net::DRI::Data::StatusList' ); } foreach ( @{ $what{name} } ) { $self->enforce_host_name_constraints($ndr,$_); } foreach my $w ( keys(%what) ) { my @s = @{ $what{$w} }; next unless @s; ## no changes of that type my $add = $tochange->add($w); my $del = $tochange->del($w); my $set = $tochange->set($w); Net::DRI::Exception->die( 0, 'DRD', 5, "Protocol ${fp} is not capable for host_update/${w} to add" ) if ( defined($add) && !$ndr->protocol_capable( 'host_update', $w, 'add' ) ); Net::DRI::Exception->die( 0, 'DRD', 5, "Protocol ${fp} is not capable for host_update/${w} to del" ) if ( defined($del) && !$ndr->protocol_capable( 'host_update', $w, 'del' ) ); Net::DRI::Exception->die( 0, 'DRD', 5, "Protocol ${fp} is not capable for host_update/${w} to set" ) if ( defined($set) && !$ndr->protocol_capable( 'host_update', $w, 'set' ) ); Net::DRI::Exception->die( 0, 'DRD', 6, "Change host_update/${w} with simultaneous set and add or del not supported" ) if ( defined($set) && ( defined($add) || defined($del) ) ); } my $rc = $ndr->process( 'host', 'update', [ $dh, $tochange, $rh ] ); return $rc; } sub message_retrieve { my ( $self, $ndr, $rd ) = @_; my $rc = $ndr->process( 'message', 'noretrieve', [$rd] ); return $rc; } sub message_delete { my ( $self, $ndr, $id, $rd ) = @_; my $rc = $ndr->process( 'message', 'nodelete', [$id, $rd] ); return $rc; } sub message_waiting { my ( $self, $ndr, $rd ) = @_; my $c = $self->message_count($ndr, $rd); return ( defined($c) && $c ) ? 1 : 0; } sub message_count { my ( $self, $ndr, $rd ) = @_; my $count = $ndr->get_info( 'count', 'message', 'info' ); return $count if defined($count); my $rc = $ndr->process( 'message', 'noretrieve', [$rd] ); return unless $rc->is_success(); $count = $ndr->get_info( 'count', 'message', 'info' ); return ( defined($count) && $count ) ? $count : 0; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/GL.pm0000644000175000017500000000670511352534376015672 0ustar patrickpatrick## Domain Registry Interface, GL Registry Driver ## ## Copyright (c) 2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::GL; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use DateTime; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::GL - GL Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. As .GL is not yet in production, modifications may be needed. Only little testing has been done, but basic contact and domain functions are working. However, .GL is currently implementing a vanilla CoCCA system. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub periods { return map { DateTime::Duration->new(years => $_) } (1..5); } sub name { return 'GL'; } sub tlds { return (qw/gl co.gl com.gl net.gl edu.gl org.gl/); } sub object_types { return ('domain','ns','contact'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{remote_host => 'registry.nic.gl'},'Net::DRI::Protocol::EPP',{}) if $type eq 'epp'; return; } #################################################################################################### # OBS. Not yet defined by NIC.GL # We can not start a transfer, if domain name has already been transfered less than 15 days ago. sub verify_duration_transfer { my ($self,$ndr,$duration,$domain,$op)=@_; ($duration,$domain,$op)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return 0 unless ($op eq 'start'); ## we are not interested by other cases, they are always OK my $rc=$self->domain_info($ndr,$domain,{hosts=>'none'}); return 1 unless ($rc->is_success()); my $trdate=$ndr->get_info('trDate'); return 0 unless ($trdate && $trdate->isa('DateTime')); my $now=DateTime->now(time_zone => $trdate->time_zone()->name()); my $cmp=DateTime->compare($now,$trdate+DateTime::Duration->new(days => 15)); return ($cmp == 1)? 0 : 1; ## we must have : now > transferdate + 15days ## we return 0 if OK, anything else if not } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/OVH.pm0000644000175000017500000000577011352534376016025 0ustar patrickpatrick## Domain Registry Interface, OVH Registry Driver ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::OVH; use strict; use warnings; use base qw/Net::DRI::DRD/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::OVH - OVH Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 CURRENT LIMITATIONS Only domain_info and account_list_domains are implemented for now =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub name { return 'OVH'; } sub tlds { return qw/fr com net org info biz eu me.uk co.uk org.uk de be re es/; } ## As seen on http://www.ovh.com/fr/particulier/produits/domaines.xml sub object_types { return ('domain'); } sub profile_types { return qw/ws/; } sub transport_protocol_default { my ($self,$type)=@_; #return ('Net::DRI::Transport::HTTP::SOAPWSDL',{wsdl_uri => 'https://www.ovh.com/soapi/ovh.wsdl',proxy_uri => 'http://www.ovh.com:1664',servicename => 'managerService',portname => 'managerPort'},'Net::DRI::Protocol::OVH::WS',{}) if $type eq 'ws'; return ('Net::DRI::Transport::HTTP::SOAPLite',{uri => 'https://soapi.ovh.com/manager',proxy_uri => 'https://www.ovh.com:1664'},'Net::DRI::Protocol::OVH::WS',{}) if $type eq 'ws'; return; } #################################################################################################### sub domain_operation_needs_is_mine { my ($self,$ndr,$domain,$op)=@_; return; } sub account_list_domains { my ($self,$ndr)=@_; my $rc=$ndr->try_restore_from_cache('account','domains','list'); if (! defined $rc) { $rc=$ndr->process('account','list_domains'); } return $rc; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/MOBI.pm0000644000175000017500000000504511352534376016112 0ustar patrickpatrick## Domain Registry Interface, .MOBI policies ## ## Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::MOBI; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::MOBI - .MOBI policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'MOBI'; } sub tlds { return ('mobi'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::MOBI',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.dotmobiregistry.net'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/COOP.pm0000644000175000017500000000643411352534376016127 0ustar patrickpatrick## Domain Registry Interface, .COOP policies ## ## Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::COOP; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Exception; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::COOP - .COOP policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'COOP'; } sub tlds { return ('coop'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{remote_host=>'217.10.159.121'},'Net::DRI::Protocol::EPP::Extensions::COOP',{}) if $type eq 'epp'; ## .COOP test server return; } ## TODO: these SSL checks should probably be done in other DRD classes too ! sub transport_protocol_init { my ($self,$type,$tc,$tp,$pc,$pp,$test)=@_; if ($type eq 'epp' && !$test) { my @n=grep { ! exists($tp->{$_}) || ! defined($tp->{$_}) || ! $tp->{$_}} qw/ssl_key_file ssl_cert_file ssl_ca_file/; Net::DRI::Exception::usererr_insufficient_parameters('These transport parameters must be defined: '.join(' ',@n)) if @n; } return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/AdamsNames.pm0000644000175000017500000000522711352534376017377 0ustar patrickpatrick## Domain Registry Interface, AdamsNames Registry Driver ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::AdamsNames; use strict; use warnings; use base qw/Net::DRI::DRD/; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::AdamsNames - AdamsNames (.TC .VG .GD) Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 CURRENT LIMITATIONS Only domain_info and account_list_domains are implemented for now =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub name { return 'AdamsNames'; } sub tlds { return (qw/tc vg gd/); } sub object_types { return ('domain','contact'); } sub profile_types { return qw/ws das/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::HTTP::XMLRPCLite',{proxy_uri=>'http://www.adamsnames.tc/api/xmlrpc'},'Net::DRI::Protocol::AdamsNames::WS',{}) if $type eq 'ws'; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::DAS::AdamsNames',{}) if $type eq 'das'; return; } #################################################################################################### sub domain_operation_needs_is_mine { my ($self,$ndr,$domain,$op)=@_; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/AU.pm0000644000175000017500000000521411352534376015667 0ustar patrickpatrick## Domain Registry Interface, .AU policies ## ## Copyright (c) 2007,2008,2009 Distribute.IT Pty Ltd, www.distributeit.com.au, Rony Meyer . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::AU; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::AU - .AU policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Rony Meyer, Eperl@spot-light.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Distribute.IT Pty Ltd, Ehttp://www.distributeit.com.auE, Rony Meyer . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (2..3); } sub name { return 'AU'; } sub tlds { return qw/com.au net.au org.au asn.au id.au vic.au tas.au nsw.au act.au qld.au sa.au nt.au wa.au/; } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp das/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::AU',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::DAS::AU',{}) if $type eq 'das'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/MN.pm0000644000175000017500000000556411352534376015704 0ustar patrickpatrick## Domain Registry Interface, Afilias ccTLD policies for .MN ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::MN; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::MN - .MN policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'Afilias MN'; } sub tlds { return qw/mn/; } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return; } #################################################################################################### ## http://www.afilias-grs.info/public/policies/mn sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, min_length => 3, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/VC.pm0000644000175000017500000000561111352534376015673 0ustar patrickpatrick## Domain Registry Interface, Afilias ccTLD policies for .VC ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::VC; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::VC - .VC policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'Afilias VC'; } sub tlds { return qw/vc com.vc net.vc org.vc/; } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return; } #################################################################################################### ## http://www.afilias-grs.info/public/policies/vc sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, min_length => 2, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/IENUMAT.pm0000644000175000017500000000623011352534376016463 0ustar patrickpatrick## Domain Registry Interface, Infrastructure ENUM.AT policy on reserved names ## Contributed by Michael Braunoeder from ENUM.AT ## ## Copyright (c) 2006,2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::IENUMAT; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Util; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; ## The domain renew command are not implemented at the ienum43 EPP server, domains are renewed automatically __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_renew/); =pod =head1 NAME Net::DRI::DRD::IENUMAT - Infrastructure ENUM.AT policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1); } sub name { return 'IENUMAT'; } sub tlds { return ('i.3.4.e164.arpa'); } sub object_types { return ('domain'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::IENUMAT',{}) if $type eq 'epp'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name_no_dots => 1, ## is this correct? my_tld_not_strict => 1, ## is this correct? no_country_code => 1, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/BookMyName.pm0000644000175000017500000000577111352534376017373 0ustar patrickpatrick## Domain Registry Interface, BookMyName Registry Driver ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::BookMyName; use strict; use warnings; use base qw/Net::DRI::DRD/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::BookMyName - BookMyName (aka Free/ProXad/Online/Dedibox/Iliad) Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 CURRENT LIMITATIONS Only domain_info and account_list_domains are implemented for now =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub name { return 'BookMyName'; } sub tlds { return qw/com net org biz info name eu be us/; } ## As seen on http://api.doc.free.org/revendeur-de-nom-de-domaine sub object_types { return ('domain'); } sub profile_types { return qw/ws das/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::HTTP::SOAPLite',{uri=>'https://api.free.org/apis.cgi',proxy_uri=>'https://api.free.org/apis.cgi'},'Net::DRI::Protocol::BookMyName::WS',{}) if $type eq 'ws'; return ('Net::DRI::Transport::Socket',{remote_host=>'das.bookmyname.com'},'Net::DRI::Protocol::DAS',{}) if $type eq 'das'; return; } #################################################################################################### sub domain_operation_needs_is_mine { my ($self,$ndr,$domain,$op)=@_; return; } sub account_list_domains { my ($self,$ndr)=@_; my $rc=$ndr->try_restore_from_cache('account','domains','list'); if (! defined $rc) { $rc=$ndr->process('account','list_domains'); } return $rc; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/CAT.pm0000644000175000017500000000564611352534376016002 0ustar patrickpatrick## Domain Registry Interface, .CAT policies ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::CAT; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use Net::DRI::Data::Contact::CAT; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::CAT - .CAT policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } ## The registry allows renewal as long as final date is less than 11 years in the future (10 years & 5 months would thus be ok) ## We are currently more restrictive than that, see DRD::verify_duration_renew() sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'CAT'; } sub tlds { return ('cat'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{remote_host=>'epp.ote.puntcat.corenic.net'},'Net::DRI::Protocol::EPP::Extensions::CAT',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.cat'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } sub set_factories { my ($self,$po)=@_; $po->factories('contact',sub { return Net::DRI::Data::Contact::CAT->new(@_); }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/Nominet.pm0000644000175000017500000002017411352534376016775 0ustar patrickpatrick## Domain Registry Interface, .UK (Nominet) policies for Net::DRI ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::Nominet; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Util; use Net::DRI::Exception; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; ## No status at all with Nominet ## Only domain:check is available ## Only domain transfer op=req and refuse/accept ## The delete command applies only to domain names. Accounts, contacts and nameservers cannot be explicitly deleted, but are automatically deleted when no longer referenced. ## No direct contact/host create __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_update_status_add domain_update_status_del domain_update_status_set domain_update_status domain_status_allows_delete domain_status_allows_update domain_status_allows_transfer domain_status_allows_renew domain_status_allows domain_current_status host_update_status_add host_update_status_del host_update_status_set host_update_status host_current_status contact_update_status_add contact_update_status_del contact_update_status_set contact_update_status contact_current_status host_check host_check_multi host_exist contact_check contact_check_multi contact_exist contact_transfer contact_transfer_start contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse domain_transfer_stop domain_transfer_query host_delete contact_delete host_create contact_create/); =pod =head1 NAME Net::DRI::DRD::Nominet - .UK (Nominet) policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (2); } sub name { return 'Nominet'; } sub tlds { return qw/co.uk ltd.uk me.uk net.uk org.uk plc.uk sch.uk/; } ## See http://www.nominet.org.uk/registrants/aboutdomainnames/rules/ sub object_types { return ('domain','contact','ns','account'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{remote_host => 'epp.nominet.org.uk'},'Net::DRI::Protocol::EPP::Extensions::Nominet',{}) if ($type eq 'epp' || $type eq 'epp_nominet'); return ('Net::DRI::Transport::Socket',{remote_host => 'epp.nominet.org.uk'},'Net::DRI::Protocol::EPP',{}) if ($type eq 'epp_standard'); return; } sub transport_protocol_init { my ($self,$type,$tc,$tp,$pc,$pp,$test)=@_; ## As seen on http://www.nominet.org.uk/registrars/systems/nominetepp/login/ $tp->{client_login}='#'.$tp->{client_login} if ($type eq 'epp' && defined $tp->{client_login} && length $tp->{client_login}==2); return; } #################################################################################################### ## http://www.nominet.org.uk/registrars/systems/epp/renew/ sub verify_duration_renew { my ($self,$ndr,$duration,$domain,$curexp)=@_; ($duration,$domain,$curexp)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); ## +Renew commands will only be processed if the expiry date of the domain name is within 6 months. if (defined($duration)) { my ($y,$m)=$duration->in_units('years','months'); return 1 unless ($y==2 && $m==0); ## Only 24m or 2y allowed } return 0; ## everything ok } sub host_info { my ($self,$ndr,$dh,$rh)=@_; my $roid=Net::DRI::Util::isa_hosts($dh)? $dh->roid() : $dh; ## when we do a domain:info we get all info needed to later on reply to a host:info (cache delay permitting) ; we do not take this information into account here my $rc=$ndr->try_restore_from_cache('host',$roid,'info'); if (! defined $rc) { $rc=$ndr->process('host','info',[$dh,$rh]); } return $rc unless $rc->is_success(); return (wantarray())? ($rc,$ndr->get_info('self')) : $rc; } sub host_update { my ($self,$ndr,$dh,$tochange)=@_; my $fp=$ndr->protocol->nameversion(); my $name=Net::DRI::Util::isa_hosts($dh)? $dh->get_details(1) : $dh; $self->enforce_host_name_constraints($ndr,$name); Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes'); foreach my $t ($tochange->types()) { Net::DRI::Exception->die(0,'DRD',6,"Change host_update/${t} not handled") unless ($t=~m/^(?:ip|name)$/); next if $ndr->protocol_capable('host_update',$t); Net::DRI::Exception->die(0,'DRD',5,"Protocol ${fp} is not capable of host_update/${t}"); } my %what=('ip' => [ $tochange->all_defined('ip') ], 'name' => [ $tochange->all_defined('name') ], ); foreach (@{$what{ip}}) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::Hosts'); } foreach (@{$what{name}}) { $self->enforce_host_name_constraints($ndr,$_); } foreach my $w (keys(%what)) { my @s=@{$what{$w}}; next unless @s; ## no changes of that type my $add=$tochange->add($w); my $del=$tochange->del($w); my $set=$tochange->set($w); Net::DRI::Exception->die(0,'DRD',5,"Protocol ${fp} is not capable for host_update/${w} to add") if (defined($add) && ! $ndr->protocol_capable('host_update',$w,'add')); Net::DRI::Exception->die(0,'DRD',5,"Protocol ${fp} is not capable for host_update/${w} to del") if (defined($del) && ! $ndr->protocol_capable('host_update',$w,'del')); Net::DRI::Exception->die(0,'DRD',5,"Protocol ${fp} is not capable for host_update/${w} to set") if (defined($set) && ! $ndr->protocol_capable('host_update',$w,'set')); Net::DRI::Exception->die(0,'DRD',6,"Change host_update/${w} with simultaneous set and add or del not supported") if (defined($set) && (defined($add) || defined($del))); } my $rc=$ndr->process('host','update',[$dh,$tochange]); return $rc; } sub account_info { my ($self,$ndr,$c)=@_; return $ndr->process('account','info',[$c]); } sub account_update { my ($self,$ndr,$c,$cs)=@_; return $ndr->process('account','update',[$c,$cs]); } sub account_fork { my ($self,$ndr,$c,$cs)=@_; return $ndr->process('account','fork',[$c,$cs]); } sub account_merge { my ($self,$ndr,$c,$cs)=@_; return $ndr->process('account','merge',[$c,$cs]); } sub domain_unrenew { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'unrenew'); return $ndr->process('domain','unrenew',[$domain,$rd]); } sub account_list_domains { my ($self,$ndr,$rd,$rh)=@_; my $rc=$ndr->try_restore_from_cache('account','domains','list'); if (! defined $rc) { $rc=$ndr->process('account','list_domains',[$rd,$rh]); } return $rc; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/Gandi.pm0000644000175000017500000000526311352534376016410 0ustar patrickpatrick## Domain Registry Interface, Gandi Registry Driver ## ## Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::Gandi; use strict; use warnings; use base qw/Net::DRI::DRD/; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::Gandi - Gandi Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 CURRENT LIMITATIONS Only domain_info and account_list_domains are implemented for now =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ##################################################################################### sub name { return 'Gandi'; } sub tlds { return ('com','net','org','biz','info','name','be'); } sub object_types { return ('domain','contact'); } sub profile_types { return qw/ws/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::HTTP::XMLRPCLite',{proxy_uri=>'https://api.gandi.net/xmlrpc/'},'Net::DRI::Protocol::Gandi::WS',{}) if $type eq 'ws'; return; } #################################################################################################### sub domain_operation_needs_is_mine { my ($self,$ndr,$domain,$op)=@_; return; } sub account_list_domains { my ($self,$ndr)=@_; my $rc=$ndr->try_restore_from_cache('account','domains','list'); if (! defined $rc) { $rc=$ndr->process('account','list_domains'); } return $rc; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/SWITCH.pm0000644000175000017500000000556711352534376016376 0ustar patrickpatrick## Domain Registry Interface, .CH/.LI policies ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::SWITCH; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_accept domain_transfer_refuse domain_renew contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse/); =pod =head1 NAME Net::DRI::DRD::SWITCH - SWITCH (.CH/.LI) policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E or Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1); } sub name { return 'SWITCH'; } sub tlds { return ('ch','li'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::SWITCH',{}) if $type eq 'epp'; ## return ('Net::DRI::Transport::Socket',{remote_host=>'whois.switch.ch'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/SE.pm0000644000175000017500000001060511352534376015671 0ustar patrickpatrick## Domain Registry Interface, .SE policy on reserved names ## Contributed by Elias Sidenbladh and Ulrich Wisser from NIC SE ## ## Copyright (c) 2006-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::SE; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use Net::DRI::Util; use Net::DRI::Data::Contact::SE; our $VERSION=do { my @r=(q$Revision: 1.9 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; ## Only transfer requests and queries are possible, the rest is handled "off line". __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_stop domain_transfer_accept domain_transfer_refuse domain_delete/); =pod =head1 NAME Net::DRI::DRD::SE - .SE policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub name { return 'se'; } sub tlds { return ('SE'); } sub periods { return map { DateTime::Duration->new(months => $_) } (12..120); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::SE',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.nic-se.se'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } sub set_factories { my ($self,$po)=@_; $po->factories('contact',sub { return Net::DRI::Data::Contact::SE->new(@_); }); } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, }); } sub verify_duration_create { my ($self,$ndr,$duration,$domain)=@_; ($duration,$domain)=($ndr,$duration) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); if ( defined($duration) ) { my $m = $duration->in_units( 'months' ); ## Only 12 - 120 months allowed unless ( $m >= 12 && $m <= 120 ) { Net::DRI::Exception::usererr_invalid_parameters( 'Invalid duration for create, must be 12..120 months (was '.$m.')' ); return 1; # if exception is removed, return an error } } return 0; ## everything ok } sub verify_duration_renew { my ($self,$ndr,$duration,$domain,$curexp)=@_; ($duration,$domain,$curexp)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); if ( defined($duration) ) { my $m = $duration->in_units( 'months' ); ## Only 12 - 120 months allowed unless ( $m >= 12 && $m <= 120 ) { Net::DRI::Exception::usererr_invalid_parameters( 'Invalid duration for renew, must be 12..120 months (was '.$m.')' ); return 1; # if exception is removed, return an error } } return 0; ## everything ok } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/PRO.pm0000644000175000017500000000664711352534376016035 0ustar patrickpatrick## Domain Registry Interface, .PRO policies ## ## Copyright (c) 2008,2009 Tonnerre Lombard ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::PRO; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::PRO - .PRO policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.bsdprojects.net/project/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE, Alexander Biehl, Einfo@hexonet.netE, HEXONET Support GmbH, Ehttp://www.hexonet.net/E. =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->{info}->{host_as_attr} = 0; bless($self, $class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'RegistryPro'; } sub tlds { return qw/pro law.pro jur.pro bar.pro med.pro cpa.pro aca.pro eng.pro/; } sub object_types { return ('domain','contact','ns','av'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::PRO',{}) if $type eq 'epp'; return; } #################################################################################################### sub verify_name_domain { my ($self, $ndr, $domain, $op) = @_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, }); } #################################################################################################### ## TODO : $av should be checked here to be syntaxically correct before doing process() sub av_create { my ($self,$ndr,$av,$ep)=@_; return $ndr->process('av','create',[$av,$ep]); } sub av_check { my ($self,$ndr,$av,$ep)=@_; return $ndr->process('av','check',[$av,$ep]); } sub av_info { my ($self,$ndr,$av,$ep)=@_; return $ndr->process('av','info',[$av,$ep]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/IT.pm0000644000175000017500000000544711352534376015706 0ustar patrickpatrick## Domain Registry Interface, .IT policies ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::IT; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Exception; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/host_check host_info host_update host_delete host_create contact_transfer contact_transfer_start contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse domain_renew/); =pod =head1 NAME Net::DRI::DRD::IT - .IT policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. This is only a stub for now, no .IT extensions are implemented currently. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'IIT-CNR'; } sub tlds { return ('it'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::HTTP',{protocol_connection=>'Net::DRI::Protocol::EPP::Extensions::HTTP'},'Net::DRI::Protocol::EPP::Extensions::IT',{}) if $type eq 'epp'; ## EPP is over HTTPS here return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/ME.pm0000644000175000017500000000462411352534376015667 0ustar patrickpatrick## Domain Registry Interface, .ME policies ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::ME; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::ME - .ME policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'ME'; } sub tlds { return ('me'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/OpenSRS.pm0000644000175000017500000000752111352534376016656 0ustar patrickpatrick## Domain Registry Interface, OpenSRS Registry Driver ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::OpenSRS; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::OpenSRS - OpenSRS Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head2 CURRENT LIMITATIONS Only domain_info and account_list_domains are available. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'OpenSRS'; } sub tlds { return (qw/example com net org info biz mobi name asia at be ca cc ch cn de dk es eu fr it li me com.mx nl tv uk us/); } ## see http://services.tucows.com/services/domains/pricing.php sub object_types { return ('domain'); } sub profile_types { return qw/xcp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::HTTP',{},'Net::DRI::Protocol::OpenSRS::XCP',{}) if $type eq 'xcp'; return; } #################################################################################################### sub domain_operation_needs_is_mine { my ($self,$ndr,$domain,$op)=@_; return; } sub account_list_domains { my ($self,$ndr)=@_; my $rc=$ndr->try_restore_from_cache('account','domains','list'); if (! defined $rc) { $rc=$ndr->process('account','list_domains'); } return $rc; } sub domain_info { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'info'); my $rc=$ndr->try_restore_from_cache('domain',$domain,'info'); if (! defined $rc) { ## First grab a cookie, if needed unless (Net::DRI::Util::has_key($rd,'cookie')) { $rd={} unless defined($rd); ## will fail in set_cookie because other params needed, but at least this will be ok for next line ; otherwise do true checks of value needed $rd->{domain}=$domain; $rc=$ndr->process('session','set_cookie',[$rd]); return $rc unless $rc->is_success(); $rd->{cookie}=$ndr->get_info('value','session','cookie'); ## Store cookie somewhere (taking into account date of expiry or some TTLs) ? } ## Now do the real info $rc=$ndr->process('domain','info',[$domain,$rd]); ## the $domain is not really used here, as it was used during set_cookie above } return $rc; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/EURid.pm0000644000175000017500000001470511352534376016337 0ustar patrickpatrick## Domain Registry Interface, EURid (.EU) policy on reserved names ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::EURid; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Util; use Net::DRI::Exception; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.14 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_query domain_transfer_accept domain_transfer_refuse domain_renew contact_check contact_check_multi contact_transfer contact_transfer_start contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse/); =pod =head1 NAME Net::DRI::DRD::EURid - EURid (.EU) policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ##################################################################################### our %CCA2_EU=map { $_ => 1 } qw/AT BE BG CZ CY DE DK ES EE FI FR GR GB HU IE IT LT LU LV MT NL PL PT RO SE SK SI AX GF GI GP MQ RE/; our %LANGA2_EU=map { $_ => 1 } qw/bg cs da de el en es et fi fr ga hu it lt lv mt nl pl pt ro sk sl sv/; sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1); } sub name { return 'EURid'; } sub tlds { return ('eu'); } sub object_types { return ('domain','contact','nsgroup'); } sub profile_types { return qw/epp das whois das-registrar whois-registrar/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{remote_host=>'epp.registry.tryout.eu',remote_port=>33128},'Net::DRI::Protocol::EPP::Extensions::EURid',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'das.eu'},'Net::DRI::Protocol::DAS',{no_tld=>1}) if $type eq 'das'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.eu'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return ('Net::DRI::Transport::Socket',{remote_host=>'das.registry.eu'},'Net::DRI::Protocol::DAS',{no_tld=>1}) if $type eq 'das-registrar'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.registry.eu'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois-registrar'; return; } ###################################################################################### ## See terms_and_conditions_v1_0_.pdf, Section 2.2.ii sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, min_length => 2, no_double_hyphen_except_idn => 1, ## temporary bypass for IDNs no_country_code => 1, }); } sub domain_undelete { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'undelete'); my $rc=$ndr->process('domain','undelete',[$domain,$rd]); return $rc; } sub domain_transfer_quarantine { my ($self,$ndr,$domain,$op,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_quarantine'); Net::DRI::Exception::usererr_invalid_parameters('Transfer from quarantine operation must be start or stop') unless ($op=~m/^(?:start|stop)$/); my $rc; if ($op eq 'start') { $rc=$ndr->process('domain','transferq_request',[$domain,$rd]); } elsif ($op eq 'stop') { $rc=$ndr->process('domain','transferq_cancel',[$domain,$rd]); } return $rc; } sub domain_transfer_quarantine_start { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer_quarantine($ndr,$domain,'start',$rd); } sub domain_transfer_quarantine_stop { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer_quarantine($ndr,$domain,'stop',$rd); } sub domain_trade_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); my $rc=$ndr->process('domain','trade_request',[$domain,$rd]); return $rc; } sub domain_trade_stop { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); my $rc=$ndr->process('domain','trade_cancel',[$domain,$rd]); return $rc; } sub domain_reactivate { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'reactivate'); my $rc=$ndr->process('domain','reactivate',[$domain,$rd]); return $rc; } sub domain_check_contact_for_transfer { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'check_contact_for_transfer'); my $rc=$ndr->process('domain','check_contact_for_transfer',[$domain,$rd]); return $rc; } sub registrar_info { my ($self,$ndr)=@_; my $rc=$ndr->process('registrar','info'); return $rc; } sub domain_remind { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'remind'); my $rc=$ndr->process('domain','remind',[$domain,$rd]); return $rc; } ################################################################################################################# 1; Net-DRI-0.96/lib/Net/DRI/DRD/DENIC.pm0000644000175000017500000001041411352534376016202 0ustar patrickpatrick## Domain Registry Interface, DENIC policies ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::DENIC; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::DENIC - DENIC (.DE) policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'DENIC'; } sub tlds { return ('de','9.4.e164.arpa'); } ## *.9.4.e164.arpa can be queried over IRIS DCHK, do not know about RRI support sub object_types { return ('domain','contact'); } sub profile_types { return qw/rri dchk/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{remote_host=>'rri.test.denic.de',remote_port=>51131,defer=>1,close_after=>1,socktype=>'tcp'},'Net::DRI::Protocol::RRI',{version=>'2.0'}) if $type eq 'rri'; return ('Net::DRI::Transport::Socket',{find_remote_server => ['de.','DCHK1:iris.lwz']},'Net::DRI::Protocol::IRIS',{version=>'1.0',authority=>'de'}) if $type eq 'dchk'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, ## is that right ?? }); } sub contact_update { my ($self, $reg, $c, $changes, $rd) = @_; my $oc = $reg->get_info('self', 'contact', $c->srid()); if (!defined($oc)) { my $res = $reg->process('contact', 'info', [$reg->local_object('contact')->srid($c->srid())]); $oc = $reg->get_info('self', 'contact', $c->srid()) if ($res->is_success()); } $c->type($oc->type()) if (defined($oc)); return $self->SUPER::contact_update($reg, $c, $changes, $rd); } sub domain_update { my ($self, $reg, $dom, $changes, $rd) = @_; my $cs = $reg->get_info('contact', 'domain', $dom); my $ns = $reg->get_info('ns', 'domain', $dom); if (!defined($cs) || !defined($ns)) { my $res = $reg->process('domain', 'info', [$dom]); $cs = $reg->get_info('contact', 'domain', $dom) if ($res->is_success()); $ns = $reg->get_info('ns', 'domain', $dom) if ($res->is_success()); } $rd->{contact} = $cs unless (defined($rd->{contact})); $rd->{ns} = $ns unless (defined($rd->{ns})); return $self->SUPER::domain_update($reg, $dom, $changes, $rd); } sub domain_trade { my ($self, $reg, $dom, $rd) = @_; return $reg->process('domain', 'trade', [$dom, $rd]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/SIDN.pm0000644000175000017500000000641711352534376016125 0ustar patrickpatrick## Domain Registry Interface, SIDN (.NL) Registry Driver ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::SIDN; use strict; use warnings; use base qw/Net::DRI::DRD/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_renew domain_transfer_stop domain_update_status domain_update_status_add domain_update_status_del domain_update_status_set contact_update_status contact_update_status_add contact_update_status_del contact_update_status_set host_update_status host_update_status_add host_update_status_del host_update_status_set host_update_name_set/); #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub name { return 'SIDN'; } sub tlds { return (qw/nl/); } sub periods { return; } ## registry does not expect any duration at all sub object_types { return (qw/domain contact ns/); } sub profile_types { return qw/das epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::DAS::SIDN',{}) if $type eq 'das'; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::SIDN',{}) if $type eq 'epp'; return; } #################################################################################################### sub domain_undelete { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'delete_cancel'); my $rc=$ndr->process('domain','delete_cancel',[$domain,$rd]); return $rc; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::DRD::SIDN - SIDN (.NL) Registry driver for Net::DRI =head1 SYNOPSIS $dri=Net::DRI->new(); $dri->add_registry('SIDN'); =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/DRD/AFNIC.pm0000644000175000017500000001202611352534376016201 0ustar patrickpatrick## Domain Registry Interface, AFNIC Registry Driver for .FR/.RE ## ## Copyright (c) 2005,2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::AFNIC; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.9 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/host_update host_current_status host_check host_check_multi host_exist host_delete host_create host_info contact_delete contact_check/); =pod =head1 NAME Net::DRI::DRD::AFNIC - AFNIC (.FR/.RE) Registry Driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head2 CURRENT LIMITATIONS Only domain_check (through AFNIC web services) and domain_create (by email) are currently provided. All operations are available through EPP, but this protocol is not currently in production at the registry. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1); } sub name { return 'AFNIC'; } sub tlds { return (qw/fr re tf wf pm yt asso.fr com.fr tm.fr gouv.fr/); } ## see http://www.afnic.fr/doc/autres-nic/dom-tom sub object_types { return ('domain','contact'); } sub profile_types { return qw/email ws epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::SMTP',{},'Net::DRI::Protocol::AFNIC::Email',{}) if $type eq 'email'; return ('Net::DRI::Transport::SOAP',{},'Net::DRI::Protocol::AFNIC::WS',{}) if $type eq 'ws'; return ('Net::DRI::Transport::Socket',{remote_host => 'epp.test.nic.fr'},'Net::DRI::Protocol::EPP::Extensions::AFNIC',{}) if $type eq 'epp'; return; } #################################################################################################### sub domain_operation_needs_is_mine { my ($self,$ndr,$domain,$op)=@_; return $self->SUPER::domain_operation_needs_is_mine($ndr,$domain,$op) if ($ndr->protocol()->name() eq 'EPP'); return; } sub domain_create { my ($self,$ndr,$domain,$rd)=@_; return $self->SUPER::domain_create($ndr,$domain,$rd) unless ($ndr->protocol()->name() eq 'EPP'); return $self->SUPER::domain_create($ndr,$domain,$rd) unless (Net::DRI::Util::has_key($rd,'pure_create') && $rd->{pure_create}==1); my $ns; if (defined($rd) && (ref($rd) eq 'HASH')) { $ns=$rd->{ns}; delete($rd->{ns}); } my $rc=$self->SUPER::domain_create($ndr,$domain,$rd); ## create the domain without any nameserver return $rc unless $rc->is_success(); return $rc unless (defined($ns) && Net::DRI::Util::isa_hosts($ns)); return $self->domain_update_ns_add($ndr,$domain,$ns); ## Finally update domain to add nameservers } sub domain_trade_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); return $ndr->process('domain','trade_request',[$domain,$rd]); } sub domain_trade_query { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); return $ndr->process('domain','trade_query',[$domain]); } sub domain_trade_stop { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); return $ndr->process('domain','trade_cancel',[$domain]); } sub domain_recover_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'recover'); return $ndr->process('domain','recover_request',[$domain,$rd]); } ## domain_check_multi : max 7 ! #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/BE.pm0000644000175000017500000001025511352534376015651 0ustar patrickpatrick## Domain Registry Interface, .BE (DNSBE) policies for Net::DRI ## ## Copyright (c) 2006,2007,2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::BE; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.10 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_stop domain_transfer_query domain_transfer_accept domain_transfer_refuse domain_renew contact_check contact_check_multi contact_transfer message_retrieve message_delete message_waiting message_count/); =pod =head1 NAME Net::DRI::DRD::BE - .BE (DNSBE) policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ##################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1); } sub name { return 'DNSBE'; } sub tlds { return ('be'); } sub object_types { return ('domain','contact','nsgroup'); } sub profile_types { return qw/epp das/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::DNSBE',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.dns.be'},'Net::DRI::Protocol::DAS',{no_tld=>1}) if $type eq 'das'; return; } ###################################################################################### ## From §2 of Enduser_Terms_And_Conditions_fr_v3.1.pdf sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{ check_name => 1, my_tld => 1, min_length => 2, no_double_hyphen => 1, }); } sub domain_undelete { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'undelete'); my $rc=$ndr->process('domain','undelete',[$domain,$rd]); return $rc; } sub domain_transfer_quarantine_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_quarantine'); my $rc=$ndr->process('domain','transferq_request',[$domain,$rd]); return $rc; } sub domain_trade_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); my $rc=$ndr->process('domain','trade_request',[$domain,$rd]); return $rc; } sub domain_reactivate { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'reactivate'); my $rc=$ndr->process('domain','reactivate',[$domain,$rd]); return $rc; } ################################################################################################################# 1; Net-DRI-0.96/lib/Net/DRI/DRD/TRAVEL.pm0000644000175000017500000000605611352534376016364 0ustar patrickpatrick## Domain Registry Interface, .TRAVEL policies ## ## Copyright (c) 2008,2009 Tonnerre Lombard , ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::TRAVEL; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::TRAVEL - .TRAVEL policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard , SyGroup GmbH. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=6; ## INT only or INT+LOC (but not LOC only) bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'TRAVEL'; } sub tlds { return ('travel'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.nic.travel'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/BR.pm0000644000175000017500000000531011352534376015662 0ustar patrickpatrick## Domain Registry Interface, .BR policies ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::BR; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::BR - .BR policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1); } sub name { return 'RegistroBR'; } ## See http://registro.br/info/dpn.html sub tlds { return ('br',map { $_.'.br' } qw/com agr am art edu coop esp far fm g12 gov imb ind inf jus mil net org psi rec srv tmp tur tv etc adm adv arq ato bio bmd cim cng cnt ecn eng eti fnd fot fst ggf jor lel mat med mus not ntr odo ppg pro psc qql slg trd vet zlg blog flog nom vlog sec3 wiki/ ); } sub object_types { return ('domain','contact'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::BR',{}) if $type eq 'epp'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/BZ.pm0000644000175000017500000000564111352534376015701 0ustar patrickpatrick## Domain Registry Interface, Afilias ccTLD policies for .BZ ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::BZ; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::BZ - .BZ policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'Afilias BZ'; } sub tlds { return qw/bz com.bz net.bz/; } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return; } #################################################################################################### ## http://www.afilias-grs.info/public/policies/bz ## http://www.belizenic.bz/ sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{ check_name => 1, my_tld => 1, min_length => 3, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/BIZ.pm0000644000175000017500000000616011352534376016007 0ustar patrickpatrick## Domain Registry Interface, .BIZ policies ## ## Copyright (c) 2007,2008,2009 Distribute.IT Pty Ltd, www.distributeit.com.au, ## Rony Meyer . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::BIZ; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::BIZ - .BIZ policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Distribute.IT Pty Ltd, Ehttp://www.distributeit.com.auE, Rony Meyer . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=6; ## INT only or INT+LOC (but not LOC only) bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'BIZ'; } sub tlds { return ('biz'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.nic.biz'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/ICANN.pm0000644000175000017500000001020211352534376016203 0ustar patrickpatrick## Domain Registry Interface, ICANN policy on reserved names ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::ICANN; use strict; use warnings; our $VERSION=do { my @r=(q$Revision: 1.14 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; ## See http://www.icann.org/registries/rsep/submitted_app.html for changes our %ALLOW1=map { $_ => 1 } qw/mobi coop biz pro cat/; ## Pending ICANN review: travel (#2009003) info our %ALLOW2=map { $_ => 1 } qw/mobi coop name jobs biz pro cat/; ## Pending ICANN review: travel (#2009003) info ## See http://www.icann.org/tlds/agreements/verisign/registry-agmt-appk-net-org-16apr01.htm & same ## Updated to http://www.icann.org/tlds/agreements/tel/appendix-6-07apr06.htm sub is_reserved_name { my ($domain,$op)=@_; my @d=split(/\./,lc($domain)); ## Tests at all levels foreach my $d (@d) { ## §A (ICANN+IANA reserved) return 1 if ($d=~m/^(?:aso|dnso|gnso|icann|internic|ccnso|pso|afrinic|apnic|arin|example|gtld-servers|iab|iana|iana-servers|iesg|ietf|irtf|istf|lacnic|latnic|rfc-editor|ripe|root-servers)$/o); ## §C (tagged domain names) return 1 if (length($d)>3 && (substr($d,2,2) eq '--') && ($d!~/^xn--/)); } if ($op eq 'create') { ## §B.1 (additional second level) return 1 if (length($d[-2])==1 && ! exists($ALLOW1{$d[-2]})); ## §B.2 return 1 if (length($d[-2])==2 && ! exists($ALLOW2{$d[-2]})); } ## §B.3 ## Restriction lifted in newer gTLD unless ($d[0]=~m/^(?:travel|mobi|cat|tel)$/o) { return 1 if ($d[-2]=~m/^(?:aero|arpa|biz|com|coop|edu|gov|info|int|mil|museum|name|net|org|pro)$/o); } ## §D (reserved for Registry operations) return 1 if ($d[-2]=~m/^(?:nic|whois|www)$/o); return 0; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::DRD::ICANN - ICANN policies for Net::DRI =head1 VERSION This documentation refers to Net::DRI::DRD::ICANN version 1.14 =head1 SYNOPSIS This module is never used directly, it is used by other DRD modules for registries that follow ICANN policies on syntax of domain names. More precisely, it is called from subroutine _verify_name_rules in L. =head1 DESCRIPTION This module implements ICANN rules on domain names such as minimum and maximum length, allowed characters, etc... =head1 EXAMPLES None. =head1 SUBROUTINES/METHODS =over =item is_reserved_name() returns 1 if the name passed violates some ICANN policy on domain name, 0 otherwise. =back =head1 DIAGNOSTICS None. =head1 CONFIGURATION AND ENVIRONMENT None. =head1 DEPENDENCIES This module has to be used inside the Net::DRI framework and does not have any dependency. =head1 INCOMPATIBILITIES None. =head1 BUGS AND LIMITATIONS No known bugs. Please report problems to author (see below) or use CPAN RT system. Patches are welcome. xn--something domain names are currently allowed as a temporary passthrough until L gets full IDN support. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 LICENSE AND COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/DRD/SC.pm0000644000175000017500000000567211352534376015677 0ustar patrickpatrick## Domain Registry Interface, Afilias ccTLD policies for .SC ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::SC; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::SC - .SC policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'Afilias SC'; } sub tlds { return qw/sc com.sc gov.sc net.sc org.sc edu.sc/; } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return; } #################################################################################################### ## http://www.afilias-grs.info/public/policies/sc ## http://www.nic.sc/policies.html sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, min_length => 3, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/NAME.pm0000644000175000017500000001250711352534376016105 0ustar patrickpatrick## Domain Registry Interface, .NAME policies ## ## Copyright (c) 2007,2008,2009 HEXONET Support GmbH, www.hexonet.com, ## Alexander Biehl ## and Patrick Mevzek . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::NAME; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Exception; use Net::DRI::Util; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::NAME - .NAME policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 HEXONET Support GmbH, Ehttp://www.hexonet.comE, Alexander Biehl and Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=2; ## INT only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'NAME'; } sub tlds { return ('name'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::NAME',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.nic.name'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, check_name_dots => [1,2], my_tld_not_strict => 1, ## we need less strict checks because in X.Y.name domain names both X and Y are variables icann_reserved => 1, }); } sub emailfwd_check { my ($self,$ndr,$email)=@_; ## Technical syntax check of email object needed here my $rc=$ndr->try_restore_from_cache('emailfwd',$email,'check'); if (! defined $rc) { $rc=$ndr->process('emailfwd','check',[$email]); } return $rc; } sub emailfwd_exist ## 1/0/undef { my ($self,$ndr,$email)=@_; ## Technical syntax check of email object needed here my $rc=$ndr->emailfwd_check($email); return unless $rc->is_success(); return $ndr->get_info('exist'); } sub emailfwd_info { my ($self,$ndr,$email)=@_; ## Technical syntax check of email object needed here my $rc=$ndr->try_restore_from_cache('emailfwd',$email,'info'); if (! defined $rc) { $rc=$ndr->process('emailfwd','info',[$email]); } return $rc; } sub emailfwd_create { my ($self,$ndr,$email,$rd)=@_; ## Technical syntax check of email object needed here my $rc=$ndr->process('emailfwd','create',[$email,$rd]); return $rc; } sub emailfwd_delete { my ($self,$ndr,$email)=@_; ## Technical syntax check of email object needed here my $rc=$ndr->process('emailfwd','delete',[$email]); return $rc; } sub emailfwd_update { my ($self,$ndr,$email,$tochange)=@_; my $fp=$ndr->protocol->nameversion(); ## Technical syntax check of email object needed here Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes'); foreach my $t ($tochange->types()) { next if $ndr->protocol_capable('emailfwd_update',$t); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of emailfwd_update/'.$t); } my $rc=$ndr->process('emailfwd','update',[$email,$tochange]); return $rc; } sub emailfwd_renew { my ($self,$ndr,$email,$rd)=@_; ## Technical syntax check of email object needed here Net::DRI::Util::check_isa($rd->{duration},'DateTime::Duration') if defined($rd->{duration}); Net::DRI::Util::check_isa($rd->{current_expiration},'DateTime') if defined($rd->{current_expiration}); return $ndr->process('emailfwd','renew',[$email,$rd->{duration},$rd->{current_expiration}]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/PT.pm0000644000175000017500000001042111352534376015701 0ustar patrickpatrick## Domain Registry Interface, Registry Driver for .PT ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::DRD::PT; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; use DateTime; use Net::DRI::Util; use Net::DRI::Data::Contact::FCCN; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/contact_check contact_delete contact_transfer contact_transfer_start contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse message_retrieve message_delete message_waiting message_count/); =pod =head1 NAME Net::DRI::DRD::PT - FCCN .PT Registry driver for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=1; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1,3,5); } sub name { return 'FCCN'; } sub tlds { return qw/pt net.pt org.pt edu.pt int.pt publ.pt com.pt nome.pt/; } sub object_types { return ('domain','contact'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::FCCN',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.nic.pt'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } sub set_factories { my ($self,$po)=@_; $po->factories('contact',sub { return Net::DRI::Data::Contact::FCCN->new(@_); }); } #################################################################################################### ## We can not start a transfer, if domain name has already been transfered less than 15 days ago. sub verify_duration_transfer { my ($self,$ndr,$duration,$domain,$op)=@_; ($duration,$domain,$op)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return 0 unless ($op eq 'start'); ## we are not interested by other cases, they are always OK my $rc=$self->domain_info($ndr,$domain,{hosts=>'none'}); return 1 unless ($rc->is_success()); my $trdate=$ndr->get_info('trDate'); return 0 unless ($trdate && $trdate->isa('DateTime')); my $now=DateTime->now(time_zone => $trdate->time_zone()->name()); my $cmp=DateTime->compare($now,$trdate+DateTime::Duration->new(days => 15)); return ($cmp == 1)? 0 : 1; ## we must have : now > transferdate + 15days ## we return 0 if OK, anything else if not } #################################################################################################### sub domain_renounce { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'renounce'); return $ndr->process('domain','renounce',[$domain,$rd]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/LC.pm0000644000175000017500000000527411352534376015666 0ustar patrickpatrick## Domain Registry Interface, Afilias ccTLD policies for .LC ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::LC; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::LC - .LC policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'Afilias LC'; } sub tlds { return qw/lc com.lc net.lc org.lc co.lc l.lc p.lc/; } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return; } #################################################################################################### ## http://www.afilias-grs.info/public/policies/lc ## http://www.nic.lc/rules.htm ## ## Superclass verify_name_domain is enough #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/ASIA.pm0000644000175000017500000000512311352534376016076 0ustar patrickpatrick## Domain Registry Interface, .ASIA policies ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::ASIA; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::ASIA - .ASIA policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E or Ehttp://oss.bsdprojects.net/project/netdri/E. =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'ASIA'; } sub tlds { return ('asia'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::ASIA',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.aero'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/CIRA.pm0000644000175000017500000000615011352534376016100 0ustar patrickpatrick## Domain Registry Interface, CIRA (.CA) Registry Driver ## ## Copyright (c) 2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::CIRA; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_transfer_stop domain_transfer_query domain_transfer_accept domain_transfer_refuse/); #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub name { return 'CIRA'; } sub tlds { return (qw/ca/); } sub object_types { return (qw/domain contact ns/); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::CIRA',{}) if $type eq 'epp'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name=>1,check_name_dots=>[1,2,3],my_tld_not_strict=>1}); } sub agreement_get { my ($self,$ndr,$language)=@_; Net::DRI::Exception::usererr_invalid_parameters('CIRA agreement language must be "en" or "fr"') if (defined $language && $language!~m/^(?:fr|en)$/); my $rc=$ndr->process('agreement','get',[$language]); return $rc; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::DRD::CIRA - CIRA (.CA) Registry driver for Net::DRI =head1 SYNOPSIS $dri=Net::DRI->new(); $dri->add_registry('CIRA'); =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/DRD/AG.pm0000644000175000017500000000714611352534376015657 0ustar patrickpatrick## Domain Registry Interface, Afilias ccTLD policies for .AG ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::AG; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Util; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::AG - .AG policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'Afilias AG'; } sub tlds { return qw/ag com.ag net.ag org.ag nom.ag co.ag/; } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return; } #################################################################################################### ## http://www.afilias-grs.info/public/policies/ag ## http://www.nic.ag/rules.htm ## http://www.nic.ag/reserved-names-policy.htm sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{ check_name => 1, my_tld => 1, no_double_hyphen => 1, ## http://www.nic.ag/reserved-names-policy.htm §1 no_country_code => 1,## http://www.nic.ag/reserved-names-policy.htm §6 no_digits_only => 1, ## http://www.nic.ag/reserved-names-policy.htm §4 excluded_labels => [qw/enum example localhost ns com edu ftp net whois wpad brand org tm co nom ac bd/], ## §7,8,9,10 ## Other names are banned in http://www.nic.ag/reserved-names-policy.htm §11,12 we do not implement all checks }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/HN.pm0000644000175000017500000000577311352534376015701 0ustar patrickpatrick## Domain Registry Interface, Afilias ccTLD policies for .HN ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::HN; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::HN - .HN policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'Afilias HN'; } sub tlds { return qw/hn com.hn net.hn org.hn edu.hn/; } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::Afilias',{}) if $type eq 'epp'; return; } #################################################################################################### ## http://www.afilias-grs.info/public/policies/hn ## http://www.nic.hn/politicas/sobre_dominios.html sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, min_length => 3, ## http://www.nic.hn/politicas/sobre_dominios.html §1.c }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/INFO.pm0000644000175000017500000000564311352534376016123 0ustar patrickpatrick## Domain Registry Interface, .INFO policies ## ## Copyright (c) 2006,2007,2008,2009 Rony Meyer . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::INFO; use strict; use warnings; use base qw/Net::DRI::DRD/; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD::INFO - .INFO policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Rony Meyer . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; bless($self,$class); return $self; } sub periods { return map { DateTime::Duration->new(years => $_) } (1..10); } sub name { return 'INFO'; } sub tlds { return ('info'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.afilias.info'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, icann_reserved => 1, }); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD/LU.pm0000644000175000017500000001434511352534376015707 0ustar patrickpatrick## Domain Registry Interface, .LU policy from DocRegistrar-2.0.6.pdf ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD::LU; use strict; use warnings; use base qw/Net::DRI::DRD/; use Net::DRI::Data::Contact::LU; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->make_exception_for_unavailable_operations(qw/domain_renew domain_transfer_accept domain_transfer_refuse contact_transfer contact_transfer_start contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse/); =pod =head1 NAME Net::DRI::DRD::LU - .LU policies for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(@_); $self->{info}->{host_as_attr}=0; $self->{info}->{contact_i18n}=1; ## LOC only bless($self,$class); return $self; } sub periods { return; } ## registry does not expect any duration at all sub name { return 'DNSLU'; } sub tlds { return ('lu'); } sub object_types { return ('domain','contact','ns'); } sub profile_types { return qw/epp whois/; } sub transport_protocol_default { my ($self,$type)=@_; return ('Net::DRI::Transport::Socket',{},'Net::DRI::Protocol::EPP::Extensions::LU',{}) if $type eq 'epp'; return ('Net::DRI::Transport::Socket',{remote_host=>'whois.dns.lu'},'Net::DRI::Protocol::Whois',{}) if $type eq 'whois'; return; } sub set_factories { my ($self,$po)=@_; $po->factories('contact',sub { return Net::DRI::Data::Contact::LU->new(@_); }); } #################################################################################################### sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name => 1, my_tld => 1, min_length => 3, no_double_hyphen => 1, }); } sub domain_status_allows { my ($self,$ndr,$domain,$what,$rd)=@_; return 0 unless ($what=~m/^(?:delete|update|transfer|renew|trade|transfer-trade|transfer-restore)$/); my $s=$self->domain_current_status($ndr,$domain,$rd); return 0 unless (defined($s)); return !$s->is_pending() && $s->can_delete() if ($what eq 'delete'); return !$s->is_pending() && $s->can_update() if ($what eq 'update'); ## no pendingCreate pendingUpdate pendingDelete return $s->can_transfer() if ($what eq 'transfer'); return 0 if ($what eq 'renew'); return $s->has_not('serverTradeProhibited','pendingCreate','pendingDelete') if ($what eq 'trade'); return $s->has_not('serverTransferProhibited','serverTradeProhibited') if ($what eq 'transfer-trade'); return $s->has_not('serverTransferProhibited','serverRestoreProhibited') && $s->has_any('pendingDelete') if ($what eq 'transfer-restore'); return 0; ## failsafe } sub domain_restore { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'restore'); return $ndr->process('domain','restore',[$domain]); } sub domain_trade_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); return $ndr->process('domain','trade_request',[$domain,$rd]); } sub domain_trade_query { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); return $ndr->process('domain','trade_query',[$domain]); } sub domain_trade_stop { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'trade'); return $ndr->process('domain','trade_cancel',[$domain]); } sub domain_transfer_trade_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_trade'); return $ndr->process('domain','transfer_trade_request',[$domain,$rd]); } sub domain_transfer_trade_query { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_trade'); return $ndr->process('domain','transfer_trade_query',[$domain]); } sub domain_transfer_trade_stop { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_trade'); return $ndr->process('domain','transfer_trade_cancel',[$domain]); } sub domain_transfer_restore_start { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_restore'); return $ndr->process('domain','transfer_restore_request',[$domain,$rd]); } sub domain_transfer_restore_query { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_restore'); return $ndr->process('domain','transfer_restore_query',[$domain]); } sub domain_transfer_restore_stop { my ($self,$ndr,$domain)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer_restore'); return $ndr->process('domain','transfer_restore_cancel',[$domain]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/BaseClass.pm0000644000175000017500000001027111352534376016610 0ustar patrickpatrick## Domain Registry Interface, Superclass of various classes for Net::DRI ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::BaseClass; use strict; use warnings; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/gxm); sprintf '%d'.('.%02d' x $#r), @r; }; #################################################################################################### ## CLASS METHODS sub make_exception_if_not_implemented { my ($self,@methods)=@_; my $class=ref $self || $self; foreach my $name (@methods) { no strict 'refs'; ## no critic (ProhibitNoStrict) *{"${class}::${name}"}=sub { my $self=shift; Net::DRI::Exception->die(1,'internal',1,sprintf('Method %s not implemented in %s, please report.',$name,ref $self)); }; } return; } sub make_exception_for_unavailable_operations { my ($self,@methods)=@_; my $class=ref $self || $self; foreach my $name (@methods) { my @op=split(/_/,$name,2); no strict 'refs'; ## no critic (ProhibitNoStrict) *{"${class}::${name}"}=sub { my $self=shift; Net::DRI::Exception->die(0,'DRD',4,sprintf('No operation %s %s available for registry %s',@op,$self->name())); }; } no strict 'refs'; ## no critic (ProhibitNoStrict) *{"${class}::unavailable_operations"}=sub { return @methods; }; return; } #################################################################################################### ## OBJECT METHODS sub generate_trid { my ($self,$name)=@_; if (! defined $name) { $name=$self->name(); } return $self->trid_factory()->($name); } sub log_setup_channel { my ($self,@r)=@_; $self->logging()->setup_channel(@r); } sub log_output { my ($self,@r)=@_; $self->logging()->output(@r); } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::BaseClass - Superclass of various classes inside Net::DRI =head1 VERSION This documentation refers to Net::DRI::BaseClass version 1.1 =head1 SYNOPSIS Not directly used by users, this is a purely internal class, never visible to the outside of Net::DRI. =head1 DESCRIPTION This is the superclass of some Net::DRI classes, providing various useful functions. =head1 EXAMPLES No user examples. =head1 SUBROUTINES/METHODS This is mostly a pure virtual superclass. =head1 DIAGNOSTICS None. =head1 CONFIGURATION AND ENVIRONMENT None. =head1 DEPENDENCIES This modules has to be used inside the Net::DRI framework and needs the following composants: =over =item L =back =head1 INCOMPATIBILITIES None =head1 BUGS AND LIMITATIONS No known bugs. Please report problems to author (see below) or use CPAN RT system. Patches are welcome. This should probably be better done with Moose and roles. It would however require a major overhaul to everything inside Net::DRI, so this would probably not happen very soon, maybe with a Perl6 port. This class was introduced very late in Net::DRI, multiple parts of this framework should be modified to take advantage of this class. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 LICENSE AND COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/0002755000175000017500000000000011352534417016210 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/0002755000175000017500000000000011352534417017030 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/WS.pm0000644000175000017500000000451611352534376017727 0ustar patrickpatrick## Domain Registry Interface, AFNIC Web Services Protocol ## ## Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::AFNIC::WS; use strict; use base qw(Net::DRI::Protocol); use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::AFNIC::WS::Message; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AFNIC::WS - AFNIC Web Services Protocol for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('afnic_ws'); $self->version($VERSION); $self->factories('message',sub { my $m=Net::DRI::Protocol::AFNIC::WS::Message->new(); $m->version($VERSION); return $m; }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; my @class=map { 'Net::DRI::Protocol::AFNIC::WS::'.$_ } ('Domain'); $self->SUPER::_load(@class); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/WS/0002755000175000017500000000000011352534417017361 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/WS/Domain.pm0000644000175000017500000000531411352534376021133 0ustar patrickpatrick## Domain Registry Interface, AFNIC Web Services Domain commands ## ## Copyright (c) 2005 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::AFNIC::WS::Domain; use strict; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AFNIC::WS::Domain - AFNIC Web Services Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ########################################################## sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], ); return { 'domain' => \%tmp }; } sub build_msg { my ($msg,$command,$domain)=@_; Net::DRI::Exception->die(1,'protocol/afnic/ws',2,"Domain name needed") unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/afnic/ws',10,"Invalid domain name") unless ($domain=~m/^[a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?\.[a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?$/i); ## from RRP grammar $msg->method($command) if defined($command); } sub check { my ($po,$domain)=@_; my $msg=$po->message(); build_msg($msg,'check_domain',$domain); $msg->params([$domain]); $msg->service('Domain'); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); ## { free => 0|1, reason => \d+, message => '' } $rinfo->{domain}->{$oname}->{exist}=1-($r->{free}); } ######################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/WS/Message.pm0000644000175000017500000001075211352534376021312 0ustar patrickpatrick## Domain Registry Interface, AFNIC WS Message ## ## Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::AFNIC::WS::Message; use strict; use Net::DRI::Protocol::ResultStatus; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version service method params result errcode)); our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AFNIC::WS::Message - AFNIC Web Services Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self={errcode => undef}; bless($self,$class); $self->params([]); ## default my $rh=shift; if (defined($rh) && (ref($rh) eq 'HASH')) { $self->service($rh->{service}) if exists($rh->{service}); $self->method($rh->{method}) if exists($rh->{method}); $self->params($rh->{params}) if exists($rh->{params}); } return $self; } sub as_string { my ($self)=@_; my @p=@{$self->params()}; my @pr; foreach my $i (0..$#p) { push @pr,sprintf 'PARAM%d=%s',$i+1,$p[$i]; } return sprintf "SERVICE=%s\nMETHOD=%s\n%s\n",$self->service(),$self->method(),join("\n",@pr); } sub parse { my ($self,$r)=@_; $self->result($r); my $c; $c=$r->{reason} if (defined($r) && ref($r) && exists($r->{reason})); $self->errcode($c); ## Warning: when we handle multiple web services, we will need a way to retrieve the method name called, ## to find the correct errcode, as it will obviously not be done the same way accross all services. } ## We handle all non free cases as errors, even if we should not sub is_success { my $self=shift; my $r=$self->result(); my $code=$self->errcode(); return 1 if ($r->{free}); return 0; } sub result_status { my $self=shift; my $r=$self->result(); return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL',$r->{message}) if ($r->{free}); my %codes=( 0 => 2400, # problème de connexion à la base de données => Command failed 1 => 2302, # le nom de domaine est déjà enregistré => Object exists 2 => 2308, # un nom de domaine est déjà enregistré à l'identique dans l'une des extensions du domaine public => Data management policy violation 4 => 2304, # une opération est en cours pour ce nom de domaine => Object status prohibits operation 5 => 2308, # nom de domaine interdit (termes fondamentaux) => Data management policy violation 51 => 2308, # nom de domaine réservé pour les communes => Data management policy violation 100 => 2005, # mauvaise syntaxe du nom de domaine => Parameter value syntax error ); my $code=$self->errcode(); my $eppcode=(!defined($code) || $code >=1000 || !exists($codes{$code}))? 'GENERIC_ERROR' : $codes{$code}; return Net::DRI::Protocol::ResultStatus->new('afnic_ws_check_domain',$code,$eppcode,$self->is_success(),$r->{message}); ## Warning: when we handle multiple web services, we will need a way to retrieve the method name called, ## to find the correct key of the hash (and special case of free <=> 2303) } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/Email/0002755000175000017500000000000011352534417020057 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/Email/Domain.pm0000644000175000017500000003142011352534376021626 0ustar patrickpatrick## Domain Registry Interface, AFNIC Email Domain commands ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::AFNIC::Email::Domain; use strict; use warnings; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AFNIC::Email::Domain - AFNIC Email Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], ## TODO : parsing of return messages delete => [ \&delete, undef ], update => [ \&update, undef ], transfer_request => [ \&transfer_request, undef], trade => [ \&trade, undef], ); return { 'domain' => \%tmp }; } ## AFNIC says international format is : +code_pays 10 20 30 40 50 ## yeah right ! sub format_tel { my $in=shift; $in=~s/x.*$//; my @t=split(/\./,$in,2); return $t[0].' '.reverse(join(' ',grep { defined($_) && $_ ne '' } split(/(\d{2})/,reverse($t[1])))); } sub add_starting_block { my ($action,$domain,$mes,$rd)=@_; my $ca=$mes->client_auth(); $mes->line('1a',$action); $mes->line('1b',$ca->{id}); ## code fournisseur $mes->line('1c',$ca->{pw}); ## mot de passe $mes->line('1e',$mes->trid()); ## reference client (=trid) ## allow more/other ? $mes->line('1f','2.5.0'); $mes->line('1g',$rd->{auth_code}) if ($action=~m/^[CD]$/ && Net::DRI::Util::has_key($rd,'auth_code') && $rd->{auth_code}); ## authorization code for reserved domain names $mes->line('2a',$domain); } sub create { my ($a,$domain,$rd)=@_; my $mes=$a->message(); add_starting_block('C',$domain,$mes,$rd); Net::DRI::Exception::usererr_insufficient_parameters('authInfo is mandatory') unless Net::DRI::Util::has_auth($rd); $mes->line('2z',$rd->{auth}->{pw}); Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory') unless Net::DRI::Util::has_contact($rd); my $cs=$rd->{contact}; my $co=$cs->get('registrant'); Net::DRI::Exception::usererr_insufficient_parameters('registrant contact is mandatory') unless Net::DRI::Util::isa_contact($co,'Net::DRI::Data::Contact::AFNIC'); $co->validate(); $co->validate_registrant(); if ($co->legal_form()) ## PM { $mes->line('3w','PM'); add_company_info($mes,$co); } else ## PP { $mes->line('3w','PP'); Net::DRI::Exception::usererr_insufficient_parameters('name or key needed for PP') unless ($co->name() || $co->key()); if ($co->key()) { $mes->line('3q',$co->key()); } else { $mes->line('3a',sprintf('%s, %s',$co->firstname(),$co->name())); my $b=$co->birth(); Net::DRI::Exception::usererr_insufficient_parameters('birth data (date+city) mandatory, if no registrant key provided') unless ($b && (ref($b) eq 'HASH') && exists($b->{date}) && exists($b->{place})); $mes->line('3r',(ref($b->{date}))? $b->{date}->strftime('%d/%m/%Y') : $b->{date}); $mes->line('3s',$b->{place}); } } add_owner_info($mes,$co); add_maintainer_disclose($mes,$co,$rd->{maintainer}) unless $mes->line('3x'); add_admin_contact($mes,$cs); ## optional add_tech_contacts($mes,$cs); ## mandatory add_all_ns($domain,$mes,$rd->{ns}) if Net::DRI::Util::has_ns($rd); add_installation($mes,$rd); } sub add_company_info { my ($mes,$co)=@_; $mes->line('3a',$co->name()); Net::DRI::Exception::usererr_insufficient_parameters('one legal form must be provided') unless ($co->legal_form() || $co->legal_form_other()); $mes->line('3h',$co->legal_form()) if $co->legal_form(); $mes->line('3i',$co->legal_form_other()) if $co->legal_form_other(); Net::DRI::Exception::usererr_insufficient_parameters('legal id must be provided if no trademark') if (($co->legal_form() eq 'S') && !$co->trademark() && !$co->legal_id()); $mes->line('3j',$co->legal_id()) if $co->legal_id(); my $jo=$co->jo(); Net::DRI::Exception::usererr_insufficient_parameters('jo data is needed for non profit organization without legal id or trademark') if (($co->legal_form() eq 'A') && !$co->legal_id() && !$co->trademark() && (!$jo || (ref($jo) ne 'HASH') || !exists($jo->{date_publication}) || !exists($jo->{page}))); if ($jo && (ref($jo) eq 'HASH')) { $mes->line('3k',$jo->{date_declaration}) if (exists($jo->{date_declaration}) && $jo->{date_declaration}); $mes->line('3l',$jo->{date_publication}) if (exists($jo->{date_publication}) && $jo->{date_publication}); $mes->line('3m',$jo->{number}) if (exists($jo->{number}) && $jo->{number}); $mes->line('3n',$jo->{page}) if (exists($jo->{page}) && $jo->{page}); } $mes->line('3p',$co->trademark()) if $co->trademark(); } sub add_installation { my ($mes,$rd)=@_; ## Default = A = waiting for client, otherwise I = direct installation my $inst=(Net::DRI::Util::has_key($rd,'installation_type') && $rd->{installation_type}=~m/^[IA]$/)? $rd->{installation_type} : 'A'; $mes->line('8a',$inst); ## S = standard = fax need to be sent, Default = E = Express = no fax my $form=(Net::DRI::Util::has_key($rd,'form_type') && $rd->{form_type}=~m/^[SE]$/)? $rd->{form_type} : 'E'; $mes->line('9a',$form); } sub add_owner_info { my ($mes,$co)=@_; if ($co->srid()) { $mes->line('3x',$co->srid().'-FRNIC'); } else { my $s=$co->street(); Net::DRI::Exception::usererr_insufficient_parameters('1 line of address at least needed if no nichandle') unless ($s && (ref($s) eq 'ARRAY') && @$s && $s->[0]); $mes->line('3b',$s->[0]); $mes->line('3c',$s->[1]) if $s->[1]; $mes->line('3d',$s->[2]) if $s->[2]; Net::DRI::Exception::usererr_insufficient_parameters('city, pc & cc mandatory if no nichandle') unless ($co->city() && $co->pc() && $co->cc()); $mes->line('3e',$co->city()); $mes->line('3f',$co->pc()); $mes->line('3g',uc($co->cc())); Net::DRI::Exception::usererr_insufficient_parameters('voice & email mandatory if no nichandle') unless ($co->voice() && $co->email()); $mes->line('3t',format_tel($co->voice())); $mes->line('3u',format_tel($co->fax())) if $co->fax(); $mes->line('3v',$co->email()); } } sub add_maintainer_disclose { my ($mes,$co,$maintainer)=@_; Net::DRI::Exception::usererr_insufficient_parameters('maintainer mandatory if no nichandle') unless (defined($maintainer) && $maintainer=~m/^[A-Z0-9][-A-Z0-9]+[A-Z0-9]$/i); $mes->line('3y',$maintainer); Net::DRI::Exception::usererr_insufficient_parameters('disclose option is mandatory if no nichandle') unless ($co->disclose()); $mes->line('3z',$co->disclose()); } sub add_admin_contact { my ($mes,$cs)=@_; my $co=$cs->get('admin'); $mes->line('4a',$co->srid().'-FRNIC') if (Net::DRI::Util::isa_contact($co) && $co->srid()); } sub add_tech_contacts { my ($mes,$cs)=@_; my @co=map { $_->srid() } grep { Net::DRI::Util::isa_contact($_) && defined $_->srid() } $cs->get('tech'); Net::DRI::Exception::usererr_insufficient_parameters('at least one technical contact is mandatory') unless @co; $mes->line('5a',$co[0].'-FRNIC'); $mes->line('5c',$co[1].'-FRNIC') if $co[1]; $mes->line('5e',$co[2].'-FRNIC') if $co[2]; } sub add_all_ns { my ($domain,$mes,$ns)=@_; Net::DRI::Exception::usererr_insufficient_parameters('at least 2 nameservers are mandatory') unless (Net::DRI::Util::isa_hosts($ns,'Net::DRI::Data::Hosts') && $ns->count()>=2); add_one_ns($mes,$ns,1,$domain,'6a','6b'); add_one_ns($mes,$ns,2,$domain,'7a','7b'); my $nsc=$ns->count(); add_one_ns($mes,$ns,3,$domain,'7c','7d') if ($nsc >= 3); add_one_ns($mes,$ns,4,$domain,'7e','7f') if ($nsc >= 4); add_one_ns($mes,$ns,5,$domain,'7g','7h') if ($nsc >= 5); add_one_ns($mes,$ns,6,$domain,'7i','7j') if ($nsc >= 6); add_one_ns($mes,$ns,7,$domain,'7k','7l') if ($nsc >= 7); add_one_ns($mes,$ns,8,$domain,'7m','7n') if ($nsc >= 8); } sub add_one_ns { my ($mes,$ns,$pos,$domain,$l1,$l2)=@_; my @g=$ns->get_details($pos); return unless @g; $mes->line($l1,$g[0]); ## name return unless ($g[0]=~m/\S+\.${domain}/i || (lc($g[0]) eq lc($domain))); $mes->line($l2,join(' ',@{$g[1]},@{$g[2]})); ## nameserver in domain, we add IPs } sub delete { my ($a,$domain,$rd)=@_; my $mes=$a->message(); add_starting_block('S',$domain,$mes,$rd); add_installation($mes,$rd); } sub update { my ($a,$domain,$todo,$rd)=@_; my $mes=$a->message(); Net::DRI::Util::check_isa($todo,'Net::DRI::Data::Changes'); if ((grep { ! /^(?:ns|contact)/ } $todo->types()) || (grep { ! /^(?:set)$/ } $todo->types('ns')) || (grep { ! /^(?:set)$/ } $todo->types('contact')) ) { Net::DRI::Exception->die(0,'protocol/AFNIC/Email',11,'Only ns/contact set available for domain'); } my $ns=$todo->set('ns'); my $cs=$todo->set('contact'); my $wc=Net::DRI::Util::isa_contactset($cs); Net::DRI::Exception::usererr_invalid_parameters('can not change both admin & tech contacts at the same time') if ($wc && $cs->has_type('tech') && ($cs->has_type('admin') || $cs->has_type('registrant'))); ## Technical change (DNS / Tech contacts) if ($wc && $cs->has_type('tech')) { add_starting_block('T',$domain,$mes); ## no $rd here ! add_tech_contacts($mes,$cs); ## tech contacts mandatory even for only nameserver changes ! add_all_ns($domain,$mes,$ns) if (defined $ns && Net::DRI::Util::isa_hosts($ns,'Net::DRI::Data::Hosts')); add_installation($mes,$rd); return; } ## Admin change (Admin contact) if ($wc && ($cs->has_type('admin') || $cs->has_type('registrant'))) { add_starting_block('A',$domain,$mes); my $co=$cs->get('registrant'); if (Net::DRI::Util::isa_contact($co) && $co->legal_form()) ## only for PM { $co->validate(); $mes->line('3a',$co->name()); add_owner_info($mes,$co); } else { my $ca=$cs->get('admin'); Net::DRI::Exception::usererr_insufficient_parameters('contact admin is mandatory for PP admin change') unless (Net::DRI::Util::isa_contact($ca) && $ca->srid()); } add_admin_contact($mes,$cs); add_installation($mes,$rd); return; } Net::DRI::Exception::err_assert('We do not know how to handle this kind of update, please report.'); } sub trade { my ($a,$domain,$rd)=@_; my $mes=$a->message(); create($a,$domain,$rd); my $type=(Net::DRI::Util::has_key($rd,'trade_type') && $rd->{trade_type}=~m/^[VF]$/)? $rd->{trade_type} : 'V'; $mes->line('1a','P'); $mes->line('1h',$type); if ($type eq 'F') { Net::DRI::Exception::usererr_insufficient_parameters('authInfo is mandatory') unless Net::DRI::Util::has_auth($rd); $mes->line('2z',$rd->{auth}->{pw}); } } sub transfer_request { my ($a,$domain,$rd)=@_; my $mes=$a->message(); add_starting_block('D',$domain,$mes,$rd); Net::DRI::Exception::usererr_invalid_parameters() unless (defined($rd) && (ref($rd) eq 'HASH') && keys(%$rd)); Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory') unless Net::DRI::Util::has_contact($rd); my $cs=$rd->{contact}; my $co=$cs->get('registrant'); Net::DRI::Exception::usererr_insufficient_parameters('registrant contact is mandatory') unless Net::DRI::Util::isa_contact($co,'Net::DRI::Data::Contact::AFNIC'); $co->validate(); $co->validate_registrant(); Net::DRI::Exception::usererr_insufficient_parameters('authInfo is mandatory') unless Net::DRI::Util::has_auth($rd); $mes->line('2z',$rd->{auth}->{pw}); if ($co->legal_form()) ## PM { add_company_info($mes,$co); } else ## PP { Net::DRI::Exception::usererr_insufficient_parameters('key mandatory for PP') unless ($co->key()); $mes->line('3q',$co->key()); } add_tech_contacts($mes,$cs); ## tech contacts mandatory add_all_ns($domain,$mes,$rd->{ns}) if Net::DRI::Util::has_ns($rd); add_installation($mes,$rd); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/Email/Message.pm0000644000175000017500000000751611352534376022014 0ustar patrickpatrick## Domain Registry Interface, AFNIC Email Message ## ## Copyright (c) 2006,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::AFNIC::Email::Message; use strict; use warnings; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version trid email_from client_auth)); use MIME::Entity (); use Net::DRI::Protocol::ResultStatus; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AFNIC::Email::Message - AFNIC Email Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $proto=shift; my $class=ref($proto) || $proto; my ($trid,$otype,$oaction)=@_; my $self={ version => '2.0.0', lines => {}, trid => $trid, generated_for => $otype.'_'.$oaction }; bless($self,$class); return $self; } sub line { my ($self,$champ,$data)=@_; return unless defined($champ) && $champ; if (defined($data)) { $self->{lines}->{$champ}=$data; } return unless exists($self->{lines}->{$champ}); return $self->{lines}->{$champ}; } sub email_body { my ($self)=@_; my @l; foreach my $c (sort {$a cmp $b} keys(%{$self->{lines}})) { push @l,sprintf('%s..: %s',$c,$self->{lines}->{$c}); } return Net::DRI::Util::encode('iso-8859-15',join("\n",@l)."\n"); } sub as_mime { my ($self)=@_; my $m=MIME::Entity->build(From => $self->email_from(), To => 'domain@nic.fr', Data => $self->email_body(), Type => 'text/plain', Charset => 'iso-8859-15', Disposition => 'inline', Encoding => '8bit', ); ## Message-ID ? Reply-To ? ## If needed, then probably pass a ref hash as email header template, with keys from, to, message-id, reply-to, subject & so on ## Values would be a string or a code ref that generate the correct string based on some parameters (like the message itself) ## Subject : ClientID + Name of operation attempted + TRID $m->head->replace('Subject',sprintf('%s %s [%s]',$self->client_auth()->{id},$self->{generated_for},$self->trid())); $m->head->replace('X-Mailer',sprintf('Net::DRI %s/%s via %s',$Net::DRI::VERSION,$VERSION,$m->head->get('X-Mailer'))); return $m; } sub as_string { my $self=shift; my $m=$self->as_mime(); return $m->as_string(); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AFNIC/Email.pm0000644000175000017500000000625411352534376020426 0ustar patrickpatrick## Domain Registry Interface, AFNIC Email Protocol ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::AFNIC::Email; use strict; use base qw(Net::DRI::Protocol); use Email::Valid; use Net::DRI::Exception; use Net::DRI::Protocol::AFNIC::Email::Message; use Net::DRI::Data::Contact::AFNIC; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AFNIC::Email - AFNIC Email Protocol for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $clientid=$rp->{username}; my $clientpw=$rp->{password}; my $emailfrom=$rp->{email_from}; Net::DRI::Exception::usererr_insufficient_parameters('client id must be defined') unless $clientid; Net::DRI::Exception::usererr_insufficient_parameters('client password must be defined') unless $clientpw; Net::DRI::Exception::usererr_insufficient_parameters('from email must be defined') unless $emailfrom; Net::DRI::Exception::usererr_invalid_parameters($emailfrom.' is not a valid email address') unless Email::Valid->rfc822($emailfrom); my $self=$c->SUPER::new(); $self->name('afnic_email'); $self->version($VERSION); foreach my $o (qw/ns contact/) { $self->capabilities('domain_update',$o,['set']); } ## no registrant, as there is a separate trade() call $self->factories('message',sub { my $m=Net::DRI::Protocol::AFNIC::Email::Message->new(@_); $m->client_auth({id => $clientid, pw => $clientpw}); $m->email_from($emailfrom); return $m; }); $self->factories('contact',sub { return Net::DRI::Data::Contact::AFNIC->new(); }); $self->_load(); return $self; } sub _load { my ($self)=@_; my @class=map { 'Net::DRI::Protocol::AFNIC::Email::'.$_ } ('Domain'); $self->SUPER::_load(@class); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRP/0002755000175000017500000000000011352534417016653 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/RRP/Connection.pm0000644000175000017500000001132511352534376021314 0ustar patrickpatrick## Domain Registry Interface, RRP Connection handling ## ## Copyright (c) 2005,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::RRP::Connection; use strict; use Net::DRI::Protocol::RRP::Message; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Data::Raw; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.17 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRP::Connection - RRP Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub login { my ($class,$cm,$id,$pass,$cltrid,$dr,$newpass)=@_; my %h=(Id => $id, Password => $pass); $h{NewPassword}=$newpass if (defined($newpass) && $newpass); my $mes=Net::DRI::Protocol::RRP::Message->new({ command => 'session', options => \%h}); return $mes; } sub logout { my ($class,$cm,$cltrid)=@_; my $mes=Net::DRI::Protocol::RRP::Message->new({ command => 'quit' }); return $mes; } sub keepalive { my ($class,$cm,$cltrid)=@_; my $mes=Net::DRI::Protocol::RRP::Message->new({ command => 'describe' }); return $mes; } #################################################################################################### sub read_data { my ($class,$to,$sock)=@_; my (@l); while(my $l=$sock->getline()) { push @l,$l; last if ($l=~m/^\.\s*\n?$/); } @l=map { Net::DRI::Util::decode_ascii($_); } @l; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING',@l? $l[0] : '','en')) unless (@l && $l[-1]=~m/^\.\s*\n?$/); return Net::DRI::Data::Raw->new_from_array(\@l); } sub write_message { my ($self,$to,$msg)=@_; return Net::DRI::Util::encode_ascii($msg); } sub parse_greeting { my ($class,$dc)=@_; my ($code,$msg)=find_code($dc); unless (defined($code) && ($code==0)) { return Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR',($msg || '?').' ('.($code || '?').')','en'); } else { return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL','Greeting OK','en'); } } sub parse_login { my ($class,$dc)=@_; my ($code,$msg)=find_code($dc); unless (defined($code) && ($code==200)) { my $eppcode=(defined($code))? Net::DRI::Protocol::RRP::Message::_eppcode($code) : 'COMMAND_SYNTAX_ERROR'; return Net::DRI::Protocol::ResultStatus->new_error($eppcode,($msg || 'Login failed').' ('.($code || '?').')','en'); } else { return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL',$msg || 'Login OK','en'); } } sub parse_logout { my ($class,$dc)=@_; my ($code,$msg)=find_code($dc); unless (defined($code) && ($code==220)) { my $eppcode=(defined($code))? Net::DRI::Protocol::RRP::Message::_eppcode($code) : 'COMMAND_SYNTAX_ERROR'; return Net::DRI::Protocol::ResultStatus->new_error($eppcode,($msg || 'Logout failed').' ('.($code || '?').')','en'); } else { return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL_END ',$msg || 'Logout OK','en'); } } sub find_code { my $dc=shift; my @a=$dc->as_array(); return (0,'LOGIN') if ($a[0]=~m/^.+ RRP Server version/); ## initial login return () unless $#a>0; ## at least 2 lines return () unless $a[-1]=~m/^\.\s*\n?$/; return () unless $a[0]=~m/^(\d+) (\S.+)$/; return (0+$1,$2); } sub transport_default { my ($self,$tname)=@_; return (defer => 0, socktype => 'ssl', ssl_cipher_list => 'TLSv1', remote_port => 648); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRP/Core/0002755000175000017500000000000011352534417017543 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/RRP/Core/Status.pm0000644000175000017500000000615011352534376021370 0ustar patrickpatrick## Domain Registry Interface, RRP Status ## ## Copyright (c) 2005 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::RRP::Core::Status; use base qw!Net::DRI::Data::StatusList!; use Net::DRI::Exception; use strict; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRP::Core::Status - RRP Status for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ####################################################################################### sub new { my $proto=shift; my $class=ref($proto) || $proto; my $self=$class->SUPER::new('rrp','2.0'); bless($self,$class); my %s=('delete' => 'REGISTRAR-LOCK', 'update' => 'REGISTRAR-LOCK', 'transfer' => 'REGISTRAR-LOCK', 'publish' => 'REGISTRAR-HOLD', ); $self->_register_pno(\%s); my $msg=shift; return $self unless defined($msg); if (ref($msg) eq 'Net::DRI::Protocol::RRP::Message') { my @s=$msg->entities('status'); $self->add(@s) if (@s); } else { Net::DRI::Exception::err_invalid_parameters(); } return $self; } sub is_active { return shift->has_any('ACTIVE'); } sub is_published { return ! shift->has_any('REGISTRY-HOLD','REGISTRAR-HOLD'); } sub is_pending { return shift->has_any('REGISTRY-DELETE-NOTIFY','PENDINGRESTORE','PENDINGDELETE','PENDINGTRANSFER'); } sub is_linked { return shift->has_any('REGISTRY-DELETE-NOTIFY'); } sub can_update { return ! shift->has_any('REGISTRY-LOCK','REGISTRY-HOLD','REGISTRAR-HOLD','REGISTRAR-LOCK','REGISTRY-DELETE-NOTIFY','PENDINGRESTORE','PENDINGDELETE','PENDINGTRANSFER'); } sub can_transfer { return shift->can_update(); } sub can_delete { return shift->can_update(); } sub can_renew { return ! shift->has_any('REGISTRY-DELETE-NOTIFY','REDEMPTIONPERIOD','PENDINGRESTORE','PENDINGDELETE','PENDINGTRANSFER'); } ####################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRP/Core/Host.pm0000644000175000017500000001321611352534376021023 0ustar patrickpatrick## Domain Registry Interface, RRP Host commands ## ## Copyright (c) 2005,2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::RRP::Core::Host; use strict; use Net::DRI::Protocol::RRP; use Net::DRI::Data::Hosts; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.10 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRP::Core::Host - RRP Host commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ######################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&add ], check => [ \&check, \&check_parse ], info => [ \&status, \&status_parse ], delete => [ \&del ], update => [ \&mod ], ); return { 'host' => \%tmp }; } sub build_msg { my ($msg,$command,$hostname)=@_; ($hostname)=$hostname->get_names(1) if (defined($hostname) && ref($hostname)); Net::DRI::Exception->die(1,'protocol/RRP',3,"Host name needed") unless defined($hostname) && $hostname; Net::DRI::Exception->die(1,'protocol/RRP',10,"Invalid host name") unless ($hostname=~m/^([a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?\.)*[a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?\.[a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?$/i); ## from RRP grammar $msg->command($command) if defined($command); $msg->entities('EntityName','NameServer'); $msg->entities('NameServer',uc($hostname)); } sub add { my ($rrp,$ns)=@_; my $mes=$rrp->message(); build_msg($mes,'add',$ns); add_ip($mes,$ns,$rrp->version()); } sub _basic_command { my ($command,$rrp,$ns)=@_; my $mes=$rrp->message(); build_msg($mes,$command,$ns); } sub check { return _basic_command('check',@_); } sub status { return _basic_command('status',@_); } sub del { return _basic_command('del',@_); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); $rinfo->{host}->{$oname}->{action}='check'; if ($mes->errcode() == 213) ## nameserver exists { my @ip=$mes->entities('ipaddress'); $rinfo->{host}->{$oname}->{self}=Net::DRI::Data::Hosts->new($oname,\@ip); $rinfo->{host}->{$oname}->{exist}=1; } elsif ($mes->errcode() == 212) ## nameserver available { $rinfo->{host}->{$oname}->{exist}=0; } } sub status_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); ## if operation succeeds, information should be there $rinfo->{host}->{$oname}->{exist}=1; $rinfo->{host}->{$oname}->{action}='info'; while(my ($k,$v)=each(%Net::DRI::Protocol::RRP::DATES)) { my $d=$mes->entities($k); next unless $d; $rinfo->{host}->{$oname}->{$v}=$po->{dt_parse}->parse_datetime($d); } while(my ($k,$v)=each(%Net::DRI::Protocol::RRP::IDS)) { my $d=$mes->entities($k); next unless $d; $rinfo->{host}->{$oname}->{$v}=$d; } my @ip=$mes->entities('ipaddress'); $rinfo->{host}->{$oname}->{self}=Net::DRI::Data::Hosts->new($oname,\@ip); } sub mod { my ($rrp,$hostname,$todo)=@_; my $mes=$rrp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:ip|name)$/ } $todo->types()) || (grep { ! /^(?:add|del)$/ } $todo->types('ip')) || (grep { ! /^(?:set)$/ } $todo->types('name')) ) { Net::DRI::Exception->die(0,'protocol/RRP',11,'Only IP add/del or name set available for host'); } my $nsadd=$todo->add('ip'); my $nsdel=$todo->del('ip'); my $newname=$todo->set('name'); unless (defined($hostname) && $hostname) { $hostname=$nsadd->get_names(1) if (defined($nsadd) && ref($nsadd) && $nsadd->can('get_names')); $hostname=$nsdel->get_names(1) if (defined($nsdel) && ref($nsdel) && $nsdel->can('get_names')); } build_msg($mes,'mod',$hostname); my $version=$rrp->version(); add_ip($mes,$nsadd,$version); add_ip($mes,$nsdel,$version,'='); $mes->entities('NewNameServer',ref($newname)? $newname->get_names(1) : $newname) if (defined($newname) && $newname); } sub add_ip { my ($mes,$ns,$version,$extra)=@_; $extra||=''; return unless (defined($ns) && ref($ns)); my ($name,$r4,$r6)=$ns->get_details(1); my $c=1; foreach my $ip (@$r4) { last if $c++>13; $mes->entities('IPAddress',$_.$extra); }; $c=1; if ($version eq '2.0') { foreach my $ip (@$r6) { last if $c++>13; $mes->entities('IPAddress',$_.$extra); } } } ######################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRP/Core/Session.pm0000644000175000017500000000553711352534376021540 0ustar patrickpatrick## Domain Registry Interface, RRP Session commands ## ## Copyright (c) 2005 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::RRP::Core::Session; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRP::Core::Session - RRP Session commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ############################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( _describe => [ \&describe, \&describe_parse ], logout => [ \&quit ], login => [ \&session ], ); $tmp{noop}=$tmp{_describe}; ## alias for keepalive return { 'session' => \%tmp }; } sub describe { my ($rrp,$what)=@_; my $mes=$rrp->message(); $mes->command('describe'); $mes->options('Target',$what) if $what; } sub describe_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); $rinfo->{session}->{describe}->{protocol}=$mes->entities('protocol'); } sub quit { my ($rrp)=@_; my $mes=$rrp->message(); $mes->command('quit'); } sub session { my ($rrp,$id,$pass,$newpass)=@_; Net::DRI::Exception::usererr_insufficient_parameters('login & password') unless (defined($id) && $id && defined($pass) && $pass); my $mes=$rrp->message(); $mes->command('session'); $mes->options('Id',$id); $mes->options('Password',$pass); $mes->options('NewPassword',$newpass) if (defined($newpass) && $newpass && ($newpass ne $pass)); } ############################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRP/Core/Domain.pm0000644000175000017500000001756611352534376021331 0ustar patrickpatrick## Domain Registry Interface, RRP Domain commands ## ## Copyright (c) 2005,2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::RRP::Core::Domain; use strict; use Net::DRI::Data::Hosts; use Net::DRI::Protocol::RRP::Core::Status; use Net::DRI::Protocol::RRP; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.12 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRP::Core::Domain - RRP Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ########################################################## sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&add, \&add_parse ], check => [ \&check, \&check_parse ], info => [ \&status, \&status_parse ], delete => [ \&del ], renew => [ \&renew, \&renew_parse ], update => [ \&mod ], transfer_request => [ \&transfer_request ], transfer_answer => [ \&transfer_answer ], ); $tmp{transfer_cancel}=[ \&transfer_answer ] if ($version eq "2.0"); return { 'domain' => \%tmp }; } sub build_msg { my ($msg,$command,$domain)=@_; Net::DRI::Exception->die(1,'protocol/RRP',2,"Domain name needed") unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/RRP',10,"Invalid domain name") unless ($domain=~m/^[a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?\.[a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?$/i); ## from RRP grammar $msg->command($command) if defined($command); $msg->entities('EntityName','Domain'); $msg->entities('DomainName',uc($domain)); } sub add { my ($rrp,$domain,$rd)=@_; my $mes=$rrp->message(); build_msg($mes,'add',$domain); ## (MAY) if (Net::DRI::Util::has_duration($rd)) { my $period=$rd->{duration}->years(); Net::DRI::Exceptions::usererr_invalid_parameters('period must be an integer') unless Net::DRI::Util::isint($period); $mes->options('Period',$period); } ## (MAY) 1 to 13 nameservers if (Net::DRI::Util::has_ns($rd)) { foreach ($rd->{ns}->get_names(13)) { $mes->entities('NameServer',$_); } } } sub add_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); ## Create a new DataTime object my $d='registration expiration date'; $rinfo->{domain}->{$oname}->{$Net::DRI::Protocol::RRP::DATES{$d}}=$po->{dt_parse}->parse_datetime($mes->entities($d)); $rinfo->{domain}->{$oname}->{status}=Net::DRI::Protocol::RRP::Core::Status->new($mes); $rinfo->{domain}->{$oname}->{exist}=1; $rinfo->{domain}->{$oname}->{action}='create'; } sub renew_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; add_parse($po,$otype,$oaction,$oname,$rinfo); $rinfo->{domain}->{$oname}->{action}='renew' if (exists($rinfo->{domain}->{$oname}->{action})); } sub _basic_command { my ($command,$rrp,$domain)=@_; my $mes=$rrp->message(); build_msg($mes,$command,$domain); } sub check { return _basic_command('check',@_); } sub status { return _basic_command('status',@_); } sub del { return _basic_command('del',@_); } sub transfer_request { return _basic_command('transfer',@_);} sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); if ($mes->errcode() == 211) ## domain exists { $rinfo->{domain}->{$oname}->{exist}=1; } elsif ($mes->errcode() == 210) ## domain available { $rinfo->{domain}->{$oname}->{exist}=0; } $rinfo->{domain}->{$oname}->{action}='check'; } sub status_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{exist}=1; $rinfo->{domain}->{$oname}->{action}='info'; while(my ($k,$v)=each(%Net::DRI::Protocol::RRP::DATES)) { my $d=$mes->entities($k); next unless $d; $rinfo->{domain}->{$oname}->{$v}=$po->{dt_parse}->parse_datetime($d); } while(my ($k,$v)=each(%Net::DRI::Protocol::RRP::IDS)) { my $d=$mes->entities($k); next unless $d; $rinfo->{domain}->{$oname}->{$v}=$d; } $rinfo->{domain}->{$oname}->{status}=Net::DRI::Protocol::RRP::Core::Status->new($mes); my @ns=$mes->entities('nameserver'); $rinfo->{domain}->{$oname}->{ns}=Net::DRI::Data::Hosts->new_set(@ns); } sub transfer_answer { my ($rrp,$domain,$rd)=@_; my $mes=$rrp->message(); build_msg($mes,'transfer',$domain); $mes->entities('Approve',(defined($rd) && ref($rd) && exists($rd->{approve}) && $rd->{approve})? 'Yes' : 'No'); } sub mod { my ($rrp,$domain,$todo)=@_; my $mes=$rrp->message(); build_msg($mes,'mod',$domain); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:ns|status)$/ } $todo->types()) || (grep { ! /^(?:add|del)$/ } $todo->types('ns')) || (grep { ! /^(?:add|del)$/ } $todo->types('status')) ) { Net::DRI::Exception->die(0,'protocol/RRP',11,'Only ns/status add/del available for domain'); } my $nsadd=$todo->add('ns'); my $nsdel=$todo->del('ns'); my $statadd=$todo->add('status'); my $statdel=$todo->del('status'); ## $nsadd/$nsdel are Net::DRI::Data::Hosts objects ## Up to 13 nameservers only if (defined($nsadd) && !$nsadd->is_empty()) { foreach ($nsadd->get_names(13)) { $mes->entities('NameServer',$_) } } if (defined($nsdel) && !$nsdel->is_empty()) { foreach ($nsdel->get_names(13)) { $mes->entities('NameServer',$_.'=') } } ## $statadd/$statdel are Net::DRI::Protocol::RRP::Core::Status objects if (defined($statadd)) { foreach ($statadd->list_status()) { $mes->entities('Status',$_) } } if (defined($statdel)) { foreach ($statdel->list_status()) { $mes->entities('Status',$_.'=') } } } sub renew { my ($rrp,$domain,$rd)=@_; my ($period,$curexp); if (defined($rd) && (ref($rd) eq 'HASH') && keys(%$rd)) { $period=$rd->{duration}; $curexp=$rd->{current_expiration}; } Net::DRI::Exceptions::usererr_insufficient_parameters("current expiration year and period must be both defined or not at all") if (defined($curexp) xor defined($period)); ## both or none should be defined if (defined($curexp)) { Net::DRI::Util::check_isa($period,'DateTime::Duration'); $period=$period->years(); Net::DRI::Exceptions::usererr_invalid_parameters("period must be an integer") unless Net::DRI::Util::isint($period); $curexp=$curexp->year() if (ref($curexp) && $curexp->can('year')); ## for DateTime objects Net::DRI::Exceptions::usererr_invalid_parameters("current expiration year must be a 4 digits integer") unless $curexp=~m/^\d{4}$/; } my $mes=$rrp->message(); build_msg($mes,'renew',$domain); $mes->options({Period=>$period,CurrentExpirationYear=>$curexp}) if (defined($period) && defined($curexp)); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRP/Message.pm0000644000175000017500000002332411352534376020603 0ustar patrickpatrick## Domain Registry Interface, RRP Message ## ## Copyright (c) 2005,2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::RRP::Message; use strict; use Net::DRI::Exception; use Net::DRI::Protocol::ResultStatus; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version errcode errmsg command)); our $VERSION=do { my @r=(q$Revision: 1.16 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRP::Message - RRP Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### our $EOL="\r\n"; ## as mandated by RFC 2832 our %CODES; ## defined at bottom our %ORDER=('add_domain' => ['EntityName','DomainName','-Period','NameServer'], 'add_nameserver' => ['EntityName','NameServer','IPAddress'], 'check_domain' => ['EntityName','DomainName'], 'check_nameserver' => ['EntityName','NameServer'], 'del_domain' => ['EntityName','DomainName'], 'del_nameserver' => ['EntityName','NameServer'], 'describe' => ['-Target'], 'mod_domain' => ['EntityName','DomainName','NameServer','Status'], 'mod_nameserver' => ['EntityName','NameServer','NewNameServer','IPAddress'], 'quit' => [], 'renew_domain' => ['EntityName','DomainName','-Period','-CurrentExpirationYear'], 'session' => ['-Id','-Password','-NewPassword'], 'status_domain' => ['EntityName','DomainName'], 'status_nameserver' => ['EntityName','NameServer'], 'transfer_domain' => ['-Approve','EntityName','DomainName'], ); sub new { my $proto=shift; my $class=ref($proto) || $proto; my $self={errcode => 0}; bless($self,$class); my $trid=shift; return $self; } sub is_success { return (shift->errcode()=~m/^2/)? 1 : 0; } sub result_status { my $self=shift; my $code=$self->errcode(); my $eppcode=_eppcode($code); return Net::DRI::Protocol::ResultStatus->new('rrp',$code,$eppcode,$self->is_success(),$self->errmsg(),'en'); } sub _eppcode { my $code=shift; return (defined($code) && exists($CODES{$code}))? $CODES{$code} : 'GENERIC_ERROR'; } sub as_string { my $self=shift; my $cmd=$self->command(); my $ent=$self->entities('EntityName'); my $allopt=$self->options(); my $order=lc($cmd); $order.='_'.lc($ent) if ($ent); Net::DRI::Exception->die(1,'protocol/RRP',5,'Unknown command '.$cmd.', no order found') unless (exists($ORDER{$order})); my @r=($cmd); foreach my $o (@{$ORDER{$order}}) { if ($o=~m/^-(.+)$/) ## Option { push @r,$o.':'.$allopt->{$1} if exists($allopt->{$1}); } else ## Entity { my @e=$self->entities($o); push @r,map { $o.':'.$_ } @e if @e; } } push @r,'.'.$EOL; ## end return join($EOL,@r); } sub parse { my ($self,$dc)=@_; ## DataRaw my @todo=map { my $s=$_; $s=~s/\r*\n*\r*$//; $s; } grep { defined() && ! /^\s+$/ } $dc->as_array(); Net::DRI::Exception->die(0,'protocol/RRP',1,'Unsuccessfull parse (last line not a lonely dot ') unless (pop(@todo) eq '.'); my $t=shift(@todo); $t=~m/^(\d+)\s+(\S.*\S)\s*$/; $self->errcode($1); $self->errmsg($2); foreach my $l (@todo) { my ($lh,$rh)=split(/:/,$l,2); if ($lh=~m/^-(.+)$/) ## option { $self->options($1,$rh); } else ## entity { $self->entities($lh,$rh); } } } sub entities { my ($self,$k,$v)=@_; if (defined($k)) { if (defined($v)) ## key + value => add { $self->{entities}={} unless exists($self->{entities}); my @v=(ref($v) eq 'ARRAY')? @$v : ($v); if (exists($self->{entities}->{$k})) { push @{$self->{entities}->{$k}},@v; } else { $self->{entities}->{$k}=\@v; } return $self; } else ## only key given => get value of key { return unless (exists($self->{entities})); $k=lc($k); foreach my $i (keys(%{$self->{entities}})) { next unless (lc($i) eq $k); $k=$i; last; }; return unless (exists($self->{entities}->{$k})); return wantarray()? @{$self->{entities}->{$k}} : join(' ',@{$self->{entities}->{$k}}); } } else ## nothing given => get list of keys { return exists($self->{entities})? keys(%{$self->{entities}}) : (); } } sub options { my ($self,$rh1,$v)=@_; if (defined($rh1)) ## something to add { $self->{options}={} unless exists($self->{options}); if (ref($rh1) eq 'HASH') { $self->{options}={ %{$self->{options}}, %$rh1 }; } else { $self->{options}->{$rh1}=$v; } return $self; } return exists($self->{options})? $self->{options} : {}; } #################################################################################################### %CODES=( 200 => 1000, # Command completed successfully 210 => 2303, # Domain name available => Object does not exist 211 => 2302, # Domain name not available => Object exists 212 => 2303, # Name server available => Object does not exist 213 => 2302, # Name server not available => Object exists 220 => 1500, # Command completed successfully. Server closing connection 420 => 2500, # Command failed due to server error. Server closing connection 421 => 2400, # Command failed due to server error. Client should try again 500 => 2000, # Invalid command name => Unknown command 501 => 2102, # Invalid command option => Unimplemented option 502 => 2005, # Invalid entity value => Parameter value syntax error 503 => 2005, # Invalid attribute name => Parameter value syntax error 504 => 2003, # Missing required attribute => Required parameter missing 505 => 2005, # Invalid attribute value syntax => Parameter value syntax error 506 => 2004, # Invalid option value => Parameter value range error 507 => 2001, # Invalid command format => Command syntax error 508 => 2003, # Missing required entity => Required parameter missing 509 => 2003, # Missing command option => Required parameter missing 510 => 2306, # Invalid encoding => Parameter value policy error (RRP v2.0) 520 => 2500, # Server closing connection. Client should try opening new connection => Command failed; server closing connection 521 => 2502, # Too many sessions open. Server closing connection => Session limit exceeded; server closing connection 530 => 2200, # Authentication failed => Authentication error 531 => 2201, # Authorization failed => Authorization error 532 => 2305, # Domain names linked with name server => Object association prohibits operation 533 => 2305, # Domain name has active name servers => Object association prohibits operation 534 => 2301, # Domain name has not been flagged for transfer => Object not pending transfer 535 => 2306, # Restricted IP address => Parameter value policy error 536 => 2300, # Domain already flagged for transfer => Object pending transfer 540 => 2308, # Attribute value is not unique => Data management policy violation 541 => 2005, # Invalid attribute value => Parameter value syntax error 542 => 2306, # Invalid old value for an attribute => Parameter value policy error 543 => 2308, # Final or implicit attribute cannot be updated => Data management policy violation 544 => 2304, # Entity on hold => Object status prohibits operation 545 => 2308, # Entity reference not found => Data management policy violation 546 => 2104, # Credit limit exceeded => Billing failure 547 => 2002, # Invalid command sequence => Command use error 548 => 2105, # Domain is not up for renewal => Object is not eligible for renewal 549 => 2400, # Command failed 550 => 2308, # Parent domain not registered => Data management policy violation 551 => 2308, # Parent domain status does not allow for operation => Data management policy violation 552 => 2304, # Domain status does not allow for operation => Object status prohibits operation 553 => 2300, # Operation not allowed. Domain pending transfer => Object pending transfer 554 => 2302, # Domain already registered => Object exists 555 => 2105, # Domain already renewed => Object is not eligible for renewal 556 => 2308, # Maximum registration period exceeded => Data management policy violation 557 => 2304, # Name server locked => Object status prohibits operation (RRP v2.0) ); ######################################################################## 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois.pm0000644000175000017500000000536611352534376017653 0ustar patrickpatrick## Domain Registry Interface, Whois Protocol (RFC3912) ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::Whois::Message; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois - Whois Protocol (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('whois'); my $version=Net::DRI::Util::check_equal($rp->{version},['1.0'],'1.0'); $self->version($version); my @tlds=$drd->tlds(); ## Net::DRI::Exception::usererr_invalid_parameters('Whois can not be used for registry handling multiple TLDs: '.join(',',@tlds)) unless (@tlds==1 || lc($tlds[0]) eq 'com'); $drd->set_factories($self) if $drd->can('set_factories'); $self->factories('message',sub { return Net::DRI::Protocol::Whois::Message->new(@_)->version($version); }); $self->_load(uc($tlds[0])); return $self; } sub _load { my ($self,$tld)=@_; $self->SUPER::_load('Net::DRI::Protocol::Whois::Domain::'.$tld); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::Whois::Connection', protocol_version => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/IRIS.pm0000644000175000017500000000622611352534376017324 0ustar patrickpatrick## Domain Registry Interface, IRIS Protocols (RFC 3981,3982,3983,4414,4698,4991,4992,4993,5144) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::IRIS; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Util; use Net::DRI::Protocol::IRIS::Message; use Net::DRI::Protocol::IRIS::DCHK::Status; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::IRIS - IRIS Protocols (RFC 3981,3982,3983,4414,4698,4991,4992,4993,5144) for Net::DRI =head1 DESCRIPTION Please see the README file for details. Currently only DCHK (RFC5144) over LWZ (RFC4993) is supported. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $version=$rp->{version}; my $authority=$rp->{authority}; my $self=$c->SUPER::new(); $self->name('IRIS'); $version=Net::DRI::Util::check_equal($version,['1.0'],'1.0'); $self->version($version); $self->ns({ iris1 => ['urn:ietf:params:xml:ns:iris1','iris1.xsd'], dchk1 => ['urn:ietf:params:xml:ns:dchk1','dchk1.xsd'], }); $self->factories('message',sub { my $m=Net::DRI::Protocol::IRIS::Message->new(@_); $m->ns($self->ns()); $m->version($version); $m->authority($authority); return $m; }); $self->factories('status',sub { return Net::DRI::Protocol::IRIS::DCHK::Status->new(); }); $self->_load('Net::DRI::Protocol::IRIS::DCHK::Domain'); return $self; } sub ns { my ($self,$add)=@_; $self->{ns}={ ref $self->{ns} ? %{$self->{ns}} : (), %$add } if (defined $add && ref $add eq 'HASH'); return $self->{ns}; } ## This will need to be slightly re-engineered once we do other things than DCHK in IRIS sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::IRIS::LWZ', protocol_version => '1.0'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Gandi/0002755000175000017500000000000011352534417017232 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/Gandi/WS.pm0000644000175000017500000000473011352534376020127 0ustar patrickpatrick## Domain Registry Interface, Gandi Web Services Protocol ## As seen on https://api.ote.gandi.net/ ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Gandi::WS; use strict; use base qw(Net::DRI::Protocol); use Net::DRI::Protocol::Gandi::WS::Message; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Gandi::WS - Gandi Web Services Protocol for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('gandi_ws'); $self->version($VERSION); $self->factories('message',sub { my $m=Net::DRI::Protocol::Gandi::WS::Message->new(); $m->version($VERSION); return $m; }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; my @class=map { 'Net::DRI::Protocol::Gandi::WS::'.$_ } (qw/Account Domain/); $self->SUPER::_load(@class); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::Gandi::WS::Connection', protocol_version => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Gandi/WS/0002755000175000017500000000000011352534417017563 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/Gandi/WS/Connection.pm0000644000175000017500000000463011352534376022225 0ustar patrickpatrick## Domain Registry Interface, Gandi Web Services Connection handling ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Gandi::WS::Connection; use strict; use XMLRPC::Lite; ## needed to have XMLRPC::Data our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Gandi::WS::Connection - Gandi Web Services Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub login { my ($class,$cm,$id,$pass,$cltrid)=@_; my $mes=$cm->(); $mes->method('login'); $mes->params([$id,$pass,XMLRPC::Data->type('boolean')->value(0)]); return $mes; } sub parse_login { my ($class,$mes)=@_; $mes->errmsg($mes->is_success()? 'Login OK' : 'Login failed') unless $mes->errmsg(); return $mes->result_status(); } sub extract_session { my ($class,$mes)=@_; return { id => $mes->value() }; } sub transport_default { my ($self,$tname)=@_; return (defer => 1, has_login => 1, has_logout => 0); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Gandi/WS/Account.pm0000644000175000017500000000471511352534376021526 0ustar patrickpatrick## Domain Registry Interface, Gandi Web Services Account commands ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::Gandi::WS::Account; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Gandi::WS::Account - Gandi Web Services Account commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( list_domains => [\&list_domains, \&list_domains_parse ], ); return { 'account' => \%tmp }; } sub list_domains { my ($po)=@_; my $msg=$po->message(); $msg->method('domain_list'); } sub list_domains_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/gandi/ws',1,'Unexpected reply for domainList: '.$r) unless (ref($r) eq 'ARRAY'); my @r=@$r; $rinfo->{account}->{domains}->{action}='list'; $rinfo->{account}->{domains}->{list}=\@r; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Gandi/WS/Domain.pm0000644000175000017500000001074211352534376021336 0ustar patrickpatrick## Domain Registry Interface, Gandi Web Services Domain commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Gandi::WS::Domain; use strict; use warnings; use DateTime::Format::ISO8601; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Gandi::WS::Domain - Gandi Web Services Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [\&info, \&info_parse ], check => [\&check, \&check_parse ], ); return { 'domain' => \%tmp }; } sub build_msg { my ($msg,$command,$domain)=@_; Net::DRI::Exception->die(1,'protocol/gandi/ws',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/gandi/ws',10,'Invalid domain name') unless Net::DRI::Util::is_hostname($domain); $msg->method($command) if defined($command); } sub info { my ($po,$domain)=@_; my $msg=$po->message(); build_msg($msg,'domain_info',$domain); $msg->params([$domain]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/gandi/ws',1,'Unexpected reply for domain_info: '.$r) unless (ref($r) eq 'HASH'); my %r=%$r; $rinfo->{domain}->{$oname}->{action}='info'; $rinfo->{domain}->{$oname}->{exist}=1; my %d=(registry_creation_date => 'crDate', registry_last_update => 'upDate', registry_expiration_date => 'exDate', registrar_creation_date => 'trDate'); while (my ($k,$v)=each(%d)) { next unless exists($r{$k}); $rinfo->{domain}->{$oname}->{$v}=$po->parse_iso8601($r{$k}); } my %c=(owner_handle => 'registrant', admin_handle => 'admin', tech_handle => 'tech', billing_handle => 'billing'); my $cs=$po->create_local_object('contactset'); while (my ($k,$v)=each(%c)) { next unless exists($r{$k}); my $c=$po->create_local_object('contact')->srid($r{$k}); $cs->add($c,$v); } $rinfo->{domain}->{$oname}->{contact}=$cs; $rinfo->{domain}->{$oname}->{auth}={pw => $r{authorization_code}}; if ($r{locked}) { $rinfo->{domain}->{$oname}->{status}=$po->create_local_object('status')->add('clientTransferProhibited'); ## ? } else { $rinfo->{domain}->{$oname}->{status}=$po->create_local_object('status')->add('ok'); } ## And what about nameservers ? No information in documentation, only separate functions for that: domain_ns_* # $rinfo->{domain}->{$oname}->{ns}=?? } sub check { my ($po,$domain)=@_; my $msg=$po->message(); build_msg($msg,'domain_available',$domain); $msg->params([$domain]); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/gandi/ws',1,'Unexpected reply for domain_check: '.$r) unless (ref($r) eq 'HASH'); $rinfo->{domain}->{$oname}->{action}='check'; $rinfo->{domain}->{$oname}->{exist}=(exists($r->{$oname}) && $r->{$oname}==1)? 0 : 1; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Gandi/WS/Message.pm0000644000175000017500000001015511352534376021511 0ustar patrickpatrick## Domain Registry Interface, Gandi Web Services Message ## ## Copyright (c) 2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Gandi::WS::Message; use strict; use warnings; use Net::DRI::Protocol::ResultStatus; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version method params result errcode errmsg)); our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Gandi::WS::Message - Gandi Web Services Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self={errcode => undef, errmsg => undef}; bless($self,$class); my ($trid,$otype,$oaction)=@_; $self->params([]); ## empty default return $self; } sub as_string { my ($self)=@_; my @p=@{$self->params()}; my @pr; foreach my $i (0..$#p) { push @pr,sprintf 'PARAM%d=%s',$i+1,$p[$i]; } return sprintf "METHOD=%s\n%s\n",$self->method(),join("\n",@pr); } sub add_session { my ($self,$sd)=@_; my $rp=$self->params(); unshift(@$rp,$sd->{id}); } sub parse { my ($self,$dr,$rinfo,$otype,$oaction,$sent)=@_; ## $sent is the original message, we could copy its method/params value into this new message my ($res)=@{$dr->data()}; ## $dr is a Data::Raw object, type=1 if (! defined($res->result()) || $res->fault()) { $self->result(undef); $self->errcode($res->faultcode()); $self->errmsg($res->faultstring()); } else { $self->result($res->result()); $self->errcode(0); ## probably success $self->errmsg('No status/msg given'); } } sub is_success { return (shift->errcode()==0)? 1 : 0; } ## See https://api.ote.gandi.net/#error_description sub result_status { my $self=shift; my $code=$self->errcode(); my $msg=$self->errmsg() || ''; my $ok=$self->is_success(); return Net::DRI::Protocol::ResultStatus->new('gandi_ws',$code,'COMMAND_SUCCESSFUL',1,$msg,'en') if $ok; my $eppcode='GENERIC_ERROR'; if ($code=~m/^1/) { $eppcode=2400; ## Command failed } elsif ($code=~m/^5/) { if ($code=~m/^5001/) { $eppcode=2200; } elsif ($code=~m/^5002/) { $eppcode=2201; } elsif ($code=~m/00$/) { $eppcode=2400; } elsif ($code=~m/10$/ || $code=~m/20$/) { $eppcode=2005; } elsif ($code=~m/30$/) { $eppcode=2004; } elsif ($code=~m/3[14]$/) { $eppcode=2306; } elsif ($code=~m/32$/) { $eppcode=2003; } elsif ($code=~m/33$/) { $eppcode=2308; } elsif ($code=~m/40$/) { $eppcode=2303; } elsif ($code=~m/41$/) { $eppcode=2302; } elsif ($code=~m/50$/) { $eppcode=2201; } elsif ($code=~m/60$/) { $eppcode=2304; } } return Net::DRI::Protocol::ResultStatus->new('gandi_ws',$code,$eppcode,0,$msg,'en'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/0002755000175000017500000000000011352534417016617 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/DAS/Connection.pm0000644000175000017500000000506211352534376021261 0ustar patrickpatrick## Domain Registry Interface, DAS Connection handling ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::Connection; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::Connection - DAS Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub read_data { my ($class,$to,$sock)=@_; my @a; while(my $l=$sock->getline()) { chomp($l); push @a,$l; last if $l=~m/^Status: /; } @a=map { Net::DRI::Util::decode_ascii($_); } @a; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read answer (connection closed by registry ?)','en')) unless (@a && $a[-1]=~m/^Status: /); return Net::DRI::Data::Raw->new_from_array(\@a); } sub write_message { my ($class,$to,$msg)=@_; return Net::DRI::Util::encode_ascii($msg->as_string()); } sub transport_default { my ($self,$tname)=@_; return (defer => 1, close_after => 1, socktype => 'tcp', remote_port => 4343); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/Domain.pm0000644000175000017500000000547611352534376020402 0ustar patrickpatrick## Domain Registry Interface, DAS Domain commands ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::Domain; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::Domain - DAS Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], ); return { 'domain' => \%tmp }; } sub check { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/DAS',2,'Domain name needed') unless $domain; Net::DRI::Exception->die(1,'protocol/DAS',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); my $tld=$po->tld(); $domain=~s/\.${tld}$// if defined $tld; $mes->command('get'); $mes->command_param(lc($domain)); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $domain=(defined $po->tld())? lc($rr->{Domain}.'.'.$po->tld()) : lc($rr->{Domain}); $rinfo->{domain}->{$domain}->{action}='check'; my $s=uc($rr->{Status}); $rinfo->{domain}->{$domain}->{exist}=($s eq 'FREE' || $s eq 'AVAILABLE')? 0 : 1; $rinfo->{domain}->{$domain}->{exist_reason}=$rr->{Status}; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/AdamsNames.pm0000644000175000017500000000511711352534376021174 0ustar patrickpatrick## Domain Registry Interface, DAS Protocol for AdamsNames ## as specified on http://www.adamsnames.tc/bulk/querying.html ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::AdamsNames; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Util; use Net::DRI::Protocol::DAS::AdamsNames::Message; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::AdamsNames - AdamsNames DAS Protocol (Domain Availability Service) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('DAS'); my $version=Net::DRI::Util::check_equal($rp->{version},['1.0'],'1.0'); $self->version($version); $self->factories('message',sub { return Net::DRI::Protocol::DAS::AdamsNames::Message->new(@_)->version($version); }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; $self->SUPER::_load('Net::DRI::Protocol::DAS::AdamsNames::Domain'); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::DAS::AdamsNames::Connection', protocol_version => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/AU.pm0000644000175000017500000000472211352534376017471 0ustar patrickpatrick## Domain Registry Interface, DAS Protocol for .AU ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::AU; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Util; use Net::DRI::Protocol::DAS::AU::Message; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::AU - .AU DAS Protocol (Domain Availability Service) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('DAS'); my $version=Net::DRI::Util::check_equal($rp->{version},['1.0'],'1.0'); $self->version($version); $self->factories('message',sub { return Net::DRI::Protocol::DAS::AU::Message->new(@_)->version($version); }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; $self->SUPER::_load('Net::DRI::Protocol::DAS::AU::Domain'); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::DAS::AU::Connection', protocol_version => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/AdamsNames/0002755000175000017500000000000011352534417020630 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/DAS/AdamsNames/Connection.pm0000644000175000017500000000517011352534376023272 0ustar patrickpatrick## Domain Registry Interface, DAS Connection handling for AdamsNames ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::AdamsNames::Connection; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::AdamsNames::Connection - AdamsNames DAS Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub read_data { my ($class,$to,$sock)=@_; my @a; while(my $l=$sock->getline()) { chomp($l); push @a,$l; last if $l=~m/registered/; } @a=map { Net::DRI::Util::decode_ascii($_); } @a; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read answer (connection closed by registry ?)','en')) unless (@a && $a[-1]=~m/registered/); return Net::DRI::Data::Raw->new_from_array(\@a); } sub write_message { my ($class,$to,$msg)=@_; return Net::DRI::Util::encode_ascii($msg->as_string()); } sub transport_default { my ($self,$tname)=@_; return (defer => 1, close_after => 1, socktype => 'tcp', remote_port => 43, remote_host => 'whois.adamsnames.com'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/AdamsNames/Domain.pm0000644000175000017500000000523611352534376022405 0ustar patrickpatrick## Domain Registry Interface, AdamsNames DAS Domain commands ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::AdamsNames::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::AdamsNames::Domain - AdamsNames DAS Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], ); return { 'domain' => \%tmp }; } sub check { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/DAS',2,'Domain name needed') unless $domain; Net::DRI::Exception->die(1,'protocol/DAS',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command_param(lc($domain)); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $domain=$rr->[0]; $rinfo->{domain}->{$domain}->{action}='check'; $rinfo->{domain}->{$domain}->{exist}=$rr->[1]; $rinfo->{domain}->{$domain}->{exist_reason}=$mes->errmsg(); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/AdamsNames/Message.pm0000644000175000017500000000576411352534376022570 0ustar patrickpatrick## Domain Registry Interface, AdamsNames DAS Message ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::AdamsNames::Message; use strict; use warnings; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version errcode errmsg command_param cltrid response)); our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::AdamsNames::Message - AdamsNames DAS Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $proto=shift; my $class=ref($proto) || $proto; my $trid=shift; my $self={ errcode => -1000, response => {}, }; bless($self,$class); $self->cltrid($trid) if (defined($trid) && $trid); return $self; } sub is_success { return (shift->errcode()==0)? 1 : 0; } sub result_status { my $self=shift; my $c=$self->errcode(); my $rs=Net::DRI::Protocol::ResultStatus->new('das',$c,'COMMAND_SUCCESSFUL_END',$self->is_success()); $rs->_set_trid([ $self->cltrid(),undef ]); return $rs; } sub as_string { my ($self)=@_; my $s=sprintf("testdomain %s\x0d\x0a",$self->command_param()); return $s; } sub parse { my ($self,$dc,$rinfo)=@_; my @d=$dc->as_array(); Net::DRI::Exception->die(0,'protocol/DAS',1,'Unsuccessfull parse, not exactly 2 lines in server reply') unless (@d==2); my $e=($d[0]=~m/Yes/)? 1 : 0; my ($dom)=($d[1]=~m/^(\S+) is /); $self->errcode(0); $self->errmsg($d[0].', '.$d[1]); $self->response([$dom,$e]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/SIDN.pm0000644000175000017500000000473611352534376017726 0ustar patrickpatrick## Domain Registry Interface, DAS Protocol for .NL ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::SIDN; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Util; use Net::DRI::Protocol::DAS::SIDN::Message; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::SIDN - .NL DAS Protocol (Domain Availability Service) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('DAS'); my $version=Net::DRI::Util::check_equal($rp->{version},['1.0'],'1.0'); $self->version($version); $self->factories('message',sub { return Net::DRI::Protocol::DAS::SIDN::Message->new(@_)->version($version); }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; $self->SUPER::_load('Net::DRI::Protocol::DAS::SIDN::Domain'); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::DAS::SIDN::Connection', protocol_version => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/Message.pm0000644000175000017500000000757511352534376020561 0ustar patrickpatrick## Domain Registry Interface, DAS Message ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::Message; use strict; use warnings; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version errcode errmsg errlang command command_param cltrid response)); our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::Message - DAS Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$trid)=@_; my $self={ errcode => -1000, response => {}, }; bless($self,$class); $self->cltrid($trid) if (defined($trid) && $trid); return $self; } sub is_success { return (shift->errcode()==0)? 1 : 0; } sub result_status { my $self=shift; ## From http://www.dns.be/en/home.php?n=317 ## See also http://www.dns.be/en/home.php?n=44 my %C=( 0 => 1500, ## Command successful + connection closed -9 => 2201, ## IP address blocked => Authorization error -8 => 2400, ## Timeout => Command failed -7 => 2005, ## Invalid pattern => Parameter value syntax error -6 => 2005, ## Invalid version => Parameter value syntax error ); my $c=$self->errcode(); my $rs=Net::DRI::Protocol::ResultStatus->new('das',$c,exists($C{$c})? $C{$c} : $Net::DRI::Protocol::ResultStatus::EPP_CODES{GENERIC_ERROR},$self->is_success(),$self->errmsg(),$self->errlang(),undef); $rs->_set_trid([ $self->cltrid(),undef ]); return $rs; } sub as_string { my ($self)=@_; my $s=sprintf("%s %s %s\x0d\x0a",$self->command(),$self->version(),$self->command_param()); return $s; } sub parse { my ($self,$dc,$rinfo)=@_; my @d=$dc->as_array(); my $rc; my @tmp=grep { /^%% RC\s*=\s*\S+/ } @d; if (@tmp) { ($rc)=($tmp[0]=~m/^%% RC\s*=\s*(\S+)\s*$/); $self->errcode($rc); } if ((defined $rc && $rc==0) || grep { /^Status: /} @d) ## success { $self->errcode(0); my %info=map { m/^(\S+):\s+(.*\S)\s*$/; $1 => $2 } grep { /^\S+: / } @d; Net::DRI::Exception->die(0,'protocol/DAS',1,'Unsuccessfull parse, missing key Domain') unless exists $info{Domain}; Net::DRI::Exception->die(0,'protocol/DAS',1,'Unsuccessfull parse, missing key Status') unless exists $info{Status}; $self->response(\%info); } else { $self->errlang('en'); ## really ? my ($msg)=($d[-1]=~m/^%\s*(\S.+\S)\s*$/); $self->errmsg($msg); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/AU/0002755000175000017500000000000011352534417017124 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/DAS/AU/Connection.pm0000644000175000017500000000502311352534376021563 0ustar patrickpatrick## Domain Registry Interface, DAS Connection handling for .AU ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::AU::Connection; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::AU::Connection - .AU DAS Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub read_data { my ($class,$to,$sock)=@_; my $l=$sock->getline(); chomp($l); $l=Net::DRI::Util::decode_ascii($l); die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read answer (connection closed by registry ?)','en')) unless $l=~m/^(?:Not )?Available$/; return Net::DRI::Data::Raw->new_from_string($l); } sub write_message { my ($class,$to,$msg)=@_; return Net::DRI::Util::encode_ascii($msg->as_string()); } sub transport_default { my ($self,$tname)=@_; return (defer => 1, close_after => 1, socktype => 'tcp', remote_port => 43, remote_host => 'whois-check.ausregistry.net.au'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/AU/Domain.pm0000644000175000017500000000521111352534376020672 0ustar patrickpatrick## Domain Registry Interface, .AU DAS Domain commands ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::AU::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::AU::Domain - .AU DAS Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], ); return { 'domain' => \%tmp }; } sub check { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/DAS',2,'Domain name needed') unless $domain; Net::DRI::Exception->die(1,'protocol/DAS',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain) && $domain=~m/\.au$/i; $mes->command_param(lc($domain)); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); $rinfo->{domain}->{$oname}->{action}='check'; $rinfo->{domain}->{$oname}->{exist}=($rr eq 'Not Available')? 1 : 0; $rinfo->{domain}->{$oname}->{exist_reason}=$rr; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/AU/Message.pm0000644000175000017500000000557311352534376021062 0ustar patrickpatrick## Domain Registry Interface, .AU DAS Message ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::AU::Message; use strict; use warnings; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version errcode errmsg command_param cltrid response)); our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::AU::Message - .AU DAS Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $proto=shift; my $class=ref($proto) || $proto; my $trid=shift; my $self={ errcode => -1000, response => {}, }; bless($self,$class); $self->cltrid($trid) if (defined($trid) && $trid); return $self; } sub is_success { return (shift->errcode()==0)? 1 : 0; } sub result_status { my $self=shift; my $c=$self->errcode(); my $rs=Net::DRI::Protocol::ResultStatus->new('das',$c,'COMMAND_SUCCESSFUL_END',$self->is_success()); $rs->_set_trid([ $self->cltrid(),undef ]); return $rs; } sub as_string { my ($self)=@_; my $s=sprintf("%s\x0d\x0a",$self->command_param()); return $s; } sub parse { my ($self,$dc,$rinfo)=@_; my @d=$dc->as_array(); Net::DRI::Exception->die(0,'protocol/DAS',1,'Unsuccessfull parse, not exactly one line in server reply') unless (@d==1); $self->errcode(0); $self->errmsg($d[0]); $self->response($d[0]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/SIDN/0002755000175000017500000000000011352534417017354 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/DAS/SIDN/Connection.pm0000644000175000017500000000505011352534376022013 0ustar patrickpatrick## Domain Registry Interface, DAS Connection handling for .NL ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::SIDN::Connection; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::SIDN::Connection - .NL DAS Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub read_data { my ($class,$to,$sock)=@_; my $l=$sock->getline(); $l=~s/\s*$//; ## seems better than chomp $l=Net::DRI::Util::decode_ascii($l); die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read answer (connection closed by registry ?)','en')) unless $l=~m/^\S+ is \S+$/; return Net::DRI::Data::Raw->new_from_string($l); } sub write_message { my ($class,$to,$msg)=@_; return Net::DRI::Util::encode_ascii($msg->as_string()); } sub transport_default { my ($self,$tname)=@_; return (defer => 1, close_after => 1, socktype => 'tcp', remote_port => 43, remote_host => 'whois.domain-registry.nl'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/SIDN/Domain.pm0000644000175000017500000000545311352534376021132 0ustar patrickpatrick## Domain Registry Interface, .NL DAS Domain commands ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::SIDN::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::SIDN::Domain - .NL DAS Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], ); return { 'domain' => \%tmp }; } sub check { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/DAS',2,'Domain name needed') unless $domain; Net::DRI::Exception->die(1,'protocol/DAS',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain) && $domain=~m/\.nl$/i; $mes->command_param(lc($domain)); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my ($dom,$e)=($rr=~m/^(\S+) is (free|active)/); Net::DRI::Exception->die(1,'protocol/DAS',1,'Unexpected reply for domain_check: '.$rr) unless defined $dom && defined $e; $rinfo->{domain}->{$dom}->{action}='check'; $rinfo->{domain}->{$dom}->{exist}=($e eq 'active')? 1 : 0; $rinfo->{domain}->{$dom}->{exist_reason}=$rr; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS/SIDN/Message.pm0000644000175000017500000000560211352534376021303 0ustar patrickpatrick## Domain Registry Interface, .NL DAS Message ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS::SIDN::Message; use strict; use warnings; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version errcode errmsg command_param cltrid response)); our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS::SIDN::Message - .NL DAS Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $proto=shift; my $class=ref($proto) || $proto; my $trid=shift; my $self={ errcode => -1000, response => {}, }; bless($self,$class); $self->cltrid($trid) if (defined($trid) && $trid); return $self; } sub is_success { return (shift->errcode()==0)? 1 : 0; } sub result_status { my $self=shift; my $c=$self->errcode(); my $rs=Net::DRI::Protocol::ResultStatus->new('das',$c,'COMMAND_SUCCESSFUL_END',$self->is_success()); $rs->_set_trid([ $self->cltrid(),undef ]); return $rs; } sub as_string { my ($self)=@_; my $s=sprintf("is %s\x0d\x0a",$self->command_param()); return $s; } sub parse { my ($self,$dc,$rinfo)=@_; my @d=$dc->as_array(); Net::DRI::Exception->die(0,'protocol/DAS',1,'Unsuccessfull parse, not exactly one line in server reply') unless (@d==1); $self->errcode(0); $self->errmsg($d[0]); $self->response($d[0]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRI/0002755000175000017500000000000011352534417016644 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/RRI/Connection.pm0000644000175000017500000001113111352534376021300 0ustar patrickpatrick## Domain Registry Interface, RRI Connection handling ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::RRI::Connection; use strict; use Net::DRI::Util; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRI::Connection - RRI Connection handling (DENIC-11) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub login { my ($class, $cm, $id, $pass, $cltrid, $dr, $newpass, $pdata) = @_; my $mes=$cm->(); $mes->command(['login']); my @d; push @d,['user',$id]; push @d,['password',$pass]; $mes->command_body(\@d); return $mes; } sub logout { my ($class,$cm,$cltrid)=@_; my $mes=$cm->(); $mes->command(['logout']); $mes->cltrid($cltrid) if $cltrid; return $mes; } sub keepalive { my ($class,$cm,$cltrid)=@_; my $mes=$cm->(); $mes->command(['hello']); return $mes; } #################################################################################################### sub read_data { my ($class,$to,$sock)=@_; my $version = $to->{transport}->{protocol_version}; my $m=''; my $c; my $rl=$sock->sysread($c, 4); ## first 4 bytes are the packed length die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING', 'Unable to read RRI 4 bytes length (connection closed by registry ?): '.$!, 'en')) unless (defined $rl && $rl==4); my $length = unpack('N', $c); while ($length > 0) { my $new; $length-=$sock->sysread($new,$length); $m.=$new; } $m=Net::DRI::Util::decode_utf8($m); die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR', $m ? $m : '', 'en')) unless ($m =~ m!$!); return Net::DRI::Data::Raw->new_from_xmlstring($m); } sub write_message { my ($self,$to,$msg)=@_; my $m=Net::DRI::Util::encode_utf8($msg->as_string()); my $l = pack('N', length($m)); ## DENIC-11 return $l.$m; } sub parse_login { my ($class,$dc)=@_; my ($result,$code,$msg)=find_result($dc); unless (defined($result) && ($result eq 'success')) { return Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR', (defined($msg) && length($msg) ? $msg : 'Login failed'), 'en'); } else { return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL', 'Login OK', 'en'); } } sub parse_logout { my ($class,$dc)=@_; my ($result,$code,$msg)=find_result($dc); unless (defined($result) && ($result eq 'success')) { return Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR', (defined($msg) && length($msg) ? $msg : 'Logout failed'), 'en'); } else { return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL', 'Logout OK', 'en'); } } sub find_result { my $dc=shift; my $a=$dc->as_string(); return () unless ($a=~m!!); $a=~s/>[\n\s\t]+/>/g; my ($result,$code,$msg); return () unless (($result)=($a=~m!(\w+)!)); ($code) = ($a =~ m!!); ($msg) = ($a =~ m!([^>]+)!); return ($result, $code, $msg); } sub transport_default { my ($self,$tname)=@_; return (); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRI/Contact.pm0000644000175000017500000003063511352534376020606 0ustar patrickpatrick## Domain Registry Interface, RRI Contact commands (DENIC-11) ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::RRI::Contact; use strict; use Net::DRI::Util; use Net::DRI::Exception; use DateTime::Format::ISO8601 (); our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRI::Contact - RRI Contact commands (DENIC-11) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], create => [ \&create, \&create_parse ], update => [ \&update ], ); ##$tmp{check_multi}=$tmp{check}; return { 'contact' => \%tmp }; } sub build_command { my ($msg, $command, $contact) = @_; my @contact = (ref($contact) eq 'ARRAY')? @$contact : ($contact); my @c = map { Net::DRI::Util::isa_contact($_)? $_->srid() : $_ } @contact; Net::DRI::Exception->die(1,'protocol/RRI',2,'Contact id needed') unless @c; foreach my $n (@c) { Net::DRI::Exception->die(1,'protocol/RRI',2,'Contact id needed') unless defined($n) && $n; Net::DRI::Exception->die(1,'protocol/RRI',10,'Invalid contact id: '.$n) unless Net::DRI::Util::xml_is_token($n,3,32); } my $tcommand = (ref($command))? $command->[0] : $command; my @ns = @{$msg->ns->{contact}}; $msg->command(['contact',$tcommand,$ns[0]]); my @d = map { ['contact:handle',$_] } @c; return @d; } #################################################################################################### ########### Query commands sub check { my ($rri,$c)=@_; my $mes=$rri->message(); my @d=build_command($mes,'check',$c); $mes->command_body(\@d); $mes->cltrid(undef); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes = $po->message(); return unless $mes->is_success(); my $chkdata = $mes->get_content('checkData',$mes->ns('contact')); return unless ($chkdata); my @c = $chkdata->getElementsByTagNameNS($mes->ns('contact'),'handle'); my @s = $chkdata->getElementsByTagNameNS($mes->ns('contact'),'status'); return unless (@c && @s); my $contact = $c[0]->getFirstChild()->getData(); $rinfo->{contact}->{$contact}->{action} = 'check'; $rinfo->{contact}->{$contact}->{exist} = ($s[0]->getFirstChild()->getData() eq 'free')? 0 : 1; } sub info { my ($rri,$c)=@_; my $mes=$rri->message(); my @d=build_command($mes,'info',$c); $mes->command_body(\@d); $mes->cltrid(undef); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_content('infoData',$mes->ns('contact')); return unless $infdata; my %cd=map { $_ => [] } qw/name org street city sp pc cc/; my $contact=$po->create_local_object('contact'); my @s; my $c=$infdata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'handle') { my $clID; $oname = $c->getFirstChild()->getData(); if ($oname =~ /^(\w+)-(\d+)-/) { $clID = $1 . '-' . $2 . '-RRI'; } $rinfo->{contact}->{$oname}->{action} = 'info'; $rinfo->{contact}->{$oname}->{exist} = 1; $rinfo->{contact}->{$oname}->{clID} = $rinfo->{contact}->{$oname}->{crID} = $clID; $contact->srid($oname); } elsif ($name eq 'roid') { my $el = $c->getFirstChild(); $contact->roid($el->getData()) if (defined($el)); $rinfo->{contact}->{$oname}->{roid} = $contact->roid(); } elsif ($name eq 'changed') { my $el = $c->getFirstChild(); $rinfo->{contact}->{$oname}->{upDate} = $rinfo->{contact}->{$oname}->{crDate} = DateTime::Format::ISO8601->new()-> parse_datetime($c->getFirstChild()->getData()) if (defined($el)); } elsif ($name eq 'type') { my $el = $c->getFirstChild(); $contact->type($el->getData()) if (defined($el)); } elsif ($name eq 'email') { my $el = $c->getFirstChild(); $contact->email($el->getData()) if (defined($el)); } elsif ($name eq 'name') { my $el = $c->getFirstChild(); $contact->name($el->getData()) if (defined($el)); } elsif ($name eq 'organisation') { my $el = $c->getFirstChild(); $contact->org($el->getData()) if (defined($el)); } elsif ($name eq 'sip') { my $el = $c->getFirstChild(); $contact->sip($el->getData()) if (defined($el)); } elsif ($name eq 'phone') { $contact->voice(parse_tel($c)); } elsif ($name eq 'fax') { $contact->fax(parse_tel($c)); } elsif ($name eq 'postal') { parse_postalinfo($c,\%cd); } elsif ($name eq 'disclose') { $contact->disclose(parse_disclose($c)); } } continue { $c=$c->getNextSibling(); } $contact->street(@{$cd{street}}); $contact->city(@{$cd{city}}); $contact->pc(@{$cd{pc}}); $contact->cc(@{$cd{cc}}); $rinfo->{contact}->{$oname}->{self}=$contact; } sub parse_tel { my $node=shift; my $ext=$node->getAttribute('x') || ''; my $num=get_data($node); $num.='x'.$ext if $ext; return $num; } sub get_data { my $n=shift; return ($n->getFirstChild())? $n->getFirstChild()->getData() : ''; } sub parse_postalinfo { my ($c,$rcd)=@_; my @street; my $n = $c->getFirstChild(); while ($n) { next unless ($n->nodeType() == 1); my $name=$n->localname() || $n->nodeName(); next unless $name; if ($name eq 'city') { $rcd->{city}->[0] = get_data($n); } elsif ($name eq 'postalCode') { $rcd->{pc}->[0] = get_data($n); } elsif ($name eq 'countryCode') { $rcd->{cc}->[0] = get_data($n); } elsif ($name eq 'address') { push @street, get_data($n); } } continue { $n=$n->getNextSibling(); } $rcd->{street}->[0]=\@street; } sub parse_disclose { my $c=shift; my $flag=Net::DRI::Util::xml_parse_boolean($c->getAttribute('flag')); my %tmp; my $n=$c->getFirstChild(); while($n) { next unless ($n->nodeType() == 1); my $name=$n->localname() || $n->nodeName(); next unless $name; if ($name=~m/^(name|org|addr)$/) { my $t=$n->getAttribute('type'); $tmp{$1.'_'.$t}=$flag; } elsif ($name=~m/^(voice|fax|email)$/) { $tmp{$1}=$flag; } } continue { $n=$n->getNextSibling(); } return \%tmp; } ############ Transform commands sub build_tel { my ($name,$tel)=@_; if ($tel=~m/^(\S+)x(\S+)$/) { return [$name,$1,{x=>$2}]; } else { return [$name,$tel]; } } sub build_disclose { my $contact=shift; my $d=$contact->disclose(); return () unless ($d && ref($d)); my %v=map { $_ => 1 } values(%$d); return () unless (keys(%v)==1); ## 1 or 0 as values, not both at same time my @d; push @d,['contact:name',{type=>'int'}] if (exists($d->{name_int}) && !exists($d->{name})); push @d,['contact:name',{type=>'loc'}] if (exists($d->{name_loc}) && !exists($d->{name})); push @d,['contact:name',{type=>'int'}],['contact:name',{type=>'loc'}] if exists($d->{name}); push @d,['contact:org',{type=>'int'}] if (exists($d->{org_int}) && !exists($d->{org})); push @d,['contact:org',{type=>'loc'}] if (exists($d->{org_loc}) && !exists($d->{org})); push @d,['contact:org',{type=>'int'}],['contact:org',{type=>'loc'}] if exists($d->{org}); push @d,['contact:addr',{type=>'int'}] if (exists($d->{addr_int}) && !exists($d->{addr})); push @d,['contact:addr',{type=>'loc'}] if (exists($d->{addr_loc}) && !exists($d->{addr})); push @d,['contact:addr',{type=>'int'}],['contact:addr',{type=>'loc'}] if exists($d->{addr}); push @d,['contact:voice'] if exists($d->{voice}); push @d,['contact:fax'] if exists($d->{fax}); push @d,['contact:email'] if exists($d->{email}); return ['contact:disclose',@d,{flag=>(keys(%v))[0]}]; } sub build_cdata { my $contact=shift; my @d; my (@post,@addr); _do_locint(\@post,$contact,'type','type'); _do_locint(\@post,$contact,'name','name'); _do_locint(\@post,$contact,'organisation','org'); _do_locint(\@addr,$contact,'address','street'); _do_locint(\@addr,$contact,'postalCode','pc'); _do_locint(\@addr,$contact,'city','city'); _do_locint(\@addr,$contact,'countryCode','cc'); push @post,['contact:postal',@addr] if @addr; push (@d,@post) if @post; push @d,build_tel('contact:phone',$contact->voice()) if defined($contact->voice()); push @d,build_tel('contact:fax',$contact->fax()) if defined($contact->fax()); push @d,['contact:email',$contact->email()] if defined($contact->email()); push @d,['contact:sip',$contact->sip()] if defined($contact->sip()); push @d,build_disclose($contact); return @d; } sub _do_locint { my ($r, $contact, $tagname, $what) = @_; my @tmp = $contact->$what(); my $loaded = 0; return unless (@tmp); if ($what eq 'street') { if (defined($tmp[0])) { foreach (@{$tmp[0]}) { push @$r,['contact:'.$tagname,$_]; $loaded = 1; } } if (defined($tmp[1]) && !$loaded) { foreach (@{$tmp[1]}) { push @$r,['contact:'.$tagname,$_]; } } } else { if (defined($tmp[0])) { push @$r,['contact:'.$tagname,$tmp[0]]; $loaded = 1; } if (defined($tmp[1]) && !$loaded) { push @$r,['contact:'.$tagname,$tmp[1]]; } } } sub create { my ($rri,$contact)=@_; my $mes=$rri->message(); my @d=build_command($mes,'create',$contact); Net::DRI::Exception->die(1,'protocol/RRI',10,'Invalid contact '.$contact) unless (Net::DRI::Util::isa_contact($contact)); $contact->validate(); ## will trigger an Exception if needed push @d,build_cdata($contact); $mes->command_body(\@d); } sub create_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_content('creData',$mes->ns('contact')); return unless $credata; my $c=$credata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); if ($name eq 'id') { my $new=$c->getFirstChild()->getData(); $rinfo->{contact}->{$oname}->{id}=$new if (defined($oname) && ($oname ne $new)); ## registry may give another id than the one we requested or not take ours into account at all ! $oname=$new; $rinfo->{contact}->{$oname}->{id}=$oname; $rinfo->{contact}->{$oname}->{action}='create'; $rinfo->{contact}->{$oname}->{exist}=1; } elsif ($name=~m/^(crDate)$/) { $rinfo->{contact}->{$oname}->{$1}=DateTime::Format::ISO8601->new()->parse_datetime($c->getFirstChild()->getData()); } } continue { $c=$c->getNextSibling(); } } sub update { my ($rri,$contact,$todo)=@_; my $mes=$rri->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:add|del)$/ } $todo->types('status')) || (grep { ! /^(?:set)$/ } $todo->types('info')) ) { Net::DRI::Exception->die(0,'protocol/RRI',11,'Only status add/del or info set available for contact'); } my @d=build_command($mes,'update',$contact); my $newc=$todo->set('info'); if ($newc) { Net::DRI::Exception->die(1,'protocol/RRI',10,'Invalid contact '.$newc) unless Net::DRI::Util::isa_contact($newc); $newc->type($contact->type()); $newc->validate(1); ## will trigger an Exception if needed push @d,build_cdata($newc); } $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRI/RegistryMessage.pm0000644000175000017500000001144011352534376022321 0ustar patrickpatrick## Domain Registry Interface, RRI Registry messages commands (DENIC-11) ## ## Copyright (c) 2008 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::RRI::RegistryMessage; use strict; use DateTime::Format::ISO8601 (); use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRI::RegistryMessage - RRI Registry messages commands (DENIC-11) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/project/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( retrieve => [ \&pollreq, \&parse_poll ], delete => [ \&pollack ], ); return { 'message' => \%tmp }; } sub pollack { my ($rri, $msgid) = @_; my $mes = $rri->message(); $mes->command(['msg', 'delete', $mes->ns->{msg}->[0], {msgid => $msgid}]); } sub pollreq { my ($rri,$msgid)=@_; Net::DRI::Exception::usererr_invalid_parameters('In RRI, you can not specify the message id you want to retrieve') if defined($msgid); my $mes = $rri->message(); $mes->command(['msg', 'queue-read', $mes->ns->{msg}->[0]]); $mes->cltrid(undef); } ## We take into account all parse functions, to be able to parse any result sub parse_poll { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $msgdata = $mes->get_content('message', $mes->ns('msg')); return unless ($msgdata); my $msgid = $msgdata->getAttribute('msgid'); my $rd = {}; if (defined($msgid) && $msgid) { $rinfo->{message}->{session}->{last_id} = $msgid; $rd = $rinfo->{message}->{$msgid}; ## already partially filled by Message::parse() } $rd->{id} = $msgid; $rd->{lang} = 'en'; $rd->{qdate} = DateTime::Format::ISO8601->new()-> parse_datetime($msgdata->getAttribute('msgtime')); $rd->{objtype} = 'domain'; my $el = $msgdata->getFirstChild(); while ($el) { my @doms = $el->getElementsByTagNameNS($mes->ns('msg'), 'domain'); my @news = $el->getElementsByTagNameNS($mes->ns('msg'), 'new'); my @olds = $el->getElementsByTagNameNS($mes->ns('msg'), 'old'); my $dom = $doms[0]; my $exp; my $new = ''; my $old = ''; my $action = $rd->{action} = $el->localname() || $el->nodeName(); $rd->{action} =~ s/[A-Z]\w*$//g; if ($dom) { my @hndls = $dom->getElementsByTagNameNS($mes->ns('msg'), 'handle'); my @exps = $dom->getElementsByTagNameNS($mes->ns('msg'), 'expire'); my $hndl = $hndls[0]; $rd->{objid} = $hndl->getFirstChild()->getData() if (@hndls); $rd->{exDate} = DateTime::Format::ISO8601->new()-> parse_datetime($hndl->getFirstChild()->getData()) if (@exps); } $new = $news[0]->getFirstChild()->getData() if (@news); $old = $olds[0]->getFirstChild()->getData() if (@olds); $rd->{clID} = $new if (length($new)); if ($rd->{action} eq 'chprov') { my $act = lc($rd->{action}); $act =~ s/^chprov//g; $rd->{content} = 'Received ' . $act . ' for ' . $rd->{objid} . ' from ' . ($act eq 'start' || $act eq 'reminder' || $act eq 'end' ? $new : $old); } elsif ($action eq 'expireWarning') { $rd->{content} = $rd->{objid} . ' will expire on ' . $rd->{exDate}->ymd . ' at ' . $rd->{exDate}->hms; } elsif ($action eq 'expire') { $rd->{content} = $rd->{objid} . ' expired on ' . $rd->{exDate}->ymd . ' at ' . $rd->{exDate}->hms; } $el = $el->nextSibling(); } $rinfo->{message}->{$msgid} = $rd; return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRI/Session.pm0000644000175000017500000000560211352534376020632 0ustar patrickpatrick## Domain Registry Interface, RRI Session commands (DENIC-11) ## ## Copyright (c) 2007 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::RRI::Session; use strict; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRI::Session - RRI Session commands (DENIC-11) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( noop => [ \&hello ], logout => [ \&logout ], login => [ \&login ], connect => [ \&hello ], ); return { 'session' => \%tmp }; } sub hello ## should trigger a greeting from server, allowed at any time { my ($rri)=@_; my $mes=$rri->message(); $mes->command(['hello']); } sub logout { my ($rri)=@_; my $mes=$rri->message(); $mes->command(['logout']); } sub login { my ($rri,$id,$pass,$newpass,$opts)=@_; Net::DRI::Exception::usererr_insufficient_parameters('login & password') unless (defined($id) && $id && defined($pass) && $pass); Net::DRI::Exception::usererr_invalid_parameters('login') unless Net::DRI::Util::xml_is_token($id,3,16); Net::DRI::Exception::usererr_invalid_parameters('password') unless Net::DRI::Util::xml_is_token($pass,6,16); my $mes=$rri->message(); $mes->command(['login']); my @d; push @d,['user',$id]; push @d,['password',$pass]; $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRI/Domain.pm0000644000175000017500000003576111352534376020427 0ustar patrickpatrick## Domain Registry Interface, RRI Domain commands (DENIC-11) ## ## Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::RRI::Domain; use strict; ##use IDNA::Punycode; use DateTime::Format::ISO8601 (); use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::Hosts; use Net::DRI::Data::ContactSet; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRI::Domain - RRI Domain commands (DENIC-11) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], transfer_query => [ \&transfer_query, \&transfer_parse ], create => [ \&create, \&create_parse ], delete => [ \&delete ], transfer_request => [ \&transfer_request ], transfer_answer => [ \&transfer_answer ], trade => [ \&trade ], update => [ \&update], ); ##$tmp{check_multi} = $tmp{check}; return { 'domain' => \%tmp }; } sub build_command { my ($msg, $command, $domain, $domainattr, $dns) = @_; my @dom = (ref($domain))? @$domain : ($domain); Net::DRI::Exception->die(1,'protocol/RRI', 2, 'Domain name needed') unless @dom; foreach my $d (@dom) { Net::DRI::Exception->die(1, 'protocol/RRI', 2, 'Domain name needed') unless defined($d) && $d; Net::DRI::Exception->die(1, 'protocol/RRI', 10, 'Invalid domain name: ' . $d) unless Net::DRI::Util::is_hostname($d); } my $tcommand = (ref($command)) ? $command->[0] : $command; my @ns = @{$msg->ns->{domain}}; $msg->command(['domain', $tcommand, (defined($dns) ? $dns : $ns[0]), $domainattr]); my @d; foreach my $domain (@dom) { ##my $ace = join('.', map { decode_punycode($_) } split(/\./, $domain)); push @d, ['domain:handle', $domain]; push @d, ['domain:ace', $domain]; } return @d; } #################################################################################################### ########### Query commands sub check { my ($rri, $domain, $rd)=@_; my $mes = $rri->message(); my @d = build_command($mes, 'check', $domain); $mes->command_body(\@d); $mes->cltrid(undef); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes = $po->message(); return unless $mes->is_success(); my $chkdata = $mes->get_content('checkData',$mes->ns('domain')); return unless $chkdata; my @d = $chkdata->getElementsByTagNameNS($mes->ns('domain'),'handle'); my @s = $chkdata->getElementsByTagNameNS($mes->ns('domain'),'status'); return unless (@d && @s); my $dom = $d[0]->getFirstChild()->getData(); $rinfo->{domain}->{$dom}->{action} = 'check'; $rinfo->{domain}->{$dom}->{exist} = ($s[0]->getFirstChild()->getData() eq 'free')? 0 : 1; } sub info { my ($rri, $domain, $rd)=@_; my $mes = $rri->message(); my @d = build_command($mes, 'info', $domain, {recursive => 'false', withProvider => 'true'}); $mes->command_body(\@d); $mes->cltrid(undef); } sub info_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $infdata = $mes->get_content('infoData', $mes->ns('domain')); return unless $infdata; my $cs = Net::DRI::Data::ContactSet->new(); my $ns = Net::DRI::Data::Hosts->new(); my $c = $infdata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name = $c->localname() || $c->nodeName(); next unless $name; if ($name eq 'handle') { $oname = lc($c->getFirstChild()->getData()); $rinfo->{domain}->{$oname}->{action} = 'info'; $rinfo->{domain}->{$oname}->{exist} = 1; } elsif ($name eq 'status') { my $val = $c->getFirstChild()->getData(); $rinfo->{domain}->{$oname}->{exist} = ($val eq 'connect')? 1 : 0; } elsif ($name eq 'contact') { my $role = $c->getAttribute('role'); my %rmap = ('holder' => 'registrant', 'admin-c' => 'admin', 'tech-c' => 'tech', 'zone-c' => 'zone'); my @hndl_tags = $c->getElementsByTagNameNS($mes->ns('contact'),'handle'); my $hndl_tag = $hndl_tags[0]; $role = $rmap{$role} if (defined($rmap{$role})); $cs->add($po->create_local_object('contact')->srid($hndl_tag->getFirstChild()->getData()), $role) if (defined($hndl_tag)); } elsif ($name eq 'dnsentry') { $ns->add(parse_ns($mes,$c)); } elsif ($name eq 'regAccId') { $rinfo->{domain}->{$oname}->{clID} = $rinfo->{domain}->{$oname}->{crID} = $rinfo->{domain}->{$oname}->{upID} = $c->getFirstChild()->getData(); } elsif ($name eq 'changed') { $rinfo->{domain}->{$oname}->{crDate} = $rinfo->{domain}->{$oname}->{upDate} = DateTime::Format::ISO8601->new()-> parse_datetime($c->getFirstChild()->getData()); } elsif ($name eq 'chprovData') { # FIXME: Implement this one as well } } continue { $c = $c->getNextSibling(); } $rinfo->{domain}->{$oname}->{contact} = $cs; $rinfo->{domain}->{$oname}->{status} = $po->create_local_object('status'); $rinfo->{domain}->{$oname}->{ns} = $ns; } sub parse_ns { my $mes = shift; my $node = shift; my $n = $node->getFirstChild(); my $hostname = ''; my @ip4 = (); my @ip6 = (); while ($n) { next unless ($n->nodeType() == 1); ## only for element nodes my $name = $n->localname() || $n->nodeName(); next unless $name; if ($name eq 'rdata') { my $nn = $n->getFirstChild(); while ($nn) { next unless ($nn->nodeType() == 1); ## only for element nodes my $name2 = $nn->localname() || $nn->nodeName(); next unless $name2; if ($name2 eq 'nameserver') { $hostname = $nn->getFirstChild()->getData(); $hostname =~ s/\.$// if ($hostname =~ /\.$/); } elsif ($name2 eq 'address') { my $ip = $nn->getFirstChild()->getData(); if ($ip=~m/:/) { push @ip6, $ip; } else { push @ip4, $ip; } } } continue { $nn = $nn->getNextSibling(); } } } continue { $n = $n->getNextSibling(); } return ($hostname, \@ip4, \@ip6); } sub transfer_query { my ($rri, $domain, $rd)=@_; my $mes = $rri->message(); my @d = build_command($mes, 'info', $domain, {recursive => 'true', withProvider => 'false'}); $mes->command_body(\@d); } sub transfer_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $infodata = $mes->get_content('infoData', $mes->ns('domain')); return unless $infodata; my $namedata = ($infodata->getElementsByTagNameNS($mes->ns('domain'), 'handle'))[0]; return unless $namedata; my $trndata = ($infodata->getElementsByTagNameNS($mes->ns('domain'), 'chprovData'))[0]; return unless $trndata; $oname = lc($namedata->getFirstChild()->getData()); $rinfo->{domain}->{$oname}->{action} = 'transfer'; $rinfo->{domain}->{$oname}->{exist} = 1; $rinfo->{domain}->{$oname}->{trStatus} = undef; my $c = $trndata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name = $c->localname() || $c->nodeName(); next unless $name; if ($name eq 'chprovTo') { $rinfo->{domain}->{$oname}->{reID} = $c->getFirstChild()->getData(); } elsif ($name eq 'chprovStatus') { my %stmap = (ACTIVE => 'pending', REMINDED => 'pending'); my $val = $c->getFirstChild()->getData(); $rinfo->{domain}->{$oname}->{trStatus} = (defined($stmap{$val}) ? $stmap{$val} : $val); } elsif ($name =~ m/^(chprovStart|chprovReminder|chprovEnd)$/) { my %tmmap = (chprovStart => 'reDate', chprovReminder => 'acDate', chprovEnd => 'exDate'); $rinfo->{domain}->{$oname}->{$tmmap{$1}} = DateTime::Format::ISO8601-> new()->parse_datetime($c->getFirstChild()->getData()); } } continue { $c = $c->getNextSibling(); } } ############ Transform commands sub create { my ($rri, $domain, $rd) = @_; my $mes = $rri->message(); my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi); my @d = build_command($mes, 'create', $domain, undef, \%ns); my $def = $rri->default_parameters(); if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) && (ref($def->{domain_create}) eq 'HASH')) { $rd = {} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd)); while (my ($k, $v) = each(%{$def->{domain_create}})) { next if exists($rd->{$k}); $rd->{$k} = $v; } } ## Contacts, all OPTIONAL push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd); ## Nameservers, OPTIONAL push @d,build_ns($rri,$rd->{ns},$domain) if Net::DRI::Util::has_ns($rd); $mes->command_body(\@d); } sub build_contact { my $cs = shift; my @d; my %trans = ('registrant' => 'holder', 'admin' => 'admin-c', 'tech' => 'tech-c', 'zone' => 'zone-c'); # All nonstandard contacts go into the extension section foreach my $t (sort($cs->types())) { my @o = $cs->get($t); my $c = (defined($trans{$t}) ? $trans{$t} : $t); push @d, map { ['domain:contact', $_->srid(), {'role' => $c}] } @o; } return @d; } sub build_ns { my ($rri,$ns,$domain,$xmlns)=@_; my @d; foreach my $i (1..$ns->count()) { my ($n, $v4, $v6) = $ns->get_details($i); my @h = map { ['dnsentry:address', $_] } (@{$v4}, @{$v6}); push @d, ['dnsentry:dnsentry', {'xsi:type' => 'dnsentry:NS'}, ['dnsentry:owner', $domain . '.'], ['dnsentry:rdata', ['dnsentry:nameserver', $n . '.' ], @h ] ]; } $xmlns='dnsentry' unless defined($xmlns); return @d; } sub create_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $credata = $mes->get_content('creData', $mes->ns('domain')); return unless $credata; my $c = $credata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name = $c->localname() || $c->nodeName(); next unless $name; if ($name eq 'name') { $oname = lc($c->getFirstChild()->getData()); $rinfo->{domain}->{$oname}->{action} = 'create'; $rinfo->{domain}->{$oname}->{exist} = 1; } elsif ($name =~ m/^(crDate|exDate)$/) { $rinfo->{domain}->{$oname}->{$1} = DateTime::Format::ISO8601->new()-> parse_datetime($c->getFirstChild()->getData()); } } continue { $c = $c->getNextSibling(); } } sub delete { my ($rri, $domain, $rd) = @_; my $mes = $rri->message(); my @d = build_command($mes, 'delete', $domain); ## Holder contact if (Net::DRI::Util::has_contact($rd)) { my $ocs = $rd->{contact}; my $cs = Net::DRI::Data::ContactSet->new(); foreach my $c ($ocs->get('registrant')) { $cs->add($c, 'registrant'); } push @d, build_contact($cs); } $mes->command_body(\@d); } sub transfer_request { my ($rri, $domain, $rd) = @_; my $mes = $rri->message(); my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi); my @d = build_command($mes, 'chprov', $domain, undef, \%ns); ## Contacts, all OPTIONAL push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd); ## Nameservers, OPTIONAL push @d, build_ns($rri, $rd->{ns}, $domain) if Net::DRI::Util::has_ns($rd); $mes->command_body(\@d); } sub transfer_answer { my ($rri, $domain, $rd) = @_; my $mes = $rri->message(); my @d = build_command($mes, (Net::DRI::Util::has_key($rd,'approve') && $rd->{approve}) ? 'chprovAck' : 'chprovNack', $domain); $mes->command_body(\@d); } sub trade { my ($rri, $domain, $rd) = @_; my $mes = $rri->message(); my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi); my @d = build_command($mes, 'chholder', $domain, undef, \%ns); my $def = $rri->default_parameters(); if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) && (ref($def->{domain_create}) eq 'HASH')) { $rd = {} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd)); while (my ($k, $v) = each(%{$def->{domain_create}})) { next if exists($rd->{$k}); $rd->{$k} = $v; } } ## Contacts, all OPTIONAL push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd); ## Nameservers, OPTIONAL push @d, build_ns($rri, $rd->{ns}, $domain) if Net::DRI::Util::has_ns($rd); $mes->command_body(\@d); } sub update { my ($rri, $domain, $todo, $rd)=@_; my $mes = $rri->message(); my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi); my $ns = $rd->{ns}; my $cs = $rd->{contact}; Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); Net::DRI::Exception::usererr_invalid_parameters('Must specify contact set and name servers with update command (or use the proper API)') unless (Net::DRI::Util::isa_contactset($cs) && Net::DRI::Util::isa_hosts($ns)); if ((grep { ! /^(?:add|del)$/ } $todo->types('ns')) || (grep { ! /^(?:add|del)$/ } $todo->types('contact'))) { Net::DRI::Exception->die(0, 'protocol/RRI', 11, 'Only ns/status/contact add/del or registrant/authinfo set available for domain'); } my @d = build_command($mes, 'update', $domain, undef, \%ns); my $nsadd = $todo->add('ns'); my $nsdel = $todo->del('ns'); my $cadd = $todo->add('contact'); my $cdel = $todo->del('contact'); if (defined($nsadd)) { foreach my $hostname ($nsadd->get_names()) { $ns->add($nsadd->get_details($hostname)); } } if (defined($nsdel)) { my $newns =Net::DRI::Data::Hosts->new(); foreach my $hostname ($ns->get_names()) { if (!grep { $_ eq $hostname } $nsdel->get_names()) { $newns->add($ns->get_details($hostname)); } } $ns = $newns; } if (defined($cadd)) { foreach my $type ($cadd->types()) { foreach my $c ($cadd->get($type)) { $cs->add($c, $type); } } } if (defined($cdel)) { foreach my $type ($cdel->types()) { foreach my $c ($cdel->get($type)) { $cs->del($c, $type); } } } push @d, build_contact($cs); push @d, build_ns($rri, $ns, $domain); $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRI/Message.pm0000644000175000017500000001464711352534376020604 0ustar patrickpatrick## Domain Registry Interface, RRI Message ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::RRI::Message; use strict; use warnings; use XML::LibXML (); use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use Net::DRI::Util; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version command command_body cltrid svtrid result errcode errmsg node_resdata result_extra_info)); our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRI::Message - RRI Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class = shift; my $trid = shift; my $self = { result => 'uninitialized', }; bless($self,$class); $self->cltrid($trid) if (defined($trid) && $trid); return $self; } sub ns { my ($self,$what)=@_; return $self->{ns} unless defined($what); if (ref($what) eq 'HASH') { $self->{ns}=$what; return $what; } return unless exists($self->{ns}->{$what}); return $self->{ns}->{$what}->[0]; } sub is_success { return (shift->result() =~ m/^success/)? 1 : 0; } sub result_status { my $self=shift; my $rs = Net::DRI::Protocol::ResultStatus->new('rri', ($self->is_success() ? 1000 : $self->errcode()), undef, $self->is_success(), $self->errmsg(), 'en', $self->result_extra_info()); $rs->_set_trid([ $self->cltrid(), $self->svtrid() ]); return $rs; } sub as_string { my ($self)=@_; my $rns=$self->ns(); my $topns=$rns->{_main}; my $ens=sprintf('xmlns="%s"', $topns->[0]); my $cmdi = $self->command(); my @d; push @d,''; my ($type, $cmd, $ns, $attr); ($type, $cmd, $ns, $attr) = @{$cmdi} if (ref($cmdi) eq 'ARRAY'); $attr = '' unless (defined($attr)); $attr = ' ' . join(' ', map { $_ . '="' . $attr->{$_} . '"' } keys (%{$attr})) if (ref($attr) eq 'HASH'); if (defined($ns)) { if (ref($ns) eq 'HASH') { $ens .= ' ' . join(' ', map { 'xmlns:' . $_ . '="' . $ns->{$_} . '"' } keys(%{$ns})); $cmd = $type . ':' . $cmd; } else { $ens .= ' xmlns:' . $type . '="' . $ns . '"'; $cmd = $type . ':' . $cmd; } } else { $cmd = $type; $type = undef; } push @d,''; my $body=$self->command_body(); if (defined($body) && $body) { push @d,'<'.$cmd.$attr.'>'; push @d,Net::DRI::Util::xml_write($body); push @d,''; } else { push @d,'<'.$cmd.$attr.'/>'; } ## OPTIONAL clTRID my $cltrid=$self->cltrid(); push @d,''.$cltrid.'' if (defined($cltrid) && $cltrid && Net::DRI::Util::xml_is_token($cltrid,3,64)); push @d,''; return join('',@d); } sub topns { return shift->ns->{_main}->[0]; } sub get_content { my ($self,$nodename,$ns,$ext)=@_; return unless (defined($nodename) && $nodename); my @tmp; my $n1=$self->node_resdata(); $ns||=$self->topns(); @tmp=$n1->getElementsByTagNameNS($ns,$nodename) if (defined($n1)); return unless @tmp; return wantarray()? @tmp : $tmp[0]; } sub parse { my ($self,$dc,$rinfo)=@_; my $NS=$self->topns(); my $trNS = $self->ns('tr'); my $parser=XML::LibXML->new(); my $xstr = $dc->as_string(); $xstr =~ s/^\s*//; my $doc=$parser->parse_string($xstr); my $root=$doc->getDocumentElement(); Net::DRI::Exception->die(0, 'protocol/RRI', 1, 'Unsuccessfull parse, root element is not registry-response') unless ($root->getName() eq 'registry-response'); my @trtags = $root->getElementsByTagNameNS($trNS, 'transaction'); Net::DRI::Exception->die(0, 'protocol/RRI', 1, 'Unsuccessfull parse, no transaction block') unless (@trtags); my $res = $trtags[0]; ## result block(s) my @results = $res->getElementsByTagNameNS($trNS,'result'); ## success indicator foreach (@results) { $self->result($_->firstChild()->getData()); } if ($res->getElementsByTagNameNS($trNS,'message')) ## OPTIONAL { my @msgs = $res->getElementsByTagNameNS($trNS,'message'); my $msg = $msgs[0]; my @extra = (); if (defined($msg)) { my @texts = $msg->getElementsByTagNameNS($trNS, 'text'); my $msgtype = $msg->getAttribute('level'); my $text = $texts[0]; if ($msgtype eq 'error') { $self->errcode($msg->getAttribute('code')); $self->errmsg($text->getFirstChild()->getData()) if (defined($text)); } else { push @extra, { from => 'rri', type => 'text', code => $msg->getAttribute('code'), message => (defined $text ? $text->textContent() : '') }; } } $self->result_extra_info(\@extra); } if ($res->getElementsByTagNameNS($trNS,'data')) ## OPTIONAL { $self->node_resdata(($res->getElementsByTagNameNS($trNS,'data'))[0]); } ## trID if ($res->getElementsByTagNameNS($trNS, 'stid')) { my @svtrid = $res->getElementsByTagNameNS($trNS, 'stid'); $self->svtrid($svtrid[0]->firstChild()->getData()); } if ($res->getElementsByTagNameNS($trNS, 'ctid')) { my @cltrid = $res->getElementsByTagNameNS($trNS, 'ctid'); $self->cltrid($cltrid[0]->firstChild()->getData()); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRI.pm0000644000175000017500000000712411352534376017210 0ustar patrickpatrick## Domain Registry Interface, RRI Protocol (DENIC-11) ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::RRI; use strict; use base qw(Net::DRI::Protocol); use Net::DRI::Util; use Net::DRI::Protocol::RRI::Message; use Net::DRI::Data::StatusList; use Net::DRI::Data::Contact::DENIC; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRI - RRI Protocol (DENIC-11) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('RRI'); my $version=Net::DRI::Util::check_equal($rp->{version},['2.0'],'2.0'); $self->version($version); foreach my $o (qw/ip status/) { $self->capabilities('host_update',$o,['set']); } $self->capabilities('host_update','name',['set']); $self->capabilities('contact_update','info',['set']); foreach my $o (qw/ns status contact/) { $self->capabilities('domain_update',$o,['add','del']); } foreach my $o (qw/registrant auth/) { $self->capabilities('domain_update',$o,['set']); } $self->{ns}={ _main => ['http://registry.denic.de/global/1.0'], tr => ['http://registry.denic.de/transaction/1.0'], contact => ['http://registry.denic.de/contact/1.0'], domain => ['http://registry.denic.de/domain/1.0'], dnsentry=> ['http://registry.denic.de/dnsentry/1.0'], msg => ['http://registry.denic.de/msg/1.0'], xsi => ['http://www.w3.org/2001/XMLSchema-instance'], }; $self->factories('message',sub { my $m=Net::DRI::Protocol::RRI::Message->new(@_); $m->ns($self->{ns}); $m->version($version); return $m; }); $self->factories('status',sub { return Net::DRI::Data::StatusList->new(); }); $self->factories('contact',sub { return Net::DRI::Data::Contact::DENIC->new(); }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; my @core=('Session','RegistryMessage','Domain','Contact'); my @class=map { 'Net::DRI::Protocol::RRI::'.$_ } @core; $self->SUPER::_load(@class); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::RRI::Connection', protocol_version => '2.0'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AdamsNames/0002755000175000017500000000000011352534417020221 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/AdamsNames/WS.pm0000644000175000017500000000522411352534376021115 0ustar patrickpatrick## Domain Registry Interface, AdamsNames Web Services Protocol ## As seen on http://www.adamsnames.tc/api/xmlrpc.html ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::AdamsNames::WS; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Protocol::AdamsNames::WS::Message; use DateTime::Format::Strptime; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AdamsNames::WS - AdamsNames Web Services Protocol for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('adamsnames_ws'); $self->version($VERSION); $self->factories('message',sub { my $m=Net::DRI::Protocol::AdamsNames::WS::Message->new(); $m->version($VERSION); return $m; }); $self->_load($rp); $self->{dt_parse}=DateTime::Format::Strptime->new(time_zone=>'Europe/London', pattern=>'%Y-%m-%d'); return $self; } sub _load { my ($self,$rp)=@_; my @class=map { 'Net::DRI::Protocol::AdamsNames::WS::'.$_ } (qw/Domain/); $self->SUPER::_load(@class); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::AdamsNames::WS::Connection', protocol_version => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AdamsNames/WS/0002755000175000017500000000000011352534417020552 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/AdamsNames/WS/Connection.pm0000644000175000017500000000373511352534376023221 0ustar patrickpatrick## Domain Registry Interface, AdamsNames Web Services Connection handling ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::AdamsNames::WS::Connection; use strict; use warnings; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AdamsNames::WS::Connection - AdamsNames Web Services Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub transport_default { my ($self,$tname)=@_; return (defer => 1, has_login => 0, has_logout => 0); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AdamsNames/WS/Domain.pm0000644000175000017500000000700511352534376022323 0ustar patrickpatrick## Domain Registry Interface, AdamsNames Web Services Domain commands ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::AdamsNames::WS::Domain; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AdamsNames::WS::Domain - AdamsNames Web Services Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [\&info, \&info_parse ], ); return { 'domain' => \%tmp }; } sub build_msg { my ($msg,$command,$domain)=@_; Net::DRI::Exception->die(1,'protocol/adamsnames/ws',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/adamsnames/ws',10,'Invalid domain name') unless Net::DRI::Util::is_hostname($domain); $msg->method($command) if defined($command); } sub info { my ($po,$domain)=@_; my $msg=$po->message(); build_msg($msg,'domquery',$domain); $msg->params([$domain]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/adamsnames/ws',1,'Unexpected reply for domain_info: '.$r) unless (ref($r) eq 'HASH'); $rinfo->{domain}->{$oname}->{action}='info'; $rinfo->{domain}->{$oname}->{exist}=$r->{'found'}; return unless $r->{'found'}; my %r=%{$r->{domain}}; $rinfo->{domain}->{$oname}->{crDate}=$po->{dt_parse}->parse_datetime($r{'registered'}); my %c=(org => 'registrant', admin => 'admin', tech => 'tech', bill => 'billing'); my $cs=$po->create_local_object('contactset'); while (my ($k,$v)=each(%c)) { next unless exists($r{$k}); my $c=$po->create_local_object('contact')->srid($r{$k}); $cs->add($c,$v); } $rinfo->{domain}->{$oname}->{contact}=$cs; my $h=$po->create_local_object('hosts'); foreach my $rr (@{$r{rr}}) { next unless $rr->{rclass} eq 'ns'; $h->add($rr->{rdata}); } $rinfo->{domain}->{$oname}->{ns}=$h; $rinfo->{domain}->{$oname}->{roid}=$r{id}; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/AdamsNames/WS/Message.pm0000644000175000017500000000761611352534376022510 0ustar patrickpatrick## Domain Registry Interface, AdamsNames Web Services Message ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::AdamsNames::WS::Message; use strict; use warnings; use Net::DRI::Protocol::ResultStatus; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version method params result errcode errmsg)); our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::AdamsNames::WS::Message - AdamsNames Web Services Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$trid,$otype,$oaction)=@_; my $self={errcode => undef, errmsg => undef}; bless($self,$class); $self->params([]); ## empty default return $self; } sub as_string { my ($self)=@_; my @p=@{$self->params()}; my @pr; foreach my $i (0..$#p) { push @pr,sprintf 'PARAM%d=%s',$i+1,$p[$i]; } return sprintf "METHOD=%s\n%s\n",$self->method(),join("\n",@pr); } sub parse { my ($self,$dr,$rinfo,$otype,$oaction,$sent)=@_; ## $sent is the original message, we could copy its method/params value into this new message my ($res)=@{$dr->data()}; ## $dr is a Data::Raw object, type=1 if (! defined($res->result()) || $res->fault()) { $self->result(undef); $self->errcode($res->faultcode()); $self->errmsg($res->faultstring()); } else { $self->result($res->result()); ## TODO: properly parse all error messages my $err=$res->result()->{error}; if (defined $err && @$err) { $self->errcode($err->[0]->[0]); $self->errmsg($err->[0]->[1]); } else { $self->errcode(0); ## probably success $self->errmsg('No error'); } } } sub is_success { return (shift->errcode()==0)? 1 : 0; } ## See http://www.adamsnames.tc/api/xmlrpc-doc/common.html ## Some values depend on the command issued sub result_status { my $self=shift; my $code=$self->errcode(); my $msg=$self->errmsg() || ''; my $ok=$self->is_success(); return Net::DRI::Protocol::ResultStatus->new('adamsnames_ws',$code,'COMMAND_SUCCESSFUL',1,$msg,'en') if $ok; my $eppcode='GENERIC_ERROR'; if ($code=~m/^30/) { $eppcode='AUTHORIZATION_ERROR'; } elsif ($code=~m/^31/) { $eppcode='COMMAND_SYNTAX_ERROR'; } elsif ($code=~m/^32/) { $eppcode='PARAMETER_VALUE_SYNTAX_ERROR'; } elsif ($code=~m/^4/) { $eppcode='COMMAND_SUCCESSFUL'; ## ? } elsif ($code=~m/^5/) { $eppcode='COMMAND_FAILED'; } return Net::DRI::Protocol::ResultStatus->new('adamsnames_ws',$code,$eppcode,0,$msg,'en'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/BookMyName/0002755000175000017500000000000011352534417020211 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/BookMyName/WS.pm0000644000175000017500000000501211352534376021100 0ustar patrickpatrick## Domain Registry Interface, BookMyName Web Services Protocol ## As seen on http://api.doc.free.org/revendeur-de-nom-de-domaine ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::BookMyName::WS; use strict; use base qw(Net::DRI::Protocol); use Net::DRI::Protocol::BookMyName::WS::Message; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::BookMyName::WS - BookMyName (aka Free/ProXad/Online/Dedibox/Iliad) Web Services Protocol for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('bookmyname_ws'); $self->version($VERSION); $self->factories('message',sub { my $m=Net::DRI::Protocol::BookMyName::WS::Message->new(); $m->version($VERSION); return $m; }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; my @class=map { 'Net::DRI::Protocol::BookMyName::WS::'.$_ } (qw/Account Domain/); $self->SUPER::_load(@class); } sub transport_default { my ($self)=@_; return (has_login=>0,has_logout=>0,defer=>1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/BookMyName/WS/0002755000175000017500000000000011352534417020542 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/BookMyName/WS/Account.pm0000644000175000017500000000503111352534376022475 0ustar patrickpatrick## Domain Registry Interface, BookMyName Web Services Account commands ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::BookMyName::WS::Account; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::BookMyName::WS::Account - BookMyName Web Services Account commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( list_domains => [\&list_domains, \&list_domains_parse ], ); return { 'account' => \%tmp }; } sub list_domains { my ($po)=@_; my $msg=$po->message(); $msg->method('domain_list'); } sub list_domains_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/bookmyname/ws',1,'Unexpected reply for domain_list: '.$r) unless (ref($r) eq 'ARRAY'); ## this is not clearly specified in documentation my @r=@$r; $rinfo->{account}->{domains}->{action}='list'; $rinfo->{account}->{domains}->{list}=\@r; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/BookMyName/WS/Domain.pm0000644000175000017500000001274011352534376022315 0ustar patrickpatrick## Domain Registry Interface, BookMyName Web Services Domain commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::BookMyName::WS::Domain; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::BookMyName::WS::Domain - BookMyName Web Services Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [\&info, \&info_parse ], check => [\&check, \&check_parse ], ); return { 'domain' => \%tmp }; } ## From http://api.doc.free.org/revendeur-de-nom-de-domaine#status sub parse_status { my $s=shift; my @s; push @s,'clientDeleteProhibited' if ($s & 0x01); push @s,'serverDeleteProhibited' if ($s & 0x02); push @s,'clientHold' if ($s & 0x04); push @s,'serverHold' if ($s & 0x08); push @s,'clientRenewProhibited' if ($s & 0x10); push @s,'serverRenewProhibited' if ($s & 0x20); push @s,'clientTransferProhibited' if ($s & 0x40); push @s,'serverTransferProhibited' if ($s & 0x80); push @s,'clientUpdateProhibited' if ($s & 0x100); push @s,'serverUpdateProhibited' if ($s & 0x200); push @s,'pendingCreate' if ($s & 0x400); push @s,'pendingDelete' if ($s & 0x800); push @s,'pendingRenew' if ($s & 0x1000); push @s,'pendingTransfer' if ($s & 0x2000); push @s,'pendingUpdate' if ($s &0x4000); return @s? @s : ('ok'); } sub build_msg { my ($msg,$command,$domain)=@_; Net::DRI::Exception->die(1,'protocol/bookmyname/ws',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/bookmyname/ws',10,'Invalid domain name') unless Net::DRI::Util::is_hostname($domain); $msg->method($command) if defined($command); } sub info { my ($po,$domain)=@_; my $msg=$po->message(); build_msg($msg,'domain_info',$domain); $msg->params([ $domain ]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/bookmyname/ws',1,'Unexpected reply for domain_info: '.$r) unless (ref($r) eq 'HASH'); my %r=%$r; $oname=lc($r{domain}); $rinfo->{domain}->{$oname}->{action}='info'; $rinfo->{domain}->{$oname}->{exist}=1; $rinfo->{domain}->{$oname}->{roid}=$r{id}; my %d=(registrar_creation => 'crDate', lastupdate => 'upDate', registrar_expiration => 'exDate'); while (my ($k,$v)=each(%d)) { next unless exists($r{$k}); $rinfo->{domain}->{$oname}->{$v}=$po->parse_iso8601($r{$k}); } $rinfo->{domain}->{$oname}->{upIP}=$r{lastupdate_ip}; my %c=(owner_id => 'registrant', admin_id => 'admin', tech_id => 'tech', bill_id => 'billing'); my $cs=$po->create_local_object('contactset'); while (my ($k,$v)=each(%d)) { next unless exists($r{$k}); my $c=$po->create_local_object('contact')->srid($r{$k}); $cs->add($c,$v); } $rinfo->{domain}->{$oname}->{contact}=$cs; $rinfo->{domain}->{$oname}->{auth}={pw => $r{authinfo}}; foreach my $k (qw/service ip_dns_master/) { $rinfo->{domain}->{$oname}->{$k}=$r{$k} if (exists($r{$k}) && defined($r{$k})); } my $sl=$po->create_local_object('status'); foreach my $s (parse_status($r{registry_status})) { $sl->add($s); } $rinfo->{domain}->{$oname}->{status}=$sl; ## $r{status} is not used, what is it ? my $ns=$po->create_local_object('hosts'); foreach my $nsk (sort { ($a=~m/^ns(\d+)/)[0] <=> ($b=~m/^ns(\d+)/)[0] } grep { /^ns\d+$/ } keys(%r)) { $ns->add($r{$nsk}); } $rinfo->{domain}->{$oname}->{ns}=$ns; } sub check { my ($po,$domain)=@_; my $msg=$po->message(); build_msg($msg,'domain_check',$domain); $msg->params([ $domain ]); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); if ($mes->retcode()==-1 && ($mes->retval()==-2 || $mes->retval()==-4)) ## domain does not exist { $mes->retcode(1); ## fake a success } return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='check'; $rinfo->{domain}->{$oname}->{exist}=($mes->retcode()==1 && $mes->retval()==1)? 1 : 0; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/BookMyName/WS/Message.pm0000644000175000017500000000747311352534376022501 0ustar patrickpatrick## Domain Registry Interface, BookMyName Web Services Message ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::BookMyName::WS::Message; use strict; use warnings; use Net::DRI::Protocol::ResultStatus; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version method params operation result retcode retval)); our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::BookMyName::WS::Message - BookMyName Web Services Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self={errcode => undef, errmsg => undef}; bless($self,$class); my ($trid,$otype,$oaction)=@_; $self->params([]); ## default return $self; } sub as_string { my ($self)=@_; my @p=@{$self->params()}; my @pr; foreach my $i (0..$#p) { push @pr,sprintf 'PARAM%d=%s',$i+1,$p[$i]; } return sprintf "METHOD=%s\n%s\n",$self->method(),join("\n",@pr); } sub add_session { my ($self,$sd)=@_; my $rp=$self->params(); unshift(@$rp,$sd->{id},$sd->{pass}); } sub parse { my ($self,$dr,$rinfo,$otype,$oaction,$sent)=@_; ## $sent is the original message, we could copy its method/params value into this new message $self->operation($otype.'_'.$oaction); my ($res)=@{$dr->data()}; ## $dr is a Data::Raw object, type=1 $self->result($res->{retfields}) if exists($res->{retfields}); $self->retcode($res->{retcode}); ## integer $self->retval($res->{retval}); ## integer } ## See http://api.doc.free.org/revendeur-de-nom-de-domaine our %CODES=( domain_info => { '-1,-1' => 2200, '-1,-2' => 2201, '-1,-3' => 2003, '0,0' => 2303, }, domain_check => { '-1,-1' => 2200, '-1,-2' => 2303, '-1,-3' => 2103, '-1,-4' => 2303, '-1,-5' => 2003, }, account_list_domains => { '-1,-1' => 2200, }, ); sub is_success { return (shift->retcode()==1)? 1 : 0; } sub result_status { my $self=shift; my ($op,$rc,$rv)=($self->operation(),$self->retcode(),$self->retval()); my $ok=$self->is_success(); my $k=$rc.','.$rv; my $eppcode=(exists($CODES{$op}) && (ref($CODES{$op}) eq 'HASH') && keys(%{$CODES{$op}}) && exists($CODES{$op}->{$k}))? $CODES{$op}->{$k} : 'GENERIC_ERROR'; return Net::DRI::Protocol::ResultStatus->new('bookmyname_ws',100*$rc+$rv,$ok? 'COMMAND_SUCCESSFUL' : $eppcode,$ok,'retcode='.$rc.' retval='.$rv,'en'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/0002755000175000017500000000000011352534417016634 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Connection.pm0000644000175000017500000001425411352534376021301 0ustar patrickpatrick## Domain Registry Interface, EPP Connection handling ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Connection; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.18 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Connection - EPP over TCP/TLS Connection Handling (RFC4934) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub login { my ($class,$cm,$id,$pass,$cltrid,$dr,$newpass,$pdata)=@_; my $got=$cm->(); $got->parse($dr); my $rg=$got->result_greeting(); my $mes=$cm->(); $mes->command(['login']); my @d; push @d,['clID',$id]; push @d,['pw',$pass]; push @d,['newPW',$newpass] if (defined($newpass) && $newpass); push @d,['options',['version',$rg->{version}->[0]],['lang','en']]; ## TODO: allow choice of language if multiple choices (like fr+en in .CA) ? my @s; push @s,map { ['objURI',$_] } @{$rg->{svcs}}; push @s,['svcExtension',map {['extURI',$_]} @{$rg->{svcext}}] if (exists($rg->{svcext}) && defined($rg->{svcext}) && (ref($rg->{svcext}) eq 'ARRAY')); @s=$pdata->{login_service_filter}->(@s) if (defined($pdata) && ref($pdata) eq 'HASH' && exists($pdata->{login_service_filter}) && ref($pdata->{login_service_filter}) eq 'CODE'); push @d,['svcs',@s] if @s; $mes->command_body(\@d); $mes->cltrid($cltrid) if $cltrid; return $mes; } sub logout { my ($class,$cm,$cltrid)=@_; my $mes=$cm->(); $mes->command(['logout']); $mes->cltrid($cltrid) if $cltrid; return $mes; } sub keepalive { my ($class,$cm)=@_; my $mes=$cm->(); $mes->command(['hello']); return $mes; } #################################################################################################### sub read_data { my ($class,$to,$sock)=@_; my $c; my $rl=$sock->sysread($c,4); ## first 4 bytes are the packed length die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read EPP 4 bytes length (connection closed by registry '.$to->transport_data('remote_uri').' ?): '.($! || 'no error given'),'en')) unless (defined $rl && $rl==4); my $length=unpack('N',$c)-4; my $m=''; while ($length > 0) { my $new; $length-=$sock->sysread($new,$length); $m.=$new; } $m=Net::DRI::Util::decode_utf8($m); die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR',$m? 'Got unexpected EPP message: '.$m : '','en')) unless ($m=~m!\s*$!s); return Net::DRI::Data::Raw->new_from_xmlstring($m); } sub write_message { my ($self,$to,$msg)=@_; my $m=Net::DRI::Util::encode_utf8($msg); my $l=pack('N',4+length($m)); ## RFC 4934 §4 return $l.$m; ## We do not support EPP "0.4" at all (which lacks length before data) } sub parse_greeting { my ($class,$dc)=@_; my ($code,$msg,$lang)=find_code($dc); unless (defined($code) && ($code==1000)) { return Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','No greeting node',$lang); } else { return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL','Greeting OK',$lang); } } ## Since is used as keepalive, answer is a sub parse_keepalive { return shift->parse_greeting(@_); } sub parse_login { my ($class,$dc)=@_; my ($code,$msg,$lang)=find_code($dc); unless (defined($code) && ($code==1000)) { my $eppcode=(defined($code))? $code : 'COMMAND_SYNTAX_ERROR'; return Net::DRI::Protocol::ResultStatus->new_error($eppcode,$msg || 'Login failed',$lang); } else { return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL',$msg || 'Login OK',$lang); } } sub parse_logout { my ($class,$dc)=@_; my ($code,$msg,$lang)=find_code($dc); unless (defined($code) && ($code==1500)) { my $eppcode=(defined($code))? $code : 'COMMAND_SYNTAX_ERROR'; return Net::DRI::Protocol::ResultStatus->new_error($eppcode,$msg || 'Logout failed',$lang); } else { return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL_END ',$msg || 'Logout OK',$lang); } } ## This simple regex based poking function does obviously not handle all cases correctly, ## but should be enough for parsing greeting/login/logout exchanges, which is all what is needed here sub find_code { my $dc=shift; my $a=$dc->as_string(); return () unless ($a=~m!!); return (1000,'Greeting OK','en') if ($a=~m!!); my ($code,$msg,$lang); return () unless (($code,$lang,$msg)=($a=~m!\s*\s*\s*(.+?)\s*\s*<(?:value|extValue|/result)>!)); return (0+$code,$msg,defined $lang && length $lang ? $lang : 'en'); } ## TODO: implement defaults from 4934bis sub transport_default { my ($self,$tname)=@_; return (defer => 0, socktype => 'ssl', ssl_cipher_list => 'TLSv1', remote_port => 700); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Util.pm0000644000175000017500000001544511352534376020122 0ustar patrickpatrick## Domain Registry Interface, EPP Protocol Utility functions ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Util; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub parse_status { my ($node)=@_; my %tmp; $tmp{name}=$node->getAttribute('s'); $tmp{lang}=$node->getAttribute('lang') || 'en'; $tmp{msg}=$node->textContent() || ''; return \%tmp; } sub parse_msg { my ($node)=@_; ## eppcom:msgType return (($node->getAttribute('lang') || 'en'),$node->textContent()); } sub parse_result { my ($node,$ns,$from)=@_; $from='eppcom' unless defined $from; my ($lang,$msg)=parse_msg($node->getChildrenByTagNameNS($ns,'msg')->get_node(1)); my @i; foreach my $el (Net::DRI::Util::xml_list_children($node)) ## or nodes, all optional { my ($name,$c)=@$el; if ($name eq 'extValue') { my @c=Net::DRI::Util::xml_list_children($c); ## we need to use that, instead of directly firstChild/lastChild because we want only element nodes, not whitespaces if there my $c1=$c[0]->[1]; ## node my $c2=$c[-1]->[1]; ## node my ($ll,$lt)=parse_msg($c2); push @i,{ from => $from.':extValue', type => 'rawxml', message => $c1->toString(), lang => $ll, reason => $lt }; } elsif ($name eq 'value') { push @i,{ from => $from.':value', type => 'rawxml', message => $c->toString() }; } } return { code => $node->getAttribute('code'), message => $msg, lang => $lang, extra_info => \@i }; } #################################################################################################### sub domain_build_command { my ($msg,$command,$domain,$domainattr)=@_; my @dom=(ref($domain))? @$domain : ($domain); Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless @dom; foreach my $d (@dom) { Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined($d) && $d; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$d) unless Net::DRI::Util::is_hostname($d); } my $tcommand=(ref($command))? $command->[0] : $command; $msg->command([$command,'domain:'.$tcommand,sprintf('xmlns:domain="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('domain'))]); my @d=map { ['domain:name',$_,$domainattr] } @dom; return @d; } sub domain_build_authinfo { my ($epp,$rauth,$isupdate)=@_; return ['domain:authInfo',['domain:null']] if ((! defined $rauth->{pw} || $rauth->{pw} eq '') && $epp->{usenullauth} && (defined($isupdate) && $isupdate)); return ['domain:authInfo',['domain:pw',$rauth->{pw},exists($rauth->{roid})? { 'roid' => $rauth->{roid} } : undef]]; } sub build_tel { my ($name,$tel)=@_; if ($tel=~m/^(\S+)x(\S+)$/) { return [$name,$1,{x=>$2}]; } else { return [$name,$tel]; } } sub parse_tel { my $node=shift; my $ext=$node->getAttribute('x') || ''; my $num=$node->textContent(); $num.='x'.$ext if $ext; return $num; } sub build_period { my $dtd=shift; ## DateTime::Duration my ($y,$m)=$dtd->in_units('years','months'); ## all values are integral, but may be negative ($y,$m)=(0,$m+12*$y) if ($y && $m); my ($v,$u); if ($y) { Net::DRI::Exception::usererr_invalid_parameters('years must be between 1 and 99') unless ($y >= 1 && $y <= 99); $v=$y; $u='y'; } else { Net::DRI::Exception::usererr_invalid_parameters('months must be between 1 and 99') unless ($m >= 1 && $m <= 99); $v=$m; $u='m'; } return ['domain:period',$v,{'unit' => $u}]; } sub build_ns { my ($epp,$ns,$domain,$xmlns,$noip)=@_; my @d; my $asattr=$epp->{hostasattr}; if ($asattr) { foreach my $i (1..$ns->count()) { my ($n,$r4,$r6)=$ns->get_details($i); my @h; push @h,['domain:hostName',$n]; if ((($n=~m/\S+\.${domain}$/i) || (lc($n) eq lc($domain)) || ($asattr==2)) && (!defined($noip) || !$noip)) { push @h,map { ['domain:hostAddr',$_,{ip=>'v4'}] } @$r4 if @$r4; push @h,map { ['domain:hostAddr',$_,{ip=>'v6'}] } @$r6 if @$r6; } push @d,['domain:hostAttr',@h]; } } else { @d=map { ['domain:hostObj',$_] } $ns->get_names(); } $xmlns='domain' unless defined($xmlns); return [$xmlns.':ns',@d]; } sub parse_ns ## RFC 4931 §1.1 { my ($po,$node)=@_; my $ns=$po->create_local_object('hosts'); foreach my $el (Net::DRI::Util::xml_list_children($node)) { my ($name,$n)=@$el; if ($name eq 'hostObj') { $ns->add($n->textContent()); } elsif ($name eq 'hostAttr') { my ($hostname,@ip4,@ip6); foreach my $sel (Net::DRI::Util::xml_list_children($n)) { my ($name2,$nn)=@$sel; if ($name2 eq 'hostName') { $hostname=$nn->textContent(); } elsif ($name2 eq 'hostAddr') { my $ip=$nn->getAttribute('ip') || 'v4'; if ($ip eq 'v6') { push @ip6,$nn->textContent(); } else { push @ip4,$nn->textContent(); } } } $ns->add($hostname,\@ip4,\@ip6,1); } } return $ns; } ## was Core::Domain::build_contact_noregistrant sub build_core_contacts { my ($epp,$cs)=@_; my @d; # All nonstandard contacts go into the extension section my %r=map { $_ => 1 } $epp->core_contact_types(); foreach my $t (sort(grep { exists($r{$_}) } $cs->types())) { my @o=$cs->get($t); push @d,map { ['domain:contact',$_->srid(),{'type'=>$t}] } @o; } return @d; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Util - EPP Protocol Utility functions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Core/0002755000175000017500000000000011352534417017524 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Core/Status.pm0000644000175000017500000000710311352534376021350 0ustar patrickpatrick## Domain Registry Interface, EPP Status ## ## Copyright (c) 2005,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Core::Status; use base qw!Net::DRI::Data::StatusList!; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Core::Status - EPP Status for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new('epp','1.0'); my %s=('delete' => 'clientDeleteProhibited', 'renew' => 'clientRenewProhibited', 'update' => 'clientUpdateProhibited', 'transfer' => 'clientTransferProhibited', 'publish' => 'clientHold', ); $self->_register_pno(\%s); my $msg=shift; return $self unless defined($msg); if (ref($msg) eq 'ARRAY') { $self->add(@$msg); } else { Net::DRI::Exception::err_invalid_parameters(); } return $self; } sub is_core_status { return (shift=~m/^client(?:Hold|(?:Delete|Renew|Update|Transfer)Prohibited)$/); } sub build_xml { my ($self,$name,$range)=@_; $range='core' unless defined($range); my @d; my $rd=$self->status_details(); while(my ($k,$v)=each(%$rd)) { next if (($range eq 'core') xor is_core_status($k)); if ($v && ref($v) && keys(%$v)) { my %tmp=(s => $k); $tmp{lang}=$v->{lang} if exists($v->{lang}); push @d,[$name,$v->{msg} || '',\%tmp]; } else { push @d,[$name,{s=>$k}]; } } return @d; } sub is_active { return shift->has_any('ok'); } sub is_published { return shift->has_not('clientHold','serverHold','inactive'); } sub is_pending { return shift->has_any('pendingCreate','pendingDelete','pendingRenew','pendingTransfer','pendingUpdate'); } sub is_linked { return shift->has_any('linked'); } sub can_delete { return shift->has_not('clientDeleteProhibited','serverDeleteProhibited'); } sub can_renew { return shift->has_not('clientRenewProhibited','serverRenewProhibited'); } sub can_update { return shift->has_not('clientUpdateProhibited','serverUpdateProhibited'); } sub can_transfer { return shift->has_not('clientTransferProhibited','serverTransferProhibited'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Core/Host.pm0000644000175000017500000002117711352534376021011 0ustar patrickpatrick## Domain Registry Interface, EPP Host commands (RFC4932) ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Core::Host; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.15 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Core::Host - EPP Host commands (RFC4932 obsoleting RFC3732) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, \&create_parse ], check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], delete => [ \&delete ], update => [ \&update ], review_complete => [ undef, \&pandata_parse ], ); $tmp{check_multi}=$tmp{check}; return { 'host' => \%tmp }; } sub build_command { my ($msg,$command,$hostname)=@_; my @n=map { Net::DRI::Util::isa_hosts($_)? $_->get_names() : $_ } ((ref($hostname) eq 'ARRAY')? @$hostname : ($hostname)); Net::DRI::Exception->die(1,'protocol/EPP',2,'Host name needed') unless @n; foreach my $n (@n) { Net::DRI::Exception->die(1,'protocol/EPP',2,'Host name needed') unless (defined($n) && $n && !ref($n)); Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid host name: '.$n) unless Net::DRI::Util::is_hostname($n); } $msg->command([$command,'host:'.$command,sprintf('xmlns:host="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('host'))]); my @d=map { ['host:name',$_] } @n; return @d; } #################################################################################################### ########### Query commands sub check { my ($epp,$ns)=@_; my $mes=$epp->message(); my @d=build_command($mes,'check',$ns); $mes->command_body(\@d); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $chkdata=$mes->get_response('host','chkData'); return unless defined $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($mes->ns('host'),'cd')) { my $host; foreach my $el (Net::DRI::Util::xml_list_children($cd)) { my ($n,$c)=@$el; if ($n eq 'name') { $host=lc($c->textContent()); $rinfo->{host}->{$host}->{action}='check'; $rinfo->{host}->{$host}->{exist}=1-Net::DRI::Util::xml_parse_boolean($c->getAttribute('avail')); } if ($n eq 'reason') { $rinfo->{host}->{$host}->{exist_reason}=$c->textContent(); } } } } sub info { my ($epp,$ns)=@_; my $mes=$epp->message(); my @d=build_command($mes,'info',$ns); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('host','infData'); return unless defined $infdata; my (@s,@ip4,@ip6); foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{host}->{$oname}->{action}='info'; $rinfo->{host}->{$oname}->{exist}=1; } elsif ($name=~m/^(clID|crID|upID)$/) { $rinfo->{host}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(crDate|upDate|trDate)$/) { $rinfo->{host}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } elsif ($name eq 'roid') { $rinfo->{host}->{$oname}->{roid}=$c->textContent(); } elsif ($name eq 'status') { push @s,Net::DRI::Protocol::EPP::Util::parse_status($c); } elsif ($name eq 'addr') { my $ip=$c->textContent(); my $ipv=$c->getAttribute('ip'); $ipv='v4' unless (defined($ipv) && $ipv); push @ip4,$ip if ($ipv eq 'v4'); push @ip6,$ip if ($ipv eq 'v6'); } } $rinfo->{host}->{$oname}->{status}=$po->create_local_object('status')->add(@s); $rinfo->{host}->{$oname}->{self}=$po->create_local_object('hosts',$oname,\@ip4,\@ip6,1); } ############ Transform commands sub create { my ($epp,$ns)=@_; my $mes=$epp->message(); my @d=build_command($mes,'create',$ns); push @d,add_ip($ns) if Net::DRI::Util::isa_hosts($ns); $mes->command_body(\@d); } sub create_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_response('host','creData'); return unless defined $credata; foreach my $el (Net::DRI::Util::xml_list_children($credata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{host}->{$oname}->{action}='create'; $rinfo->{host}->{$oname}->{exist}=1; } elsif ($name=~m/^(crDate)$/) { $rinfo->{host}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } } sub delete { my ($epp,$ns)=@_; my $mes=$epp->message(); my @d=build_command($mes,'delete',$ns); $mes->command_body(\@d); } sub update { my ($epp,$ns,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a non empty Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); my $nsadd=$todo->add('ip'); my $nsdel=$todo->del('ip'); my $sadd=$todo->add('status'); my $sdel=$todo->del('status'); my $newname=$todo->set('name'); unless (defined($ns) && $ns) { $ns=$nsadd->get_names(1) if Net::DRI::Util::isa_hosts($nsadd); $ns=$nsdel->get_names(1) if Net::DRI::Util::isa_hosts($nsdel); } my (@add,@rem); push @add,add_ip($nsadd) if Net::DRI::Util::isa_hosts($nsadd); push @add,$sadd->build_xml('host:status') if Net::DRI::Util::isa_statuslist($sadd); push @rem,add_ip($nsdel) if Net::DRI::Util::isa_hosts($nsdel); push @rem,$sdel->build_xml('host:status') if Net::DRI::Util::isa_statuslist($sdel); my @d=build_command($mes,'update',$ns); push @d,['host:add',@add] if @add; push @d,['host:rem',@rem] if @rem; if (defined($newname) && length $newname) { Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid host name: '.$newname) unless Net::DRI::Util::is_hostname($newname); push @d,['host:chg',['host:name',$newname]]; } $mes->command_body(\@d); } sub add_ip { my ($ns)=@_; my @ip; my ($name,$r4,$r6)=$ns->get_details(1); push @ip,map { ['host:addr',$_,{ip=>'v4'}] } @$r4 if @$r4; push @ip,map { ['host:addr',$_,{ip=>'v6'}] } @$r6 if @$r6; return @ip; } #################################################################################################### ## RFC4932 §3.3 Offline Review of Requested Actions sub pandata_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $pandata=$mes->get_response('host','panData'); return unless defined $pandata; foreach my $el (Net::DRI::Util::xml_list_children($pandata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{host}->{$oname}->{action}='review'; $rinfo->{host}->{$oname}->{result}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('paResult')); } elsif ($name eq 'paTRID') { my $ns=$mes->ns('_main'); my $tmp=Net::DRI::Util::xml_child_content($c,$ns,'clTRID'); $rinfo->{host}->{$oname}->{trid}=$tmp if defined $tmp; $rinfo->{host}->{$oname}->{svtrid}=Net::DRI::Util::xml_child_content($c,$ns,'svTRID'); } elsif ($name eq 'paDate') { $rinfo->{host}->{$oname}->{date}=$po->parse_iso8601($c->textContent()); } } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Core/Contact.pm0000644000175000017500000003742611352534376021473 0ustar patrickpatrick## Domain Registry Interface, EPP Contact commands (RFC4933) ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Core::Contact; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.18 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Core::Contact - EPP Contact commands (RFC4933 obsoleting RFC3733) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], transfer_query => [ \&transfer_query, \&transfer_parse ], create => [ \&create, \&create_parse ], delete => [ \&delete ], transfer_request => [ \&transfer_request, \&transfer_parse ], transfer_cancel => [ \&transfer_cancel,\&transfer_parse ], transfer_answer => [ \&transfer_answer,\&transfer_parse ], update => [ \&update ], review_complete => [ undef, \&pandata_parse ], ); $tmp{check_multi}=$tmp{check}; return { 'contact' => \%tmp }; } sub build_command { my ($msg,$command,$contact)=@_; my @contact=(ref($contact) eq 'ARRAY')? @$contact : ($contact); my @c=map { Net::DRI::Util::isa_contact($_)? $_->srid() : $_ } @contact; Net::DRI::Exception->die(1,'protocol/EPP',2,'Contact id needed') unless @c; foreach my $n (@c) { Net::DRI::Exception->die(1,'protocol/EPP',2,'Contact id needed') unless defined($n) && $n; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact id: '.$n) unless Net::DRI::Util::xml_is_token($n,3,16); } my $tcommand=(ref($command))? $command->[0] : $command; $msg->command([$command,'contact:'.$tcommand,sprintf('xmlns:contact="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('contact'))]); my @d=map { ['contact:id',$_] } @c; if (($tcommand=~m/^(?:info|transfer)$/) && ref($contact[0]) && Net::DRI::Util::isa_contact($contact[0])) { push @d,build_authinfo($contact[0]); } return @d; } #################################################################################################### ########### Query commands sub check { my ($epp,$c)=@_; my $mes=$epp->message(); my @d=build_command($mes,'check',$c); $mes->command_body(\@d); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $chkdata=$mes->get_response('contact','chkData'); return unless defined $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($mes->ns('contact'),'cd')) { my $contact; foreach my $el (Net::DRI::Util::xml_list_children($cd)) { my ($n,$c)=@$el; if ($n eq 'id') { $contact=$c->textContent(); $rinfo->{contact}->{$contact}->{action}='check'; $rinfo->{contact}->{$contact}->{exist}=1-Net::DRI::Util::xml_parse_boolean($c->getAttribute('avail')); } if ($n eq 'reason') { $rinfo->{contact}->{$contact}->{exist_reason}=$c->textContent(); } } } } sub info { my ($epp,$c)=@_; my $mes=$epp->message(); my @d=build_command($mes,'info',$c); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('contact','infData'); return unless defined $infdata; my %cd=map { $_ => [] } qw/name org street city sp pc cc/; my $contact=$po->create_local_object('contact'); my @s; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'id') { $oname=$c->textContent(); $rinfo->{contact}->{$oname}->{action}='info'; $rinfo->{contact}->{$oname}->{exist}=1; $rinfo->{contact}->{$oname}->{id}=$oname; $contact->srid($oname); } elsif ($name eq 'roid') { $contact->roid($c->textContent()); $rinfo->{contact}->{$oname}->{roid}=$contact->roid(); } elsif ($name eq 'status') { push @s,Net::DRI::Protocol::EPP::Util::parse_status($c); } elsif ($name=~m/^(clID|crID|upID)$/) { $rinfo->{contact}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(crDate|upDate|trDate)$/) { $rinfo->{contact}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } elsif ($name eq 'email') { $contact->email($c->textContent()); } elsif ($name eq 'voice') { $contact->voice(Net::DRI::Protocol::EPP::Util::parse_tel($c)); } elsif ($name eq 'fax') { $contact->fax(Net::DRI::Protocol::EPP::Util::parse_tel($c)); } elsif ($name eq 'postalInfo') { parse_postalinfo($po,$c,\%cd); } elsif ($name eq 'authInfo') ## we only try to parse the authInfo version defined in the RFC, other cases are to be handled by extensions { $contact->auth({pw => scalar Net::DRI::Util::xml_child_content($c,$mes->ns('contact'),'pw')}); } elsif ($name eq 'disclose') { $contact->disclose(parse_disclose($c)); } } $contact->name(@{$cd{name}}); $contact->org(@{$cd{org}}); $contact->street(@{$cd{street}}); $contact->city(@{$cd{city}}); $contact->sp(@{$cd{sp}}); $contact->pc(@{$cd{pc}}); $contact->cc(@{$cd{cc}}); $rinfo->{contact}->{$oname}->{status}=$po->create_local_object('status')->add(@s); $rinfo->{contact}->{$oname}->{self}=$contact; } sub parse_postalinfo { my ($epp,$c,$rcd)=@_; my $type=$c->getAttribute('type'); ## int or loc, mandatory in EPP ! $type=$epp->{defaulti18ntype} if (!defined($type) && defined($epp->{defaulti18ntype})); my $ti={loc=>0,int=>1}->{$type}; foreach my $el (Net::DRI::Util::xml_list_children($c)) { my ($name,$n)=@$el; if ($name eq 'name') { $rcd->{name}->[$ti]=$n->textContent(); } elsif ($name eq 'org') { $rcd->{org}->[$ti]=$n->textContent(); } elsif ($name eq 'addr') { my @street; foreach my $sel (Net::DRI::Util::xml_list_children($n)) { my ($name2,$nn)=@$sel; if ($name2 eq 'street') { push @street,$nn->textContent(); } elsif ($name2 eq 'city') { $rcd->{city}->[$ti]=$nn->textContent(); } elsif ($name2 eq 'sp') { $rcd->{sp}->[$ti]=$nn->textContent(); } elsif ($name2 eq 'pc') { $rcd->{pc}->[$ti]=$nn->textContent(); } elsif ($name2 eq 'cc') { $rcd->{cc}->[$ti]=$nn->textContent(); } } $rcd->{street}->[$ti]=\@street; } } } sub parse_disclose ## RFC 4933 §2.9 { my $c=shift; my $flag=Net::DRI::Util::xml_parse_boolean($c->getAttribute('flag')); my %tmp; foreach my $el (Net::DRI::Util::xml_list_children($c)) { my ($name,$n)=@$el; if ($name=~m/^(name|org|addr)$/) { my $t=$n->getAttribute('type'); $tmp{$1.'_'.$t}=$flag; } elsif ($name=~m/^(voice|fax|email)$/) { $tmp{$1}=$flag; } } return \%tmp; } sub transfer_query { my ($epp,$c)=@_; my $mes=$epp->message(); my @d=build_command($mes,['transfer',{'op'=>'query'}],$c); $mes->command_body(\@d); } sub transfer_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $trndata=$mes->get_response('contact','trnData'); return unless defined $trndata; foreach my $el (Net::DRI::Util::xml_list_children($trndata)) { my ($name,$c)=@$el; if ($name eq 'id') { $oname=$c->textContent(); $rinfo->{contact}->{$oname}->{id}=$oname; $rinfo->{contact}->{$oname}->{action}='transfer'; $rinfo->{contact}->{$oname}->{exist}=1; } elsif ($name=~m/^(trStatus|reID|acID)$/) { $rinfo->{contact}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(reDate|acDate)$/) { $rinfo->{contact}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } } ############ Transform commands sub build_authinfo { my $contact=shift; my $az=$contact->auth(); return () unless ($az && ref($az) && exists($az->{pw})); return ['contact:authInfo',['contact:pw',$az->{pw}]]; } sub build_disclose { my $contact=shift; my $d=$contact->disclose(); return () unless ($d && ref($d)); my %v=map { $_ => 1 } values(%$d); return () unless (keys(%v)==1); ## 1 or 0 as values, not both at same time my @d; push @d,['contact:name',{type=>'int'}] if (exists($d->{name_int}) && !exists($d->{name})); push @d,['contact:name',{type=>'loc'}] if (exists($d->{name_loc}) && !exists($d->{name})); push @d,['contact:name',{type=>'int'}],['contact:name',{type=>'loc'}] if exists($d->{name}); push @d,['contact:org',{type=>'int'}] if (exists($d->{org_int}) && !exists($d->{org})); push @d,['contact:org',{type=>'loc'}] if (exists($d->{org_loc}) && !exists($d->{org})); push @d,['contact:org',{type=>'int'}],['contact:org',{type=>'loc'}] if exists($d->{org}); push @d,['contact:addr',{type=>'int'}] if (exists($d->{addr_int}) && !exists($d->{addr})); push @d,['contact:addr',{type=>'loc'}] if (exists($d->{addr_loc}) && !exists($d->{addr})); push @d,['contact:addr',{type=>'int'}],['contact:addr',{type=>'loc'}] if exists($d->{addr}); push @d,['contact:voice'] if exists($d->{voice}); push @d,['contact:fax'] if exists($d->{fax}); push @d,['contact:email'] if exists($d->{email}); return ['contact:disclose',@d,{flag=>(keys(%v))[0]}]; } sub build_cdata { my ($contact,$v)=@_; my $hasloc=$contact->has_loc(); my $hasint=$contact->has_int(); if ($hasint && !$hasloc && (($v & 5) == $v)) { $contact->int2loc(); $hasloc=1; } elsif ($hasloc && !$hasint && (($v & 6) == $v)) { $contact->loc2int(); $hasint=1; } my (@postl,@posti,@addrl,@addri); _do_locint(\@postl,\@posti,$contact,'name'); _do_locint(\@postl,\@posti,$contact,'org'); _do_locint(\@addrl,\@addri,$contact,'street'); _do_locint(\@addrl,\@addri,$contact,'city'); _do_locint(\@addrl,\@addri,$contact,'sp'); _do_locint(\@addrl,\@addri,$contact,'pc'); _do_locint(\@addrl,\@addri,$contact,'cc'); push @postl,['contact:addr',@addrl] if @addrl; push @posti,['contact:addr',@addri] if @addri; my @d; push @d,['contact:postalInfo',@postl,{type=>'loc'}] if (($v & 5) && $hasloc); ## loc+int OR loc push @d,['contact:postalInfo',@posti,{type=>'int'}] if (($v & 6) && $hasint); ## loc+int OR int push @d,Net::DRI::Protocol::EPP::Util::build_tel('contact:voice',$contact->voice()) if defined($contact->voice()); push @d,Net::DRI::Protocol::EPP::Util::build_tel('contact:fax',$contact->fax()) if defined($contact->fax()); push @d,['contact:email',$contact->email()] if defined($contact->email()); push @d,build_authinfo($contact); push @d,build_disclose($contact); return @d; } sub _do_locint { my ($rl,$ri,$contact,$what)=@_; my @tmp=$contact->$what(); return unless @tmp; if ($what eq 'street') { if (defined($tmp[0])) { foreach (@{$tmp[0]}) { push @$rl,['contact:street',$_]; } }; if (defined($tmp[1])) { foreach (@{$tmp[1]}) { push @$ri,['contact:street',$_]; } }; } else { if (defined($tmp[0])) { push @$rl,['contact:'.$what,$tmp[0]]; } if (defined($tmp[1])) { push @$ri,['contact:'.$what,$tmp[1]]; } } } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); my @d=build_command($mes,'create',$contact); Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact '.$contact) unless Net::DRI::Util::isa_contact($contact); $contact->validate(); ## will trigger an Exception if needed push @d,build_cdata($contact,$epp->{contacti18n}); $mes->command_body(\@d); } sub create_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_response('contact','creData'); return unless defined $credata; foreach my $el (Net::DRI::Util::xml_list_children($credata)) { my ($name,$c)=@$el; if ($name eq 'id') { my $new=$c->textContent(); $rinfo->{contact}->{$oname}->{id}=$new if (defined $oname && ($oname ne $new)); ## registry may give another id than the one we requested or not take ours into account at all ! $oname=$new; $rinfo->{contact}->{$oname}->{id}=$oname; $rinfo->{contact}->{$oname}->{action}='create'; $rinfo->{contact}->{$oname}->{exist}=1; } elsif ($name=~m/^(crDate)$/) { $rinfo->{contact}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } } sub delete { my ($epp,$contact)=@_; my $mes=$epp->message(); my @d=build_command($mes,'delete',$contact); $mes->command_body(\@d); } sub transfer_request { my ($epp,$c)=@_; my $mes=$epp->message(); my @d=build_command($mes,['transfer',{'op'=>'request'}],$c); $mes->command_body(\@d); } sub transfer_cancel { my ($epp,$c)=@_; my $mes=$epp->message(); my @d=build_command($mes,['transfer',{'op'=>'cancel'}],$c); $mes->command_body(\@d); } sub transfer_answer { my ($epp,$c,$approve)=@_; my $mes=$epp->message(); my @d=build_command($mes,['transfer',{'op'=>((defined($approve) && $approve)? 'approve' : 'reject' )}],$c); $mes->command_body(\@d); } sub update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a non empty Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); my $sadd=$todo->add('status'); my $sdel=$todo->del('status'); my @d=build_command($mes,'update',$contact); push @d,['contact:add',$sadd->build_xml('contact:status')] if Net::DRI::Util::isa_statuslist($sadd); push @d,['contact:rem',$sdel->build_xml('contact:status')] if Net::DRI::Util::isa_statuslist($sdel); my $newc=$todo->set('info'); if (defined $newc) { Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact '.$newc) unless Net::DRI::Util::isa_contact($newc); $newc->validate(1); ## will trigger an Exception if needed my @c=build_cdata($newc,$epp->{contacti18n}); push @d,['contact:chg',@c] if @c; } $mes->command_body(\@d); } #################################################################################################### ## RFC4933 §3.3 Offline Review of Requested Actions sub pandata_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $pandata=$mes->get_response('contact','panData'); return unless defined $pandata; foreach my $el (Net::DRI::Util::xml_list_children($pandata)) { my ($name,$c)=@$el; if ($name eq 'id') { $oname=$c->textContent(); $rinfo->{contact}->{$oname}->{action}='review'; $rinfo->{contact}->{$oname}->{result}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('paResult')); } elsif ($name eq 'paTRID') { my $ns=$mes->ns('_main'); my $tmp=Net::DRI::Util::xml_child_content($c,$ns,'clTRID'); $rinfo->{contact}->{$oname}->{trid}=$tmp if defined $tmp; $rinfo->{contact}->{$oname}->{svtrid}=Net::DRI::Util::xml_child_content($c,$ns,'svTRID'); } elsif ($name eq 'paDate') { $rinfo->{contact}->{$oname}->{date}=$po->parse_iso8601($c->textContent()); } } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Core/RegistryMessage.pm0000644000175000017500000001233511352534376023205 0ustar patrickpatrick## Domain Registry Interface, EPP Registry messages commands (RFC4930) ## ## Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Core::RegistryMessage; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.13 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Core::RegistryMessage - EPP Registry messages commands (RFC4930 obsoleting RFC3730) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( retrieve => [ \&pollreq, \&parse_poll ], delete => [ \&pollack ], ); return { 'message' => \%tmp }; } sub pollack { my ($epp,$msgid)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters('In EPP, you must specify the message id (XML token) you want to delete') unless Net::DRI::Util::xml_is_token($msgid); $mes->command([['poll',{op=>'ack',msgID=>$msgid}]]); } sub pollreq { my ($epp,$msgid)=@_; Net::DRI::Exception::usererr_invalid_parameters('In EPP, you can not specify the message id you want to retrieve') if defined($msgid); my $mes=$epp->message(); $mes->command([['poll',{op=>'req'}]]); } ## We take into account all parse functions, to be able to parse any result sub parse_poll { my ($po,$otype,$oaction,$oname,$rinfo)=@_; return if exists $rinfo->{_processing_parse_poll}; ## calling myself here would be a very bad idea ! my $mes=$po->message(); return unless $mes->is_success(); my $msgid=$mes->msg_id(); return unless (defined($msgid) && $msgid); $rinfo->{message}->{session}->{last_id}=$msgid; ## needed here and not lower below, in case of pure text registry message ## Was there really a registry message with some content ? return unless ($mes->result_code() == 1301 && (defined($mes->node_resdata()) || defined($mes->node_extension()) || defined($mes->node_msg()))); my $rd=$rinfo->{message}->{$msgid}; ## already partially filled by Message::parse() my ($totype,$toaction,$toname); ## $toaction will remain undef, but could be $haction if only one my %info; my $h=$po->commands(); while (my ($htype,$hv)=each(%$h)) { while (my ($haction,$hv2)=each(%$hv)) { foreach my $t (@$hv2) { my $pf=$t->[1]; next unless (defined($pf) && (ref($pf) eq 'CODE')); $info{_processing_parse_poll}=1; $pf->($po,$totype,$toaction,$toname,\%info); delete $info{_processing_parse_poll}; next unless keys(%info); next if defined($toname); ## this must be there and not optimised as a last call further below as there can be multiple information to parse for a given $toname my @tmp=keys %info; Net::DRI::Exception::err_assert('EPP::parse_poll can not handle multiple types !') unless @tmp==1; $totype=$tmp[0]; @tmp=keys %{$info{$totype}}; Net::DRI::Exception::err_assert('EPP::parse_poll can not handle multiple names !') unless @tmp==1; ## this may happen for check_multi ! $toname=$tmp[0]; $info{$totype}->{$toname}->{name}=$toname; } } } ## If message not completely in the node, we have to parse something ! Net::DRI::Exception::err_assert('EPP::parse_poll was not able to parse anything, please report !') if ((defined($mes->node_resdata()) || defined($mes->node_extension())) && ! defined $toname); ## Copy local %info into $rd (which is in fact global info as set above) someway (we're working with references) ## Here, $rd=$rinfo->{message}->{$msgid} $rd->{object_type}=$totype; $rd->{object_id}=$toname; ## this has to be taken broadly, it is in fact a name for domains and hosts while(my ($k,$v)=each(%{$info{$totype}->{$toname}})) { $rd->{$k}=$v; } ## Also update data about the queried object, for easier access while(my ($k,$v)=each(%$rd)) { $rinfo->{$totype}->{$toname}->{$k}=$v; } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Core/Session.pm0000644000175000017500000001046011352534377021511 0ustar patrickpatrick## Domain Registry Interface, EPP Session commands (RFC4930) ## ## Copyright (c) 2005,2006,2007 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::EPP::Core::Session; use strict; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Core::Session - EPP Session commands (RFC4930 obsoleting RFC3730) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( noop => [ \&hello ], logout => [ \&logout ], login => [ \&login ], connect => [ \&hello, \&parse_greeting ], ); return { 'session' => \%tmp }; } sub hello ## should trigger a greeting from server, allowed at any time { my ($epp)=@_; my $mes=$epp->message(); $mes->command(['hello']); } sub parse_greeting { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); $po->server_greeting($mes->result_greeting()); } sub logout { my ($epp)=@_; my $mes=$epp->message(); $mes->command(['logout']); } sub login { my ($epp,$id,$pass,$newpass,$opts)=@_; Net::DRI::Exception::usererr_insufficient_parameters('login & password') unless (defined($id) && $id && defined($pass) && $pass); Net::DRI::Exception::usererr_invalid_parameters('login') unless Net::DRI::Util::xml_is_token($id,3,16); Net::DRI::Exception::usererr_invalid_parameters('password') unless Net::DRI::Util::xml_is_token($pass,6,16); Net::DRI::Exception::usererr_invalid_parameters('new password') if ($newpass && !Net::DRI::Util::xml_is_token($newpass,6,16)); my $mes=$epp->message(); $mes->command(['login']); my @d; push @d,['clID',$id]; push @d,['pw',$pass]; push @d,['newPW',$newpass] if $newpass; my $rg=$epp->server_greeting(); my @o; my $tmp=_opt($opts,$rg,'version'); Net::DRI::Exception::usererr_insufficient_parameters('version') unless defined($tmp); $tmp=$tmp->[0] if ref($tmp); Net::DRI::Exception::usererr_invalid_parameters('version') unless ($tmp=~m/^[1-9]+\.[0-9]+$/); push @o,['version',$tmp]; $tmp=_opt($opts,$rg,'lang'); Net::DRI::Exception::usererr_insufficient_parameters('lang') unless defined($tmp); $tmp=$tmp->[0] if ref($tmp); Net::DRI::Exception::usererr_invalid_parameters('lang') unless ($tmp=~m/^[a-z]{1,8}(?:-[a-z0-9]{1,8})?$/i); push @o,['lang',$tmp]; push @d,['options',@o]; my @s; $tmp=_opt($opts,$rg,'svcs'); push @s,map { ['objURI',$_] } @$tmp if (defined($tmp) && (ref($tmp) eq 'ARRAY')); $tmp=_opt($opts,$rg,'svcext'); push @s,['svcExtension',map {['extURI',$_]} @$tmp] if (defined($tmp) && (ref($tmp) eq 'ARRAY')); push @d,['svcs',@s] if @s; $mes->command_body(\@d); } sub _opt { my ($ro,$rg,$w)=@_; return $ro->{$w} if ($ro && (ref($ro) eq 'HASH') && exists($ro->{$w})); return $rg->{$w} if ($rg && (ref($rg) eq 'HASH') && exists($rg->{$w})); return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Core/Domain.pm0000644000175000017500000003402011352534377021273 0ustar patrickpatrick## Domain Registry Interface, EPP Domain commands (RFC4931) ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Core::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.21 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Core::Domain - EPP Domain commands (RFC4931 obsoleting RFC3731) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], transfer_query => [ \&transfer_query, \&transfer_parse ], create => [ \&create, \&create_parse ], delete => [ \&delete ], renew => [ \&renew, \&renew_parse ], transfer_request => [ \&transfer_request, \&transfer_parse ], transfer_cancel => [ \&transfer_cancel,\&transfer_parse ], transfer_answer => [ \&transfer_answer,\&transfer_parse ], update => [ \&update ], review_complete => [ undef, \&pandata_parse ], ); $tmp{check_multi}=$tmp{check}; return { 'domain' => \%tmp }; } #################################################################################################### ########### Query commands sub check { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'check',$domain); $mes->command_body(\@d); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $chkdata=$mes->get_response('domain','chkData'); return unless defined $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($mes->ns('domain'),'cd')) { my $domain; foreach my $el (Net::DRI::Util::xml_list_children($cd)) { my ($n,$c)=@$el; if ($n eq 'name') { $domain=lc($c->textContent()); $rinfo->{domain}->{$domain}->{action}='check'; $rinfo->{domain}->{$domain}->{exist}=1-Net::DRI::Util::xml_parse_boolean($c->getAttribute('avail')); } elsif ($n eq 'reason') { $rinfo->{domain}->{$domain}->{exist_reason}=$c->textContent(); } } } } sub info { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $hosts='all'; $hosts=$rd->{hosts} if (defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{hosts}) && ($rd->{hosts}=~m/^(?:all|del|sub|none)$/)); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'info',$domain,{'hosts'=> $hosts}); push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('domain','infData'); return unless defined $infdata; my (@s,@host); my $cs=$po->create_local_object('contactset'); foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{domain}->{$oname}->{action}='info'; $rinfo->{domain}->{$oname}->{exist}=1; } elsif ($name eq 'roid') { $rinfo->{domain}->{$oname}->{roid}=$c->textContent(); } elsif ($name eq 'status') { push @s,Net::DRI::Protocol::EPP::Util::parse_status($c); } elsif ($name eq 'registrant') { $cs->set($po->create_local_object('contact')->srid($c->textContent()),'registrant'); } elsif ($name eq 'contact') { $cs->add($po->create_local_object('contact')->srid($c->textContent()),$c->getAttribute('type')); } elsif ($name eq 'ns') { $rinfo->{domain}->{$oname}->{ns}=Net::DRI::Protocol::EPP::Util::parse_ns($po,$c); } elsif ($name eq 'host') { push @host,$c->textContent(); } elsif ($name=~m/^(clID|crID|upID)$/) { $rinfo->{domain}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(crDate|upDate|trDate|exDate)$/) { $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } elsif ($name eq 'authInfo') ## we only try to parse the authInfo version defined in the RFC, other cases are to be handled by extensions { $rinfo->{domain}->{$oname}->{auth}={pw => scalar Net::DRI::Util::xml_child_content($c,$mes->ns('domain'),'pw')}; } } $rinfo->{domain}->{$oname}->{contact}=$cs; $rinfo->{domain}->{$oname}->{status}=$po->create_local_object('status')->add(@s); $rinfo->{domain}->{$oname}->{host}=$po->create_local_object('hosts')->set(@host) if @host; } sub transfer_query { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>'query'}],$domain); push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub transfer_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $trndata=$mes->get_response('domain','trnData'); return unless defined $trndata; foreach my $el (Net::DRI::Util::xml_list_children($trndata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{domain}->{$oname}->{action}='transfer'; $rinfo->{domain}->{$oname}->{exist}=1; } elsif ($name=~m/^(trStatus|reID|acID)$/) { $rinfo->{domain}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(reDate|acDate|exDate)$/) { $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } } ############ Transform commands sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'create',$domain); my $def=$epp->default_parameters(); if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) && (ref($def->{domain_create}) eq 'HASH')) { $rd={} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd)); while(my ($k,$v)=each(%{$def->{domain_create}})) { next if exists($rd->{$k}); $rd->{$k}=$v; } } ## Period, OPTIONAL push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd); ## Nameservers, OPTIONAL push @d,Net::DRI::Protocol::EPP::Util::build_ns($epp,$rd->{ns},$domain) if Net::DRI::Util::has_ns($rd); ## Contacts, all OPTIONAL if (Net::DRI::Util::has_contact($rd)) { my $cs=$rd->{contact}; my @o=$cs->get('registrant'); push @d,['domain:registrant',$o[0]->srid()] if (@o && Net::DRI::Util::isa_contact($o[0])); push @d,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cs); } ## AuthInfo Net::DRI::Exception::usererr_insufficient_parameters('authInfo is mandatory') unless Net::DRI::Util::has_auth($rd); push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}); $mes->command_body(\@d); } sub create_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_response('domain','creData'); return unless defined $credata; foreach my $el (Net::DRI::Util::xml_list_children($credata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{domain}->{$oname}->{action}='create'; $rinfo->{domain}->{$oname}->{exist}=1; } elsif ($name=~m/^(crDate|exDate)$/) { $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } } sub delete { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'delete',$domain); $mes->command_body(\@d); } sub renew { my ($epp,$domain,$rd)=@_; my $curexp=Net::DRI::Util::has_key($rd,'current_expiration')? $rd->{current_expiration} : undef; Net::DRI::Exception::usererr_insufficient_parameters('current expiration date') unless defined($curexp); $curexp=$curexp->set_time_zone('UTC')->strftime('%Y-%m-%d') if (ref($curexp) && Net::DRI::Util::check_isa($curexp,'DateTime')); Net::DRI::Exception::usererr_invalid_parameters('current expiration date must be YYYY-MM-DD') unless $curexp=~m/^\d{4}-\d{2}-\d{2}$/; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'renew',$domain); push @d,['domain:curExpDate',$curexp]; push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd); $mes->command_body(\@d); } sub renew_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rendata=$mes->get_response('domain','renData'); return unless defined $rendata; foreach my $el (Net::DRI::Util::xml_list_children($rendata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{domain}->{$oname}->{action}='renew'; $rinfo->{domain}->{$oname}->{exist}=1; } elsif ($name=~m/^(exDate)$/) { $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } } sub transfer_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>'request'}],$domain); push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd); push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub transfer_answer { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>(Net::DRI::Util::has_key($rd,'approve') && $rd->{approve})? 'approve' : 'reject'}],$domain); push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub transfer_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>'cancel'}],$domain); push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a non empty Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); my $nsadd=$todo->add('ns'); my $nsdel=$todo->del('ns'); my $sadd=$todo->add('status'); my $sdel=$todo->del('status'); my $cadd=$todo->add('contact'); my $cdel=$todo->del('contact'); my (@add,@del); push @add,Net::DRI::Protocol::EPP::Util::build_ns($epp,$nsadd,$domain) if Net::DRI::Util::isa_hosts($nsadd); push @add,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cadd) if Net::DRI::Util::isa_contactset($cadd); push @add,$sadd->build_xml('domain:status','core') if Net::DRI::Util::isa_statuslist($sadd); push @del,Net::DRI::Protocol::EPP::Util::build_ns($epp,$nsdel,$domain,undef,1) if Net::DRI::Util::isa_hosts($nsdel); push @del,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cdel) if Net::DRI::Util::isa_contactset($cdel); push @del,$sdel->build_xml('domain:status','core') if Net::DRI::Util::isa_statuslist($sdel); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'update',$domain); push @d,['domain:add',@add] if @add; push @d,['domain:rem',@del] if @del; my $chg=$todo->set('registrant'); my @chg; push @chg,['domain:registrant',$chg->srid()] if Net::DRI::Util::isa_contact($chg); $chg=$todo->set('auth'); push @chg,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$chg,1) if ($chg && (ref $chg eq 'HASH') && exists $chg->{pw}); push @d,['domain:chg',@chg] if @chg; $mes->command_body(\@d); } #################################################################################################### ## RFC4931 §3.3 Offline Review of Requested Actions sub pandata_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $pandata=$mes->get_response('domain','panData'); return unless defined $pandata; foreach my $el (Net::DRI::Util::xml_list_children($pandata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{domain}->{$oname}->{action}='review'; $rinfo->{domain}->{$oname}->{result}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('paResult')); } elsif ($name eq 'paTRID') { my $ns=$mes->ns('_main'); my $tmp=Net::DRI::Util::xml_child_content($c,$ns,'clTRID'); $rinfo->{domain}->{$oname}->{trid}=$tmp if defined $tmp; $rinfo->{domain}->{$oname}->{svtrid}=Net::DRI::Util::xml_child_content($c,$ns,'svTRID'); } elsif ($name eq 'paDate') { $rinfo->{domain}->{$oname}->{date}=$po->parse_iso8601($c->textContent()); } } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/0002755000175000017500000000000011352534417020773 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AERO/0002755000175000017500000000000011352534417021521 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AERO/Contact.pm0000644000175000017500000000576311352534377023470 0ustar patrickpatrick## Domain Registry Interface, .AERO Contact EPP extension commands ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AERO::Contact; use strict; use Net::DRI::Util; use DateTime::Format::ISO8601; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AERO::Contact - .AERO EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], ); return { 'contact' => \%tmp }; } #################################################################################################### sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('aero','infData'); return unless $infdata; my $c=$infdata->getChildrenByTagNameNS($mes->ns('aero'),'ensInfo'); return unless ($c && $c->size()==1); $c=$c->shift()->getFirstChild(); my %ens; while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if (my ($tag)=($name=~m/^(\S+)$/)) { $ens{Net::DRI::Util::remcam($tag)}=$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } $ens{last_checked_date}=DateTime::Format::ISO8601->new()->parse_datetime($ens{last_checked_date}) if exists($ens{last_checked_date}); $rinfo->{contact}->{$oname}->{self}->ens(\%ens); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AERO/Domain.pm0000644000175000017500000000675611352534377023307 0ustar patrickpatrick## Domain Registry Interface, .AERO Domain EPP extension commands ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AERO::Domain; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AERO::Domain - .AERO EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], info => [ undef, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:aero="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('aero'))); } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('ens attribute is mandatory, as ref hash with keys auth_id and auth_key') unless (exists($rd->{ens}) && (ref($rd->{ens}) eq 'HASH') && exists($rd->{ens}->{auth_id}) && $rd->{ens}->{auth_id} && exists($rd->{ens}->{auth_key}) && $rd->{ens}->{auth_key}); my @n; push @n,['aero:ensAuthID',$rd->{ens}->{auth_id}]; push @n,['aero:ensAuthKey',$rd->{ens}->{auth_key}]; my $eid=build_command_extension($mes,$epp,'aero:create'); $mes->command_extension($eid,\@n); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('aero','infData'); return unless $infdata; my %ens; my $c=$infdata->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'ensAuthID') { $ens{auth_id}=$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } $rinfo->{domain}->{$oname}->{ens}=\%ens; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/0002755000175000017500000000000011352534417021613 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/Status.pm0000644000175000017500000000456711352534377023453 0ustar patrickpatrick## Domain Registry Interface, EPP Status for AFNIC (.FR/.RE) ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AFNIC::Status; use base qw/Net::DRI::Protocol::EPP::Core::Status/; use strict; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AFNIC::Status - AFNIC (.FR/.RE) EPP Status for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(shift); ## Overwrite, as only clientHold is available my %s=( 'publish' => 'clientHold', ); $self->_register_pno(\%s); return $self; } sub is_pending { return shift->has_any('pendingCreate','pendingDelete','pendingRenew','pendingTransfer','pendingUpdate','pendingRestore'); } sub can_trade { return shift->has_not('serverTradeProhibited'); } sub can_recover { return shift->has_not('serverRecoverProhibited'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/Contact.pm0000644000175000017500000002010611352534377023546 0ustar patrickpatrick## Domain Registry Interface, AFNIC (.FR/.RE) Contact EPP extension commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AFNIC::Contact; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AFNIC::Contact - AFNIC (.FR/.RE) EPP Contact extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, \&create_parse ], update => [ \&update, undef ], info => [ undef, \&info_parse ], ); return { 'contact' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:frnic="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('frnic'))); } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); ## validate() has been called my @n; if ($contact->legal_form()) # PM { my @d; Net::DRI::Exception::usererr_insufficient_parameters('legal_form data mandatory') unless ($contact->legal_form()); Net::DRI::Exception::usererr_invalid_parameters('legal_form_other data mandatory if legal_form=other') if (($contact->legal_form() eq 'other') && !$contact->legal_form_other()); push @d,['frnic:legalStatus',{s => $contact->legal_form()},$contact->legal_form() eq 'other'? $contact->legal_form_other() : '']; push @d,['frnic:siren',$contact->legal_id()] if $contact->legal_id(); push @d,['frnic:VAT',$contact->vat()] if $contact->vat(); push @d,['frnic:trademark',$contact->trademark()] if $contact->trademark(); my $jo=$contact->jo(); if (defined($jo) && (ref($jo) eq 'HASH')) { my @j; push @j,['frnic:waldec',$jo->{waldec}] if exists $jo->{waldec}; push @j,['frnic:waldec',$contact->legal_id()] if (defined $contact->legal_id() && defined $contact->legal_form_other() && $contact->legal_form_other() eq 'asso'); ## not sure API ok push @j,['frnic:decl',$jo->{date_declaration}]; push @j,['frnic:publ',{announce=>$jo->{number},page=>$jo->{page}},$jo->{date_publication}]; push @d,['frnic:asso',@j]; } push @n,['frnic:legalEntityInfos',@d]; } else # PP { push @n,['frnic:list','restrictedPublication'] if (defined $contact->disclose() && $contact->disclose() eq 'N'); my @d; my $b=$contact->birth(); Net::DRI::Exception::usererr_insufficient_parameters('birth data mandatory') unless ($b && (ref($b) eq 'HASH') && exists($b->{date}) && exists($b->{place})); push @d,['frnic:birthDate',(ref($b->{date}))? $b->{date}->strftime('%Y-%m-%d') : $b->{date}]; if ($b->{place}=~m/^[A-Z]{2}$/i) ## country not France { push @d,['frnic:birthCc',$b->{place}]; } else { my @p=($b->{place}=~m/^\s*(\S.*\S)\s*,\s*(\S.+\S)\s*$/); push @d,['frnic:birthCity',$p[1]]; push @d,['frnic:birthPc',$p[0]]; push @d,['frnic:birthCc','FR']; } push @n,['frnic:individualInfos',@d]; push @n,['frnic:firstName',$contact->firstname()]; } my $eid=build_command_extension($mes,$epp,'frnic:ext'); $mes->command_extension($eid,['frnic:create',['frnic:contact',@n]]); } sub create_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_extension('frnic','ext'); return unless defined $credata; my $ns=$mes->ns('frnic'); $credata=Net::DRI::Util::xml_traverse($credata,$ns,'resData','creData'); return unless defined $credata; $oname=$rinfo->{contact}->{$oname}->{id}; ## take into account true ID (the one returned by the registry) foreach my $el (Net::DRI::Util::xml_list_children($credata)) { my ($name,$c)=@$el; if ($name eq 'nhStatus') { $rinfo->{contact}->{$oname}->{new_handle}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('new')); } elsif ($name eq 'idStatus') { $rinfo->{contact}->{$oname}->{identification}=$c->textContent(); } } } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $dadd=$todo->add('disclose'); my $ddel=$todo->del('disclose'); return unless ($dadd || $ddel); my @n; push @n,['frnic:add',['frnic:list',$dadd]] if $dadd; push @n,['frnic:rem',['frnic:list',$ddel]] if $ddel; my $eid=build_command_extension($mes,$epp,'frnic:ext'); $mes->command_extension($eid,['frnic:update',['frnic:contact',@n]]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('frnic','ext'); return unless defined $infdata; my $ns=$mes->ns('frnic'); $infdata=Net::DRI::Util::xml_traverse($infdata,$ns,'resData','infData','contact'); return unless defined $infdata; my $co=$rinfo->{contact}->{$oname}->{self}; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'firstName') { $co->firstname($c->textContent()); } elsif ($name eq 'list') { $co->disclose($c->textContent() eq 'restrictedPublication'? 'N' : 'Y'); } elsif ($name eq 'individualInfos') { my %b; foreach my $sel (Net::DRI::Util::xml_list_children($c)) { my ($nn,$cc)=@$sel; if ($nn eq 'idStatus') { $rinfo->{contact}->{$oname}->{identification}=$cc->textContent(); } elsif ($nn eq 'birthDate') { $b{date}=$cc->textContent(); } elsif ($nn eq 'birthCity') { $b{place}=$cc->textContent(); } elsif ($nn eq 'birthPc') { $b{place}=sprintf('%s, %s',$cc->textContent(),$b{place}); } elsif ($nn eq 'birthCc') { my $v=$cc->textContent(); $b{place}=$v unless ($v eq 'FR'); } } $co->birth(\%b); } elsif ($name eq 'legalEntityInfos') { foreach my $sel (Net::DRI::Util::xml_list_children($c)) { my ($nn,$cc)=@$sel; if ($nn eq 'legalStatus') { $co->legal_form($cc->getAttribute('type')); my $v=$cc->textContent(); $co->legal_form_other($v) if $v; } elsif ($nn eq 'siren') { $co->legal_id($cc->textContent()); } elsif ($nn eq 'trademark') { $co->trademark($cc->textContent()); } elsif ($nn eq 'asso') { my %jo; my $ccc=$cc->getChildrenByTagNameNS($mes->ns('frnic'),'decl'); $jo{date_declaration}=$ccc->get_node(1)->textContent() if ($ccc->size()); $ccc=$cc->getChildrenByTagNameNS($mes->ns('frnic'),'publ'); if ($ccc->size()) { my $p=$ccc->get_node(1); $jo{number}=$p->getAttribute('announce'); $jo{page}=$p->getAttribute('page'); $jo{date_publication}=$p->textContent(); } $co->jo(\%jo); } } } } return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/Domain.pm0000644000175000017500000002377511352534377023401 0ustar patrickpatrick## Domain Registry Interface, AFNIC EPP Domain extensions ## ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AFNIC::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AFNIC::Domain - AFNIC (.FR/.RE) EPP Domain extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], transfer_request => [ \&transfer_request, undef ], trade_request => [ \&trade_request, \&trade_parse ], trade_query => [ \&trade_query, \&trade_parse ], trade_cancel => [ \&trade_cancel, undef ], recover_request => [ \&recover_request, \&recover_parse], check => [ undef, \&check_parse], info => [ undef, \&info_parse], ); $tmp{check_multi}=$tmp{check}; return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:frnic="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('frnic'))); } sub build_domain { my ($domain)=@_; Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); return ['frnic:name',$domain]; } sub build_registrant { my ($rd)=@_; Net::DRI::Exception::usererr_invalid_parameters('AFNIC needs contacts for domain operations') unless Net::DRI::Util::has_contact($rd); my @t=$rd->{contact}->get('registrant'); Net::DRI::Exception::usererr_invalid_parameters('AFNIC needs one contact of type registrant') unless (@t==1 && Net::DRI::Util::isa_contact($t[0],'Net::DRI::Data::Contact::AFNIC')); $t[0]->validate_registrant(); Net::DRI::Exception::usererr_invalid_parameters('Registrant contact must have an id') unless length $t[0]->srid(); return ['frnic:registrant',$t[0]->srid()]; } sub build_cltrid { my ($mes)=@_; return (['frnic:clTRID',$mes->cltrid()]); } sub verify_contacts { my $rd=shift; Net::DRI::Exception::usererr_invalid_parameters('AFNIC needs contacts for domain operations') unless Net::DRI::Util::has_contact($rd); my @t=$rd->{contact}->get('admin'); Net::DRI::Exception::usererr_invalid_parameters('AFNIC needs one contact of type admin, and only one') unless (@t==1 && Net::DRI::Util::isa_contact($t[0],'Net::DRI::Data::Contact::AFNIC')); @t=grep { Net::DRI::Util::isa_contact($_,'Net::DRI::Data::Contact::AFNIC') } $rd->{contact}->get('tech'); Net::DRI::Exception::usererr_invalid_parameters('AFNIC needs one to three contacts of type tech') unless (@t >= 1 && @t <= 3); } sub build_contacts { my ($rd)=@_; my $cs=$rd->{contact}; my @n; push @n,['frnic:contact',{type => 'admin'},$cs->get('admin')->srid()]; ## only one admin allowed push @n,map { ['frnic:contact',{type => 'tech'},$_->srid()] } $cs->get('tech'); ## 1 to 3 allowed return @n; } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); ## We just make sure that we have all contact data verify_contacts($rd); build_registrant($rd); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); ## We just verify that if we do a redemption, we only use op=request, because RFC3915 allows also op=report my $rgp=$todo->set('rgp'); return unless (defined($rgp) && $rgp && (ref($rgp) eq 'HASH')); my $op=$rgp->{op} || ''; Net::DRI::Exception::usererr_invalid_parameters('RGP op can only be request for AFNIC') unless ($op eq 'request'); } sub transfer_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); verify_contacts($rd); my $eid=build_command_extension($mes,$epp,'frnic:ext'); $mes->command_extension($eid,['frnic:transfer',['frnic:domain',build_contacts($rd)]]); } sub parse_trade_recover { my ($po,$otype,$oaction,$oname,$rinfo,$s)=@_; my $mes=$po->message(); my $infdata=$mes->get_extension('frnic','ext'); return unless defined $infdata; my $ns=$mes->ns('frnic'); $infdata=Net::DRI::Util::xml_traverse($infdata,$ns,'resData',$s,'domain'); return unless defined $infdata; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{domain}->{$oname}->{action}=$oaction; $rinfo->{domain}->{$oname}->{exist}=1; } elsif ($name eq 'trStatus') { $rinfo->{domain}->{$oname}->{$name}=$c->textContent(); } elsif ($name=~m/^(reID|reHldID|acID|acHldID)$/) { $rinfo->{domain}->{$oname}->{$name}=$c->textContent(); } elsif ($name=~m/^(reDate|rhDate|ahDate)$/) { $rinfo->{domain}->{$oname}->{$name}=$po->parse_iso8601($c->textContent()); } } } sub trade_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'frnic:ext'); my @n=build_domain($domain); verify_contacts($rd); push @n,build_registrant($rd); push @n,build_contacts($rd); $mes->command_extension($eid,['frnic:command',['frnic:trade',{op=>'request'},['frnic:domain',@n]],build_cltrid($mes)]); } sub trade_query { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'frnic:ext'); my @n=build_domain($domain); $mes->command_extension($eid,['frnic:command',['frnic:trade',{op=>'query'},['frnic:domain',@n]],build_cltrid($mes)]); } sub trade_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'frnic:ext'); my @n=build_domain($domain); $mes->command_extension($eid,['frnic:command',['frnic:trade',{op=>'cancel'},['frnic:domain',@n]],build_cltrid($mes)]); } sub trade_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); parse_trade_recover($po,$otype,'trade',$oname,$rinfo,'trdData'); } sub recover_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'frnic:ext'); my @n=build_domain($domain); Net::DRI::Exception::usererr_invalid_parameters('authInfo is mandatory for a recover request') unless (Net::DRI::Util::has_auth($rd) && exists($rd->{auth}->{pw}) && $rd->{auth}->{pw}); push @n,['frnic:authInfo',['domain:pw',{'xmlns:domain'=>($mes->nsattrs('domain'))[0]},$rd->{auth}->{pw}]]; push @n,build_registrant($rd); push @n,build_contacts($rd); $mes->command_extension($eid,['frnic:command',['frnic:recover',{op=>'request'},['frnic:domain',@n]],build_cltrid($mes)]); } sub recover_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); parse_trade_recover($po,$otype,'recover',$oname,$rinfo,'recData'); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $chkdata=$mes->get_extension('frnic','ext'); return unless defined $chkdata; my $ns=$mes->ns('frnic'); $chkdata=Net::DRI::Util::xml_traverse($chkdata,$ns,'resData','chkData','domain'); return unless defined $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($ns,'cd')) { my (@r,@f,$domain); foreach my $el (Net::DRI::Util::xml_list_children($cd)) { my ($n,$c)=@$el; if ($n eq 'name') { $domain=lc($c->textContent()); $rinfo->{domain}->{$domain}->{action}='check'; $rinfo->{domain}->{$domain}->{reserved}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('reserved')); $rinfo->{domain}->{$domain}->{forbidden}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('forbidden')); } elsif ($n eq 'rsvReason') { push @r,$c->textContent(); } elsif ($n eq 'fbdReason') { push @f,$c->textContent(); } } ## There may be multiple of them ! $rinfo->{domain}->{$domain}->{reserved_reason}=join("\n",@r) if @r; $rinfo->{domain}->{$domain}->{forbidden_reason}=join("\n",@f) if @f; } } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('frnic','ext'); return unless defined $infdata; my $ns=$mes->ns('frnic'); $infdata=Net::DRI::Util::xml_traverse($infdata,$ns,'resData','infData','domain'); return unless defined $infdata; my $cs=$rinfo->{domain}->{$oname}->{status}; ## a Net::DRI::Protocol::EPP::Extensions::AFNIC::Status object foreach my $el ($infdata->getChildrenByTagNameNS($ns,'status')) { $cs->rem('ok'); $cs->add($el->getAttribute('s')); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AFNIC/Notifications.pm0000644000175000017500000001221511352534377024766 0ustar patrickpatrick## Domain Registry Interface, AFNIC EPP Notifications ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AFNIC::Notifications; use strict; use warnings; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Util; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AFNIC::Notifications - AFNIC (.FR/.RE) EPP Notifications for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( review_zonecheck => [ undef, \&parse_zonecheck ], review_identification => [ undef, \&parse_identification ], ); return { 'message' => \%tmp }; } #################################################################################################### sub parse_zonecheck { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); return unless $mes->node_msg(); ## this is the node in the EPP header ## For now there is no namespace #my $zc=$mes->node_msg()->getChildrenByTagNameNS($mes->ns('frnic'),'resZC'); my $zc=$mes->node_msg()->getChildrenByTagName('resZC'); return unless $zc->size(); $zc=$zc->shift(); return unless ($zc->getAttribute('type') eq 'plain-text'); ## we do not know what to do with other types $rinfo->{domain}->{$oname}->{review_zonecheck}=$zc->textContent(); ## a blob for now $rinfo->{domain}->{$oname}->{action}='review_zonecheck'; $rinfo->{domain}->{$oname}->{exist}=1; return; } sub parse_identification { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $idt=$mes->get_extension('frnic','ext'); return unless defined $idt; my $ns=$mes->ns('frnic'); $idt=Net::DRI::Util::xml_traverse($idt,$ns,'resData','idtData'); return unless defined $idt; my $c; if (defined($c=Net::DRI::Util::xml_traverse($idt,$ns,'contact'))) { my ($co,$oname,@reasons); foreach my $el (Net::DRI::Util::xml_list_children($c)) { my ($name,$node)=@$el; if ($name eq 'id') { $oname=$node->textContent(); $rinfo->{contact}->{$oname}->{action}='review_identification'; $rinfo->{contact}->{$oname}->{exist}=1; $co=$po->create_local_object('contact')->srid($oname); $rinfo->{contact}->{$oname}->{self}=$co; } elsif ($name eq 'identificationProcess') { $rinfo->{contact}->{$oname}->{process}=$node->getAttribute('s'); } elsif ($name eq 'legalEntityInfos') { foreach my $subel (Net::DRI::Util::xml_list_children($node)) { my ($subname,$subnode)=@$subel; if ($subname eq 'idStatus') { $co->id_status($subnode->textContent()); } elsif ($subname eq 'legalStatus') { $co->legal_form($subnode->getAttribute('s')); } elsif ($subname=~m/^(?:siren|VAT|trademark)$/) { $subname='legal_id' if $subname eq 'siren'; $subname=lc($subname); $co->$subname($subnode->textContent()); } } } elsif ($name eq 'idtReason') { push @{$rinfo->{contact}->{$oname}->{reasons}},$node->textContent(); } } return; } if (defined($c=Net::DRI::Util::xml_traverse($idt,$ns,'domain'))) { my $oname=lc(Net::DRI::Util::xml_child_content($c,$ns,'name')); $rinfo->{domain}->{$oname}->{action}='review_identification'; $rinfo->{domain}->{$oname}->{exist}=1; $rinfo->{domain}->{$oname}->{status}=$po->create_local_object('status')->add(Net::DRI::Protocol::EPP::Util::parse_status(Net::DRI::Util::xml_traverse($c,$ns,'status'))); $rinfo->{domain}->{$oname}->{contact}=$po->create_local_object('contactset')->set($po->create_local_object('contact')->srid(Net::DRI::Util::xml_child_content($c,$ns,'registrant')),'registrant'); return; } return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/HTTP.pm0000644000175000017500000000620111352534377022112 0ustar patrickpatrick## Domain Registry Interface, EPP over HTTP/HTTPS Connection handling ## ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::HTTP; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP::Connection/; use HTTP::Request (); use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::HTTP - EPP over HTTP/HTTPS connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub init { my ($class,$to)=@_; my $t=$to->transport_data(); foreach my $p (qw/client_login client_password remote_url/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p}); } } sub greeting { my ($class,$cm)=@_; return $class->keepalive($cm); ## will send an message, which is in fact a greeting ! } #################################################################################################### sub read_data { my ($class,$to,$res)=@_; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING',sprintf('Got unsuccessfull HTTP response: %d %s',$res->code(),$res->message()),'en')) unless $res->is_success(); return Net::DRI::Data::Raw->new_from_xmlstring($res->decoded_content()); } sub write_message { my ($class,$to,$msg)=@_; my $t=$to->transport_data(); my $req=HTTP::Request->new('POST',$t->{remote_url}); $req->header('Content-Type','text/xml'); $req->content(Net::DRI::Util::encode_utf8($msg)); ## Content-Length will be automatically computed during Transport by LWP::UserAgent return $req; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AT.pm0000644000175000017500000000425311352534377021644 0ustar patrickpatrick## Domain Registry Interface, NIC.AT EPP extensions ## Contributed by Michael Braunoeder from NIC.AT ## ## Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AT; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AT - .AT EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->capabilities('domain_update','status',undef); $self->capabilities('contact_update','status',undef); return; } sub default_extensions { return qw/AT::Domain AT::Contact AT::ATResult AT::Message/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PL.pm0000644000175000017500000000502211352534377021646 0ustar patrickpatrick## Domain Registry Interface, NASK (.PL) EPP extensions (draft-zygmuntowicz-epp-pltld-03) ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::PL; use strict; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::PL; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::PL - .PL EPP extensions (draft-zygmuntowicz-epp-pltld-03) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ pl_domain => ['http://www.dns.pl/NASK-EPP/extdom-1.0','extdom-1.0.xsd'], pl_contact => ['http://www.dns.pl/NASK-EPP/extcon-1.0','extcon-1.0.xsd'], # future => ['http://www.dns.pl/NASK-EPP/future-1.0','future-1.0.xsd'], ## TODO }); $self->capabilities('host_update','name',undef); ## No change of hostnames $self->factories('contact',sub { return Net::DRI::Data::Contact::PL->new(); }); return; } sub default_extensions { return qw/PL::Domain PL::Contact PL::Message/; } ## TODO: PL::Future #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CAT/0002755000175000017500000000000011352534417021402 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CAT/Contact.pm0000644000175000017500000000772611352534377023352 0ustar patrickpatrick## Domain Registry Interface, .CAT Contact EPP extension commands ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CAT::Contact; use strict; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CAT::Contact - .CAT EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ undef, \&info_parse ], ); return { 'contact' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:cx="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('puntcat_contact'))); } sub add_puntcat_extension { my ($contact)=@_; ## Everything is optional my @n; push @n,['cx:language',$contact->lang()] if $contact->lang(); push @n,['cx:maintainer',$contact->maintainer()] if $contact->maintainer(); push @n,['cx:sponsorEmail',$contact->email_sponsor()] if $contact->email_sponsor(); return @n; } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); my @n=add_puntcat_extension($contact); return unless @n; my $eid=build_command_extension($mes,$epp,'cx:create'); $mes->command_extension($eid,\@n); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $newc=$todo->set('info'); return unless $newc; ## if there already verified in Core my @n=add_puntcat_extension($newc); return unless @n; my $eid=build_command_extension($mes,$epp,'cx:update'); $mes->command_extension($eid,['cx:chg',@n]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('puntcat_contact','infData'); return unless $infdata; my $s=$rinfo->{contact}->{$oname}->{self}; my $el=$infdata->getChildrenByTagNameNS($mes->ns('puntcat_contact'),'language'); $s->lang($el->get_node(1)->getFirstChild()->getData()) if $el; $el=$infdata->getChildrenByTagNameNS($mes->ns('puntcat_contact'),'maintainer'); $s->maintainer($el->get_node(1)->getFirstChild()->getData()) if $el; $el=$infdata->getChildrenByTagNameNS($mes->ns('puntcat_contact'),'sponsorEmail'); $s->email_sponsor($el->get_node(1)->getFirstChild()->getData()) if $el; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CAT/Domain.pm0000644000175000017500000002253511352534377023161 0ustar patrickpatrick## Domain Registry Interface, .CAT Domain EPP extension commands ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CAT::Domain; use strict; use Email::Valid; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CAT::Domain - .CAT EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ undef, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:dx="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('puntcat_domain'))); } sub add_name_variant { my ($d)=@_; my @n; foreach my $n ((ref($d) eq 'ARRAY')? @{$d} : ($d)) { Net::DRI::Exception::usererr_invalid_parameters($n.' in name_variant attribute must be an XML token between 1 & 255 chars in length') unless Net::DRI::Util::xml_is_token($n,1,255); push @n,['dx:nameVariant',$n]; } return @n; } sub add_lang { my ($d)=@_; Net::DRI::Exception::usererr_invalid_parameters('lang attribute must be an XML language') unless (($d eq '') || Net::DRI::Util::xml_is_language($d)); return ['dx:language',$d]; } sub add_maintainer { my ($d)=@_; Net::DRI::Exception::usererr_invalid_parameters('maintainer attribute must be an XML token not more than 128 chars long') unless Net::DRI::Util::xml_is_token($d,undef,128); return ['dx:maintainer',$d]; } sub add_intended_use { my ($d)=@_; Net::DRI::Exception::usererr_invalid_parameters('intended_use must be a string between 1 and 1000 chars long') unless (''.$d && (length($d) <= 1000)); return ['dx:intendedUse',$d]; } sub add_puntcat_extension { my ($rd)=@_; my @n; return @n unless (defined($rd) && (ref($rd) eq 'HASH') && keys(%$rd)); if (exists($rd->{name_variant}) && defined($rd->{name_variant})) { push @n,add_name_variant($rd->{name_variant}); } push @n,add_lang($rd->{lang}) if (exists($rd->{lang}) && defined($rd->{lang})); push @n,add_maintainer($rd->{maintainer}) if (exists($rd->{maintainer}) && defined($rd->{maintainer})); Net::DRI::Exception::usererr_insufficient_parameters('ens block is mandatory, since intendeduse are mandatory') unless (exists($rd->{ens}) && defined($rd->{ens}) && (ref(($rd->{ens})) eq 'HASH')); my %ens=%{$rd->{ens}}; my @ens; if (exists($ens{auth}) && defined($ens{auth})) { my %auth=(ref($ens{auth}) eq 'HASH')? (key => $ens{auth}->{key}, id => $ens{auth}->{id} ) : (id => $ens{auth}); Net::DRI::Exception::usererr_insufficient_parameters('in ens auth block, id is mandatory') unless (exists($auth{id}) && defined($auth{id})); Net::DRI::Exception::usererr_invalid_parameters('id in ens auth block must be XML token between 1 and 20 chars long') if !Net::DRI::Util::xml_is_token($auth{id},1,20); Net::DRI::Exception::usererr_invalid_parameters('key in ens auth block must be XML token between 1 and 20 chars long') if (exists($auth{key}) && !Net::DRI::Util::xml_is_token($auth{key},1,20)); push @ens,['dx:auth',\%auth]; } if (exists($ens{sponsor}) && defined($ens{sponsor})) { my @e; foreach my $e ((ref($ens{sponsor}) eq 'ARRAY')? @{$ens{sponsor}} : ($ens{sponsor})) { Net::DRI::Exception::usererr_invalid_parameters("sponsor value $e in ens block must be a valid email address") unless (defined($e) && Net::DRI::Util::xml_is_token($e,1,undef) && Email::Valid->rfc822($e)); push @e,['dx:sponsor',$e]; } Net::DRI::Exception::usererr_invalid_parameters('there must be either 1 or 3 sponsors') unless (@e==1 || @e==3); push @ens,['dx:sponsoring',@e]; } if (exists($ens{ref_url}) && defined($ens{ref_url})) { Net::DRI::Exception::usererr_invalid_parameters('ref_url in ens auth block must be XML token between 1 and 255 chars long') unless Net::DRI::Util::xml_is_token($ens{ref_url},1,255); push @ens,['dx:refURL',$ens{ref_url}]; } if (exists($ens{registration_type}) && defined($ens{registration_type})) { Net::DRI::Exception::usererr_invalid_parameters('registration_type in ens auth block must be XML token between 1 and 128 chars long') unless Net::DRI::Util::xml_is_token($ens{registration_type},1,128); push @ens,['dx:registrationType',$ens{registration_type}]; } Net::DRI::Exception::usererr_insufficient_parameters('intended_use in ens auth block is mandatory') unless (exists($ens{intended_use}) && defined($ens{intended_use})); push @ens,add_intended_use($ens{intended_use}); push @n,['dx:ens',@ens] if @ens; return @n; } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @n=add_puntcat_extension($rd); return unless @n; my $eid=build_command_extension($mes,$epp,'dx:create'); $mes->command_extension($eid,\@n); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my (@tmp,@n); if ($todo->types('name_variant')) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only name_variant add/del available for domain') if grep { ! /^(?:add|del)$/ } $todo->types('name_variant'); @tmp=add_name_variant($todo->add('name_variant')); push @n,['dx:add',@tmp] if @tmp; @tmp=add_name_variant($todo->del('name_variant')); push @n,['dx:rem',@tmp] if @tmp; } @tmp=(); if ($todo->types('lang')) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only lang set available for domain') if grep { $_ ne 'set' } $todo->types('lang'); push @tmp,add_lang($todo->set('lang')); } if ($todo->types('maintainer')) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only maintainer set available for domain') if grep { $_ ne 'set' } $todo->types('maintainer'); push @tmp,add_maintainer($todo->set('maintainer')); } if ($todo->types('intended_use')) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only intended_use set available for domain') if grep { $_ ne 'set' } $todo->types('intended_use'); push @tmp,add_intended_use($todo->set('intended_use')); } push @n,['dx:chg',@tmp] if @tmp; return unless @n; my $eid=build_command_extension($mes,$epp,'dx:update'); $mes->command_extension($eid,\@n); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('puntcat_domain','infData'); return unless $infdata; my $c=$infdata->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'nameVariant') { push @{$rinfo->{domain}->{$oname}->{name_variant}},$c->getFirstChild()->getData(); } elsif ($name eq 'language') { $rinfo->{domain}->{$oname}->{lang}=$c->getFirstChild()->getData(); } elsif ($name eq 'maintainer') { $rinfo->{domain}->{$oname}->{maintainer}=$c->getFirstChild()->getData(); } elsif ($name eq 'ens') { my %ens; my $cc=$c->getFirstChild(); while($cc) { next unless ($cc->nodeType() == 1); ## only for element nodes my $name2=$cc->localname() || $cc->nodeName(); next unless $name2; if ($name2 eq 'auth') { $ens{auth}={ id => $cc->getAttribute('id') }; } elsif ($name2 eq 'sponsoring') { $ens{sponsor}=[ map { $_->getFirstChild()->getData() } $cc->getChildrenByTagNameNS($mes->ns('puntcat_domain'),'sponsor') ]; } elsif ($name2 eq 'refURL') { $ens{ref_url}=$cc->getFirstChild()->getData(); } elsif ($name2 eq 'registrationType') { $ens{registration_type}=$cc->getFirstChild()->getData(); } elsif ($name2 eq 'intendedUse') { $ens{intended_use}=$cc->getFirstChild()->getData(); } } continue { $cc=$cc->getNextSibling(); } $rinfo->{domain}->{$oname}->{ens}=\%ens; } } continue { $c=$c->getNextSibling(); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CAT/DefensiveRegistration.pm0000644000175000017500000003271611352534377026257 0ustar patrickpatrick## Domain Registry Interface, .CAT Defensive Registration EPP extension commands ## ## Copyright (c) 2006-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CAT::DefensiveRegistration; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.10 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CAT::DefensiveRegistration - .CAT EPP Defensive Registration extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp1=( create => [ \&create ], check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], delete => [ \&delete ], update => [ \&update ], renew => [ \&renew ], ); $tmp1{check_multi}=$tmp1{check}; return { 'defreg' => \%tmp1 }; } sub ns { my $mes=shift; return wantarray()? @{$mes->ns()->{'puntcat_defreg'}} : $mes->ns('puntcat_defreg'); } sub build_command { my ($epp,$command,$id)=@_; my $mes=$epp->message(); my @id; foreach my $n ( grep { defined } (ref($id) eq 'ARRAY')? @$id : ($id)) { Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid defensive registration id '.$n) unless ($n && !ref($n) && Net::DRI::Util::xml_is_token($n,3,16)); push @id,$n; } Net::DRI::Exception->die(1,'protocol/EPP',2,'Defensive registration id needed') unless @id; my @ns=ns($mes); $mes->command([$command,'defreg:'.$command,sprintf('xmlns:defreg="%s" xsi:schemaLocation="%s %s"',$ns[0],$ns[0],$ns[1])]); return map { ['defreg:id',$_] } @id; } sub build_pattern { my ($d)=@_; Net::DRI::Exception::usererr_insufficient_parameters('pattern is mandatory') unless (defined($d) && $d); Net::DRI::Exception::usererr_invalid_parameters('pattern must be a XML token between 1 and 63 chars long') unless Net::DRI::Util::xml_is_token($d,1,63); return ['defreg:pattern',$d]; } sub build_contact { my ($d,$type)=@_; Net::DRI::Exception::usererr_insufficient_parameters($type.' contact is mandatory') unless (defined($d) && $d); $d=$d->srid() if Net::DRI::Util::isa_contact($d,'Net::DRI::Data::Contact::CAT'); Net::DRI::Exception->die(1,'protocol/EPP',10,"Invalid $type contact id: $d") unless Net::DRI::Util::xml_is_token($d,3,16); return ($type eq 'registrant')? ['defreg:registrant',$d] : ['defreg:contact',$d,{type => $type}]; } sub build_contact_noregistrant { my $cs=shift; my @d; foreach my $t (sort($cs->types())) { next if ($t eq 'registrant'); my @o=$cs->get($t); push @d,map { ['defreg:contact',$_->srid(),{'type'=>$t}] } @o; } return @d; } sub build_authinfo { my ($d)=@_; Net::DRI::Exception::usererr_insufficient_parameters('auth info is mandatory') unless (defined($d) && (ref($d) eq 'HASH') && exists($d->{pw}) && $d->{pw}); Net::DRI::Exception::usererr_invalid_parameters('auth pw must be a XML normalized string') unless Net::DRI::Util::xml_is_normalizedstring($d->{pw}); return ['defreg:authInfo',['defreg:pw',$d->{pw},exists($d->{roid})? { 'roid' => $d->{roid} } : undef]]; } sub build_maintainer { my ($d)=@_; Net::DRI::Exception::usererr_insufficient_parameters('maintainer is mandatory') unless (defined($d) && $d); Net::DRI::Exception::usererr_invalid_parameters('maintainer must be an XML token up to 128 chars long') unless Net::DRI::Util::xml_is_token($d,undef,128); return ['defreg:maintainer',$d]; } sub build_trademark { my ($d)=@_; Net::DRI::Exception::usererr_insufficient_parameters('trademark is mandatory') unless (defined($d) && (ref($d) eq 'HASH') && keys(%$d)); my %t=%$d; my @n; if (exists($t{name})) { Net::DRI::Exception::usererr_invalid_parameters('trademark name must be an XML token at least one char long') unless Net::DRI::Util::xml_is_token($t{name},1); push @n,['defreg:name',$t{name}]; } if (exists($t{issue_date})) { Net::DRI::Exception::usererr_invalid_parameters('trademark issueDate must be a valid DateTime object') unless Net::DRI::Util::check_isa($t{issue_date},'DateTime'); push @n,['defreg:issueDate',$t{issue_date}->strftime('%Y-%m-%d')]; } if (exists($t{country})) { Net::DRI::Exception::usererr_invalid_parameters('trademark country must be a valid country code') unless ($t{country} && exists($Net::DRI::Util::CCA2{uc($t{country})})); push @n,['defreg:country',$t{country}]; } if (exists($t{number})) { Net::DRI::Exception::usererr_invalid_parameters('trademark number must be an XML token at least one chat long') unless Net::DRI::Util::xml_is_token($t{number},1); push @n,['defreg:number',$t{number}]; } return ['defreg:trademark',@n]; } sub build_period { my $p=Net::DRI::Protocol::EPP::Util::build_period(shift); $p->[0]='defreg:period'; return $p; } #################################################################################################### ########### Query commands sub check { my $epp=shift; my @id=@_; my @d=build_command($epp,'check',\@id); $epp->message->command_body(\@d); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $ns=ns($mes); my $chkdata=$mes->get_response($ns,'chkData'); return unless defined $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($ns,'cd')) { my $id; foreach my $el (Net::DRI::Util::xml_list_children($cd)) { my ($n,$c)=@$el; if ($n eq 'id') { $id=$c->textContent(); $rinfo->{defreg}->{$id}->{action}='check'; $rinfo->{defreg}->{$id}->{exist}=1-Net::DRI::Util::xml_parse_boolean($c->getAttribute('avail')); } elsif ($n eq 'reason') { $rinfo->{defreg}->{$id}->{exist_reason}=$c->textContent(); } } } } sub info { my ($epp,$id,$rd)=@_; my @d=build_command($epp,'info',$id); push @d,build_authinfo($rd->{auth}) if Net::DRI::Util::has_auth($rd); $epp->message->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $ns=ns($mes); my $infdata=$mes->get_response($ns,'infData'); return unless defined $infdata; my (@s,%t); my $cs=$po->create_local_object('contactset'); foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'id') { $oname=$c->textContent(); $rinfo->{defreg}->{$oname}->{id}=$oname; } elsif ($name eq 'roid') { $rinfo->{defreg}->{$oname}->{roid}=$c->textContent(); } elsif ($name eq 'pattern') { $rinfo->{defreg}->{$oname}->{pattern}=$c->textContent(); } elsif ($name eq 'status') { push @s,Net::DRI::Protocol::EPP::Util::parse_status($c); } elsif ($name eq 'registrant') { $cs->set($po->create_local_object('contact')->srid($c->textContent()),'registrant'); } elsif ($name eq 'contact') { $cs->add($po->create_local_object('contact')->srid($c->textContent()),$c->getAttribute('type')); } elsif ($name=~m/^(clID|crID|upID)$/) { $rinfo->{defreg}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(crDate|upDate|exDate)$/) { $rinfo->{defreg}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } elsif ($name eq 'authInfo') { $rinfo->{defreg}->{$oname}->{auth}={ pw => Net::DRI::Util::xml_child_content($c,$ns,'pw') }; } elsif ($name eq 'maintainer') { $rinfo->{defreg}->{$oname}->{maintainer}=$c->textContent(); } elsif ($name eq 'trademark') { foreach my $sel (Net::DRI::Util::xml_list_children($c)) { my ($name2,$cc)=@$sel; if ($name2 eq 'name') { $t{name}=$cc->textContent(); } elsif ($name2 eq 'issueDate') { $t{issue_date}=$po->parse_iso8601($cc->textContent()); } elsif ($name2 eq 'country') { $t{country}=$cc->textContent(); } elsif ($name2 eq 'number') { $t{number}=$cc->textContent(); } } } } $rinfo->{defreg}->{$oname}->{action}='info'; $rinfo->{defreg}->{$oname}->{exist}=1; $rinfo->{defreg}->{$oname}->{contact}=$cs; $rinfo->{defreg}->{$oname}->{status}=$po->create_local_object('status')->add(@s); $rinfo->{defreg}->{$oname}->{trademark}=\%t; } #################################################################################################### ############ Transform commands sub create { my ($epp,$id,$ri)=@_; my @d=build_command($epp,'create',$id); Net::DRI::Exception::usererr_invalid_parameters('A ref hash with all info must be provided alongside the id') unless (defined($ri) && (ref($ri) eq 'HASH') && keys(%$ri)); ## Period, OPTIONAL if (exists($ri->{duration})) { my $period=$ri->{duration}; Net::DRI::Util::check_isa($period,'DateTime::Duration'); push @d,build_period($period); } Net::DRI::Exception::usererr_invalid_parameters('pattern must be an XML token between 1 and 63 chars long') unless (exists($ri->{pattern}) && $ri->{pattern} && Net::DRI::Util::xml_is_token($ri->{pattern},1,63)); push @d,['defreg:pattern',$ri->{pattern}]; Net::DRI::Exception::usererr_invalid_parameters('a valid contactset object must be given in contact attribute') unless Net::DRI::Util::has_contact($ri); my $cs=$ri->{contact}; push @d,build_contact($cs->get('registrant'),'registrant'); push @d,build_contact($cs->get('billing'),'billing'); push @d,build_contact($cs->get('admin'),'admin'); push @d,build_authinfo($ri->{auth}); push @d,build_maintainer($ri->{maintainer}) if (exists($ri->{maintainer})); ## optional my $tmp=build_trademark($ri->{trademark}); Net::DRI::Exception::usererr_insufficient_parameters('trademark must be a ref hash with 4 keys: name, issue_date, country, number') unless (@$tmp==5); push @d,$tmp; $epp->message->command_body(\@d); } sub delete { my ($epp,$id)=@_; my @d=build_command($epp,'delete',$id); $epp->message->command_body(\@d); } sub renew { my ($epp,$id,$rd)=@_; my $period=(defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{duration}))? $rd->{duration} : undef; my $curexp=(defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{current_expiration}))? $rd->{current_expiration} : undef; Net::DRI::Exception::usererr_insufficient_parameters('current expiration year') unless defined($curexp); $curexp=$curexp->set_time_zone('UTC')->strftime('%Y-%m-%d') if (ref($curexp) && UNIVERSAL::isa($curexp,'DateTime')); Net::DRI::Exception::usererr_invalid_parameters('current expiration year must be YYYY-MM-DD') unless $curexp=~m/^\d{4}-\d{2}-\d{2}$/; my @d=build_command($epp,'renew',$id); push @d,['defreg:curExpDate',$curexp]; if (defined($period)) { Net::DRI::Util::check_isa($period,'DateTime::Duration'); push @d,build_period($period); } $epp->message->command_body(\@d); } sub update { my ($epp,$id,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:add|del)$/ } $todo->types('status')) || (grep { ! /^(?:add|del)$/ } $todo->types('contact')) || (grep { ! /^set$/ } $todo->types('registrant')) || (grep { ! /^set$/ } $todo->types('auth')) || (grep { ! /^set$/ } $todo->types('maintainer')) || (grep { ! /^set$/ } $todo->types('trademark')) ) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only status/contact add/del or registrant/authinfo/maintainer/trademark set available for defreg'); } my @d=build_command($epp,'update',$id); my $sadd=$todo->add('status'); my $sdel=$todo->del('status'); my $cadd=$todo->add('contact'); my $cdel=$todo->del('contact'); my (@add,@del); push @add,build_contact_noregistrant($cadd) if $cadd; push @add,$sadd->build_xml('defreg:status') if $sadd; push @del,build_contact_noregistrant($cdel) if $cdel; push @del,$sdel->build_xml('defreg:status') if $sdel; push @d,['defreg:add',@add] if @add; push @d,['defreg:rem',@del] if @del; my (@chg,$chg); $chg=$todo->set('registrant'); push @chg,['defreg:registrant',$chg->srid()] if Net::DRI::Util::isa_contact($chg,'Net::DRI::Data::Contact::CAT'); $chg=$todo->set('auth'); push @chg,build_authinfo($chg) if ($chg && ref($chg)); $chg=$todo->set('maintainer'); push @chg,build_maintainer($chg) if $chg; $chg=$todo->set('trademark'); push @chg,build_trademark($chg) if ($chg && ref($chg)); push @d,['defreg:chg',@chg] if @chg; $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NSgroup.pm0000644000175000017500000001415211352534377022734 0ustar patrickpatrick## Domain Registry Interface, EPP NSgroup extension commands ## (based on .BE Registration_guidelines_v4_7_1) ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NSgroup; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NSgroup - EPP NSgroup extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp1=( create => [ \&create ], check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], delete => [ \&delete ], update => [ \&update ], ); $tmp1{check_multi}=$tmp1{check}; return { 'nsgroup' => \%tmp1 }; } sub capabilities_add { return ('nsgroup_update','ns',['set']); } sub ns { my ($mes)=@_; my $ns=$mes->ns('nsgroup'); return defined($ns)? $ns : 'http://www.dns.be/xml/epp/nsgroup-1.0'; } sub build_command { my ($epp,$msg,$command,$hosts)=@_; my @gn; foreach my $h ( grep { defined } (ref $hosts eq 'ARRAY')? @$hosts : ($hosts)) { my $gn=Net::DRI::Util::isa_nsgroup($h)? $h->name() : $h; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid NSgroup name: '.$gn) unless (defined $gn && $gn && ! ref $gn && Net::DRI::Util::xml_is_normalizedstring($gn,1,100)); push @gn,$gn; } Net::DRI::Exception->die(1,'protocol/EPP',2,'NSgroup name needed') unless @gn; my @ns=$msg->nsattrs('nsgroup'); @ns=qw(http://www.dns.be/xml/epp/nsgroup-1.0 http://www.dns.be/xml/epp/nsgroup-1.0 nsgroup-1.0.xsd) unless @ns; $msg->command([$command,'nsgroup:'.$command,sprintf('xmlns:nsgroup="%s" xsi:schemaLocation="%s %s"',@ns)]); return map { ['nsgroup:name',$_] } @gn; } sub add_nsname { my ($ns)=@_; return () unless (defined($ns)); my @a; if (! ref($ns)) { @a=($ns); } elsif (ref($ns) eq 'ARRAY') { @a=@$ns; } elsif (Net::DRI::Util::isa_nsgroup($ns)) { @a=$ns->get_names(); } foreach my $n (@a) { next if Net::DRI::Util::is_hostname($n); Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid host name: '.$n); } return map { ['nsgroup:ns',$_] } @a; } #################################################################################################### ########### Query commands sub check { my $epp=shift; my @hosts=@_; my $mes=$epp->message(); my @d=build_command($epp,$mes,'check',\@hosts); $mes->command_body(\@d); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $ns=ns($mes); my $chkdata=$mes->get_response($ns,'chkData'); return unless defined $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($ns,'cd')) { my $nsgroup; foreach my $el (Net::DRI::Util::xml_list_children($cd)) { my ($n,$c)=@$el; if ($n eq 'name') { $nsgroup=$c->textContent(); $rinfo->{nsgroup}->{$nsgroup}->{exist}=1-Net::DRI::Util::xml_parse_boolean($c->getAttribute('avail')); $rinfo->{nsgroup}->{$nsgroup}->{action}='check'; } } } } sub info { my ($epp,$hosts)=@_; my $mes=$epp->message(); my @d=build_command($epp,$mes,'info',$hosts); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response(ns($mes),'infData'); return unless defined $infdata; my $ns=$po->create_local_object('hosts'); foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=$c->textContent(); $ns->name($oname); $rinfo->{nsgroup}->{$oname}->{exist}=1; $rinfo->{nsgroup}->{$oname}->{action}='info'; } elsif ($name eq 'ns') { $ns->add($c->textContent()); } } $rinfo->{nsgroup}->{$oname}->{self}=$ns; } ############ Transform commands sub create { my ($epp,$hosts)=@_; my $mes=$epp->message(); my @d=build_command($epp,$mes,'create',$hosts); push @d,add_nsname($hosts); $mes->command_body(\@d); } sub delete { my ($epp,$hosts)=@_; my $mes=$epp->message(); my @d=build_command($epp,$mes,'delete',$hosts); $mes->command_body(\@d); } sub update { my ($epp,$hosts,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:ns)$/ } $todo->types()) || (grep { ! /^(?:set)$/ } $todo->types('ns') )) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only ns set available for nsgroup'); } my $ns=$todo->set('ns'); my @d=build_command($epp,$mes,'update',$hosts); push @d,add_nsname($ns); $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NO/0002755000175000017500000000000011352534417021307 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NO/Host.pm0000644000175000017500000001472211352534377022573 0ustar patrickpatrick## Domain Registry Interface, .NO Host extensions ## ## Copyright (c) 2008,2010 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NO::Host; use strict; use warnings; use Net::DRI::Util; our $VERSION = do { my @r = ( q$Revision: 1.3 $ =~ /\d+/gmx ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NO::Host - .NO Host Extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Trond Haugen, Einfo@norid.noE =head1 COPYRIGHT Copyright (c) 2008,2010 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ( $class, $version ) = @_; my %tmp = ( create => [ \&create, undef ], update => [ \&update, undef ], delete => [ \&facet, undef ], check => [ \&facet, undef ], info => [ \&info, \&parse_info ], ); return { 'host' => \%tmp }; } #################################################################################################### ##### # Facets # sub _build_facet_extension { my ( $mes, $epp, $tag ) = @_; return $mes->command_extension_register( $tag, sprintf( 'xmlns:no-ext-epp="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('no_epp') ) ); } ## # This facet method is generic and can be called from all object operations # sub build_facets { my ( $epp, $rd ) = @_; my @e; my $eid; my $mes = $epp->message(); if (exists($rd->{facets}) && defined($rd->{facets})) { $eid = _build_facet_extension( $mes, $epp, 'no-ext-epp:extended' ); foreach my $fkey (keys(%{$rd->{facets}})) { push @e, [ 'no-ext-epp:facet', { name => $fkey }, $rd->{facets}->{$fkey} ]; } } return $mes->command_extension( $eid, \@e ) if (@e); } sub facet { my ( $epp, $o, $rd ) = @_; return build_facets( $epp, $rd ); } sub parse_info { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $NS = $mes->ns('no_host'); my $condata = $mes->get_extension('no_host','infData'); return unless $condata; my @e = $condata->getElementsByTagNameNS( $NS, 'contact' ); return unless @e; # Contact is a single scalar my $t = $e[0]; if ( my $ct = $t->getFirstChild()->getData() ) { $rinfo->{host}->{$oname}->{contact} = $ct; } return; } sub build_command_extension { my ( $mes, $epp, $tag ) = @_; return $mes->command_extension_register( $tag, sprintf( 'xmlns:no-ext-host="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('no_host') ) ); } sub info { my ( $epp, $ho, $rd ) = @_; my $mes = $epp->message(); my $si; $si = $rd->{sponsoringclientid} if (exists($rd->{sponsoringclientid})); my $fs; $fs = $rd->{facets} if (exists($rd->{facets})); return unless ( $si || $fs ); my $r; if ($si) { my $eid = build_command_extension( $mes, $epp, 'no-ext-host:info' ); my @e; push @e, [ 'no-ext-host:sponsoringClientID', $si ]; $r = $mes->command_extension( $eid, \@e ); } if ($fs) { $r = facet( $epp, $ho, $rd ); } return $r; } sub create { my ( $epp, $ho, $rd ) = @_; my $mes = $epp->message(); return unless ((exists($rd->{contact}) && defined($rd->{contact})) || (exists($rd->{facets}) && defined($rd->{facets}))); my $r; if (exists($rd->{contact}) && defined($rd->{contact})) { my @e; my $eid = build_command_extension( $mes, $epp, 'no-ext-host:create' ); my $c = $rd->{contact}; my $srid; # $c may be a contact object or a direct scalar if ( Net::DRI::Util::has_contact( $rd ) ) { my @o = $c->get('contact'); $srid = $o[0]->srid() if (@o); } else { # Contact shall be a single scalar! $srid = $c; } push @e, [ 'no-ext-host:contact', $srid ]; $r = $mes->command_extension( $eid, \@e ); } # Add facet if any is set if (exists($rd->{facets}) && defined($rd->{facets})) { $r = facet( $epp, $ho, $rd ); } return $r; } sub update { my ( $epp, $ho, $todo ) = @_; my $mes = $epp->message(); my $ca = $todo->add('contact'); my $cd = $todo->del('contact'); my $fs = $todo->set('facets'); return unless ( $ca || $cd || $fs); # No updates asked my $r; if ( $ca || $cd ) { my $eid = build_command_extension( $mes, $epp, 'no-ext-host:update' ); my ( @n, @s ); if ( defined($ca) && $ca ) { push @s, [ 'no-ext-host:contact', $ca ]; push @n, [ 'no-ext-host:add', @s ] if ( @s > 0 ); } @s = undef; if ( defined($cd) && $cd ) { push @s, [ 'no-ext-host:contact', $cd ]; push @n, [ 'no-ext-host:rem', @s ] if ( @s > 0 ); } $r = $mes->command_extension( $eid, \@n ); } # Add facet if any is set if ($fs) { my $rd; $rd->{facets} = $fs; $r = facet( $epp, $ho, $rd ); } return $r; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NO/Contact.pm0000644000175000017500000003066311352534377023253 0ustar patrickpatrick## Domain Registry Interface, .NO Contact extensions ## ## Copyright (c) 2008,2010 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NO::Contact; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Util; use Net::DRI::Protocol::EPP::Extensions::NO::Host; our $VERSION = do { my @r = ( q$Revision: 1.3 $ =~ /\d+/gmx ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NO::Contact - .NO Contact Extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Trond Haugen, Einfo@norid.noE =head1 COPYRIGHT Copyright (c) 2008,2010 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ( $class, $version ) = @_; my %tmp = ( check => [ \&facet, undef ], info => [ \&facet, \&parse_info ], delete => [ \&facet, undef ], create => [ \&create, undef ], update => [ \&update, undef ], ); return { 'contact' => \%tmp }; } #################################################################################################### # parsing by XML::LibXML::Element methods sub parse_xdisclose { my $c = shift; my $flag = Net::DRI::Util::xml_parse_boolean( $c->getAttribute('flag') ); my %tmp; my $n = $c->getFirstChild(); while ($n) { next unless ( $n->nodeType() == 1 ); my $name = $n->localname() || $n->nodeName(); next unless $name; if ( $name =~ m/^(mobilePhone)$/mx ) { $tmp{$1} = $flag; } } continue { $n = $n->getNextSibling(); } return \%tmp; } sub parse_info { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $NS = $mes->ns('no_contact'); my $c = $rinfo->{contact}->{$oname}->{self}; # This method is called also on a message_retrieve, so make sure we have a contact info # before checking the email value. $c->email(undef) if ( $otype eq 'contact' && $oaction eq 'info' && $c->email() eq 'n/a' ); my $condata = $mes->get_extension('no_contact','infData'); return unless $condata; # type my $el = $condata->getElementsByTagNameNS( $NS, 'type' ) ; # XML::LibXML::NodeList back my $type = $el ? $el->get_node(1)->getFirstChild()->getData() : undef; $c->type($type) if ( defined($type) && $type ); $rinfo->{contact}->{$oname}->{type} = $c->type(); # identity, type and value my @e = $condata->getElementsByTagNameNS( $NS, 'identity' ); if ( @e && $e[0] ) { my $t = $e[0]; my $tv = $t->getAttribute('type'); $c->identity( { type => $tv, value => $t->getFirstChild()->getData() } ); $rinfo->{contact}->{$oname}->{identity} = $c->identity(); } # mobilePhone @e = $condata->getElementsByTagNameNS( $NS, 'mobilePhone' ); if ( @e && $e[0] ) { $c->mobilephone( Net::DRI::Protocol::EPP::Util::parse_tel( $e[0] ) ); $rinfo->{contact}->{$oname}->{identity} = $c->mobilephone(); } ############ my @ema; foreach my $el ( $condata->getElementsByTagNameNS( $NS, 'email' ) ) { my $c = $el->getFirstChild(); my $v; $v = $c->getData() if ($c); push @ema, $v if ($v); } if ( @ema > 0 ) { $c->xemail( \@ema ); $rinfo->{contact}->{$oname}->{xemail} = $c->xemail(); } # organization my @oa; foreach my $el ( $condata->getElementsByTagNameNS( $NS, 'organization' ) ) { my $c = $el->getFirstChild(); my $v; $v = $c->getData() if ($c); push @oa, $v if ($v); } if ( @oa > 0 ) { $c->organization( \@oa ); $rinfo->{contact}->{$oname}->{organization} = $c->organization(); } # roleContact my @rca; foreach my $el ( $condata->getElementsByTagNameNS( $NS, 'roleContact' ) ) { my $c = $el->getFirstChild(); my $v; $v = $c->getData() if ($c); push @rca, $v if ($v); } if ( @rca > 0 ) { $c->rolecontact( \@rca ); $rinfo->{contact}->{$oname}->{rolecontact} = $c->rolecontact(); } ######## # xtra, disclose flag for mobilephone @e = (); @e = $condata->getElementsByTagNameNS( $NS, 'disclose' ); if ( @e && $e[0] ) { my $t = $e[0]; $c->xdisclose( parse_xdisclose($t) ); $rinfo->{contact}->{$oname}->{xdisclose} = $c->xdisclose(); } return; } sub facet { my ( $epp, $o, $rd ) = @_; return Net::DRI::Protocol::EPP::Extensions::NO::Host::build_facets( $epp, $rd ); } sub build_command_extension { my ( $mes, $epp, $tag ) = @_; return $mes->command_extension_register( $tag, sprintf( 'xmlns:no-ext-contact="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('no_contact') ) ); } sub add_no_extensions { my ( $epp, $contact, $op ) = @_; my $mes = $epp->message(); my $ty = $contact->type(); my $id = $contact->identity(); my $mp = $contact->mobilephone(); my $org = $contact->organization(); my $rc = $contact->rolecontact(); my $aem = $contact->xemail(); my $xd = $contact->xdisclose(); my $fs = $contact->facets(); return unless ( defined($ty) || defined($id) || defined($mp) || defined($org) || defined($rc) || defined($aem) || defined($fs) ); my $eid = build_command_extension( $mes, $epp, 'no-ext-contact:' . $op ); my @e; push @e, [ 'no-ext-contact:type', $ty ] if ( defined($ty) && $ty ); # Add identity extension if present. if ( defined($id) && ($id) && ( ref($id) eq 'HASH' ) && exists( $id->{type} ) && exists( $id->{value} ) ) { push @e, [ 'no-ext-contact:identity', { type => $id->{type} }, $id->{value} ]; } #mobile is an e164 number push @e, Net::DRI::Protocol::EPP::Util::build_tel( 'no-ext-contact:mobilePhone', $mp ) if defined($mp); # email if ( defined($aem) && $aem ) { if (ref($aem) eq 'ARRAY' ) { foreach my $c (@$aem) { push @e, [ 'no-ext-contact:email', $c ]; } } else { # scalar push @e, [ 'no-ext-contact:email', $aem ]; } } #organization is a clID if ( defined($org) && $org ) { if ( ref($org) eq 'ARRAY' ) { foreach my $c (@$org) { push @e, [ 'no-ext-contact:organization', $c ]; } } else { # scalar push @e, [ 'no-ext-contact:organization', $org ]; } } #roleContact is a clID if ( defined($rc) && $rc ) { if ( ref($rc) eq 'ARRAY' ) { foreach my $c (@$rc) { push @e, [ 'no-ext-contact:roleContact', $c ]; } } else { # scalar push @e, [ 'no-ext-contact:roleContact', $rc ]; } } # xdisclose if ( defined ($xd) && $xd && (ref($xd) eq 'HASH') && exists( $xd->{mobilePhone} ) ) { my @d; my %v = map { $_ => 1 } values(%$xd); if (keys(%v) == 1) { ## 1 or 0 as values, not both at same time push @d, ['no-ext-contact:mobilePhone']; push @e, [ 'no-ext-contact:disclose', @d, { flag => ( keys(%v) )[0] } ]; } } my $r = $mes->command_extension( $eid, \@e ); # Add facet if any is set if ($fs) { my $rd; $rd->{facets} = $fs; $r = facet($epp, $contact, $rd); } return $r; } sub create { my ( $epp, $contact ) = @_; return add_no_extensions( $epp, $contact, 'create' ); } sub update { my ( $epp, $co, $todo ) = @_; my $mes = $epp->message(); my $r; my $mp = $todo->set('mobilephone'); my $id = $todo->set('identity'); my $xd = $todo->set('xdisclose'); my $fs = $todo->set('facets'); my $orgtoadd = $todo->add('organization'); my $orgtodel = $todo->del('organization'); my $rctoadd = $todo->add('rolecontact'); my $rctodel = $todo->del('rolecontact'); my $xetoadd = $todo->add('xemail'); my $xetodel = $todo->del('xemail'); return unless ( defined($mp) || $id || $orgtoadd || $orgtodel || $rctoadd || $rctodel || $xetoadd || $xetodel || $xd || $fs); if ( defined($mp) || $id || $orgtoadd || $orgtodel || $rctoadd || $rctodel || $xetoadd || $xetodel || $xd) { my $eid = build_command_extension( $mes, $epp, 'no-ext-contact:update' ); my ( @n, @s ); if ( defined($mp) ) { push @s, Net::DRI::Protocol::EPP::Util::build_tel( 'no-ext-contact:mobilePhone', $mp ); } if ( defined($id) && ( ref($id) eq 'HASH' ) && exists( $id->{type} ) && exists( $id->{value} ) ) { push @s, [ 'no-ext-contact:identity', { type => $id->{type} }, $id->{value} ]; } # xdisclose if ( ref($xd) && $xd ) { my @d; my %v = map { $_ => 1 } values(%$xd); push @d, ['no-ext-contact:mobilePhone'] if exists( $xd->{mobilePhone} ); push @s, [ 'no-ext-contact:disclose', @d, { flag => ( keys(%v) )[0] } ]; } push @n, [ 'no-ext-contact:chg', @s ] if ( @s > 0 ); @s = undef; if ( ( defined($orgtoadd) || defined($rctoadd) || defined($xetoadd) ) && ( $rctoadd || $orgtoadd || $xetoadd ) ) { push @s, map { [ 'no-ext-contact:email', $_ ] } ( ref($xetoadd) eq 'ARRAY' ) ? @$xetoadd : ($xetoadd) if ($xetoadd); push @s, map { [ 'no-ext-contact:organization', $_ ] } ( ref($orgtoadd) eq 'ARRAY' ) ? @$orgtoadd : ($orgtoadd) if ($orgtoadd); push @s, map { [ 'no-ext-contact:roleContact', $_ ] } ( ref($rctoadd) eq 'ARRAY' ) ? @$rctoadd : ($rctoadd) if ($rctoadd); push @n, [ 'no-ext-contact:add', @s ] if ( @s > 0 ); } @s = undef; if ( defined($orgtodel) || defined( $rctodel || defined($xetoadd) ) && ( $rctodel || $orgtodel || $xetodel ) ) { push @s, map { [ 'no-ext-contact:email', $_ ] } ( ref($xetodel) eq 'ARRAY' ) ? @$xetodel : ($xetodel) if ($xetodel); push @s, map { [ 'no-ext-contact:organization', $_ ] } ( ref($orgtodel) eq 'ARRAY' ) ? @$orgtodel : ($orgtodel) if ($orgtodel); push @s, map { [ 'no-ext-contact:roleContact', $_ ] } ( ref($rctodel) eq 'ARRAY' ) ? @$rctodel : ($rctodel) if ($rctodel); push @n, [ 'no-ext-contact:rem', @s ] if ( @s > 0 ); } $r = $mes->command_extension( $eid, \@n ); } if ($fs) { my $rd; $rd->{facets} = $fs; $r = facet($epp, $co, $rd); } return $r; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NO/Result.pm0000644000175000017500000001070611352534377023132 0ustar patrickpatrick## Domain Registry Interface, .NO Result extension ## ## Copyright (c) 2008 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NO::Result; use strict; our $VERSION = do { my @r = ( q$Revision: 1.3 $ =~ /\d+/gxm ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NO::Result - .NO Result Condition EPP Mapping for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Trond Haugen, Einfo@norid.noE =head1 COPYRIGHT Copyright (c) 2008 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen, Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ( $class, $version ) = @_; my %tmp = ( # hmmm, would like to parse our login response extensions as well, # but that doesn't work .. #login => [ undef, \&condition_parse ], check => [ undef, \&condition_parse ], info => [ undef, \&condition_parse ], create => [ undef, \&condition_parse ], delete => [ undef, \&condition_parse ], transfer_request => [ undef, \&condition_parse ], transfer_query => [ undef, \&condition_parse ], transfer_cancel => [ undef, \&condition_parse ], transfer_execute => [ undef, \&condition_parse ], update => [ undef, \&condition_parse ], renew => [ undef, \&condition_parse ], withdraw => [ undef, \&condition_parse ], nocommand => [ undef, \&condition_parse ], ); return { 'domain' => \%tmp, 'contact' => \%tmp, 'host' => \%tmp }; } sub condition_parse { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); my $condata = $mes->get_extension( 'no_result', 'conditions' ); return unless $condata; parse( $mes, $otype, $oname, $rinfo, $condata ); return 1; } sub parse { my ( $mes, $otype, $oname, $rinfo, $node ) = @_; my $NS = $mes->ns('no_result'); my @conditions; foreach my $el ( $node->getElementsByTagNameNS( $NS, 'condition' ) ) { my %con; my $c = $el->getFirstChild(); $con{code} = $el->getAttribute('code') if $el->getAttribute('code'); $con{severity} = $el->getAttribute('severity') if $el->getAttribute('severity'); while ($c) { my $name = $c->localname() || $c->nodeName(); next unless $name; if ( $name =~ m/^(msg|details)$/mx ) { $con{$1} = $c->getFirstChild()->getData(); } elsif ( $name =~ m/^attributes$/mx ) { foreach my $attr ( $c->getChildrenByTagNameNS( $NS, 'attr' ) ) { my $attrname = $attr->getAttribute('name'); $con{ "attr " . $attrname } = $attr->getFirstChild()->getData(); } } $c = $c->getNextSibling(); } push @conditions, \%con; } # Extension results can be returned in all 3 object types $rinfo->{$otype}->{$oname}->{conditions} = \@conditions; return; } ############################################################################## 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NO/Domain.pm0000644000175000017500000002272011352534377023062 0ustar patrickpatrick## Domain Registry Interface, .NO Domain extensions ## ## Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NO::Domain; use strict; use Net::DRI::DRD::NO; use Net::DRI::Protocol::EPP::Core::Domain; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Util; use Net::DRI::Protocol::EPP::Extensions::NO::Host; our $VERSION = do { my @r = ( q$Revision: 1.3 $ =~ /\d+/gmx ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NO::Domain - .NO EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Trond Haugen, Einfo@norid.noE =head1 COPYRIGHT Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ( $class, $version ) = @_; my %tmp = ( check => [ \&facet, undef ], info => [ \&facet, undef ], create => [ \&facet, undef ], transfer_cancel => [ \&facet, undef ], transfer_query => [ \&facet, undef ], renew => [ \&facet, undef ], update => [ \&update, undef ], delete => [ \&delete, undef ], transfer_request => [ \&transfer_request, undef ], transfer_execute => [ \&transfer_execute, \&Net::DRI::Protocol::EPP::Core::Domain::transfer_parse ], withdraw => [ \&withdraw, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ( $mes, $epp, $tag ) = @_; return $mes->command_extension_register( $tag, sprintf( 'xmlns:no-ext-domain="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('no_domain') ) ); } sub facet { my ( $epp, $o, $rd ) = @_; return Net::DRI::Protocol::EPP::Extensions::NO::Host::build_facets( $epp, $rd ); } sub update { my ( $epp, $domain, $todo ) = @_; my $fs = $todo->set('facets'); return unless ( defined($fs) && $fs); # No facets set my $rd; $rd->{facets} = $fs; return facet($epp, $domain, $rd); } sub delete { my ( $epp, $domain, $rd ) = @_; my $mes = $epp->message(); my $dfd = $rd->{deletefromdns}; my $dfr = $rd->{deletefromregistry}; my $fs = $rd->{facets}; return unless ( ( defined($dfd) || defined($dfr) || defined($fs) ) && ( $dfd || $dfr || $fs ) ); my $r; if ( $dfd || $dfr ) { my $eid = build_command_extension( $mes, $epp, 'no-ext-domain:delete' ); my @e; push @e, [ 'no-ext-domain:deleteFromDNS', $dfd ] if ( defined($dfd) && $dfd ); push @e, [ 'no-ext-domain:deleteFromRegistry', $dfr ] if ( defined($dfr) && $dfr ); $r = $mes->command_extension( $eid, \@e ) if (@e); } if ($fs) { $r = facet($epp, $domain, $rd); } return $r; } sub transfer_request { my ( $epp, $domain, $rd ) = @_; my $mes = $epp->message(); my $mp = $rd->{mobilephone}; my $em = $rd->{email}; my $fs = $rd->{facets}; return unless ( ( defined($mp) || defined($em) || defined($fs) ) && ( $mp || $em || $fs) ); my $r; if ($mp || $em) { my $eid = build_command_extension( $mes, $epp, 'no-ext-domain:transfer' ); my @d; push @d, Net::DRI::Protocol::EPP::Util::build_tel( 'no-ext-domain:mobilePhone', $mp ) if ( defined($mp) && $mp ); push @d, [ 'no-ext-domain:email', $em ] if ( defined($em) && $em ); my @e; push @e, [ 'no-ext-domain:notify', @d ]; $r = $mes->command_extension( $eid, \@e ); } if ($fs) { $r = facet($epp, $domain, $rd); } return $r; } sub withdraw { my ( $epp, $domain, $rd ) = @_; my $mes = $epp->message(); my $transaction; $transaction = $rd->{transactionname} if $rd->{transactionname}; my $fs = $rd->{facets}; return unless ( $transaction && $transaction eq 'withdraw'); Net::DRI::Exception::usererr_insufficient_parameters( 'Witdraw command requires a domain name') unless ( defined($domain) && $domain ); my $r; my (undef,$NS,$NSX)=$mes->nsattrs('no_domain'); my (undef,$ExtNS,$ExtNSX)=$mes->nsattrs('no_epp'); my $eid = $mes->command_extension_register( 'command', 'xmlns="' . $ExtNS . '" xsi:schemaLocation="' . $ExtNS . " $ExtNSX" . '"' ); my $cltrid=$mes->cltrid(); my %domns; $domns{'xmlns:domain'} = $NS; $domns{'xsi:schemaLocation'} = $NS . " $NSX"; $r=$mes->command_extension( $eid, [ [ 'withdraw', [ 'domain:withdraw', [ 'domain:name', $domain ], \%domns, \%domns ] ], [ 'clTRID', $cltrid ] ] ); if ( defined($fs) && $fs ) { $r = facet($epp, $domain, $rd); } return $r; } sub transfer_execute { my ( $epp, $domain, $rd ) = @_; my $mes = $epp->message(); my $transaction; $transaction = $rd->{transactionname} if $rd->{transactionname}; return unless ( $transaction && $transaction eq 'transfer_execute' ); my (undef,$NS,$NSX)=$mes->nsattrs('no_domain'); my (undef,$ExtNS,$ExtNSX)=$mes->nsattrs('no_epp'); my ( $auth, $du, $token, $fs ); $auth = $rd->{auth} if $rd->{auth}; $du = $rd->{duration} if $rd->{duration}; $token = $rd->{token} if $rd->{token}; $fs = $rd->{facets} if $rd->{facets}; # An execute must contain either an authInfo or a token, optionally also a duration Net::DRI::Exception::usererr_insufficient_parameters( 'transfer_execute requires either an authInfo or a token') unless ( defined($token) || defined($auth) && ( $token || $auth ) ); # Duration is optional my $dur; if ( defined($du) && $du && Net::DRI::Util::has_duration( $rd ) ) { Net::DRI::Util::check_isa( $du, 'DateTime::Duration' ); Net::DRI::Exception->die( 0, 'DRD::NO', 3, 'Invalid duration' ) if Net::DRI::DRD::NO->verify_duration_renew( $du, $domain ); $dur = Net::DRI::Protocol::EPP::Util::build_period($du); } my $eid = $mes->command_extension_register( 'command', 'xmlns="' . $ExtNS . '" xsi:schemaLocation="' . $ExtNS . " $ExtNSX" . '"' ); my $cltrid=$mes->cltrid(); my %domns; $domns{'xmlns:domain'} = 'urn:ietf:params:xml:ns:domain-1.0'; $domns{'xsi:schemaLocation'} = 'urn:ietf:params:xml:ns:domain-1.0 domain-1.0.xsd'; my %domns2; $domns2{'xmlns:no-ext-domain'} = $NS; $domns2{'xsi:schemaLocation'} = $NS . " $NSX"; my $r; if ( Net::DRI::Util::has_auth( $rd ) && ( ref( $rd->{auth} ) eq 'HASH' ) ) { $r=$mes->command_extension( $eid, [ [ 'transfer', { 'op' => 'execute' }, [ 'domain:transfer', \%domns, [ 'domain:name', $domain ], $dur, Net::DRI::Protocol::EPP::Util::domain_build_authinfo( $epp, $rd->{auth} ), ], ], [ 'clTRID', $cltrid ] ] ); } elsif ($token) { $r=$mes->command_extension( $eid, [ [ 'transfer', { 'op' => 'execute' }, [ 'domain:transfer', \%domns, [ 'domain:name', $domain ], $dur, ], ], [ 'extension', [ 'no-ext-domain:transfer', \%domns2, [ 'no-ext-domain:token', $token ] ] ], [ 'clTRID', $cltrid ] ] ); } if ( defined($fs) && $fs ) { $r = facet($epp, $domain, $rd); } return $r; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NO/Message.pm0000644000175000017500000002615311352534377023243 0ustar patrickpatrick## Domain Registry Interface, .NO message extensions ## ## Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NO::Message; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Core::Domain; use Net::DRI::Protocol::EPP::Extensions::NO::Contact; use Net::DRI::Protocol::EPP::Extensions::NO::Host; use Net::DRI::Protocol::EPP::Extensions::NO::Result; use Net::DRI::Protocol::EPP::Util; use DateTime::Format::ISO8601; our $VERSION = do { my @r = ( q$Revision: 1.5 $ =~ /\d+/gmx ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NO::Message - .NO Mesage Extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Trond Haugen, Einfo@norid.noE =head1 COPYRIGHT Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ################################################################################################ sub register_commands { my ( $class, $version ) = @_; my %tmp = ( noretrieve => [ \&pollreq, \&parse_poll ], nodelete => [ \&pollack, \&Net::DRI::Protocol::EPP::Extensions::NO::Result::condition_parse ], ); return { 'message' => \%tmp }; } sub facet { my ( $epp, $rd ) = @_; return Net::DRI::Protocol::EPP::Extensions::NO::Host::build_facets( $epp, $rd ); } sub pollack { my ( $epp, $msgid, $rd ) = @_; my $mes = $epp->message(); my $r = ( $mes->command( [ [ 'poll', { op => 'ack', msgID => $msgid } ] ] ) ); if (defined($rd->{facets}) && $rd->{facets}) { $r = facet( $epp, $rd ); } return $r; } sub pollreq { my ( $epp, $rd ) = @_; my $mes = $epp->message(); my $r = ( $mes->command( [ [ 'poll', { op => 'req' } ] ] ) ); if (defined($rd->{facets}) && $rd->{facets}) { $r = facet( $epp, $rd ); } return $r; } sub parse_resp_result { my ($node, $NS, $rinfo, $msgid)=@_; push @{$rinfo->{message}->{$msgid}->{results}},Net::DRI::Protocol::EPP::Util::parse_result($node,$NS,'no'); return; } sub transfer_resp_parse { my ($trndata, $oname, $rinfo, $msgid)=@_; return unless $trndata; my $pd=DateTime::Format::ISO8601->new(); my $c=$trndata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'name') { $oname=lc($c->getFirstChild()->getData()); $rinfo->{message}->{$msgid}->{domain}->{$oname}->{action}='transfer'; $rinfo->{message}->{$msgid}->{domain}->{$oname}->{exist}=1; } elsif ($name=~m/^(trStatus|reID|acID)$/mx) { $rinfo->{message}->{$msgid}->{domain}->{$oname}->{$1}=$c->getFirstChild()->getData() if ($c->getFirstChild()); } elsif ($name=~m/^(reDate|acDate|exDate)$/mx) { $rinfo->{message}->{$msgid}->{domain}->{$oname}->{$1}=$pd->parse_datetime($c->getFirstChild()->getData()); } } continue { $c=$c->getNextSibling(); } return; } sub contact_resp_parse { my ($credata, $oname, $rinfo, $msgid)=@_; return unless $credata; my $c=$credata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); if ($name eq 'id') { my $new=$c->getFirstChild()->getData(); $rinfo->{message}->{$msgid}->{contact}->{$oname}->{id}=$new if (defined($oname) && ($oname ne $new)); ## registry may give another id than the one we requested or not take ours into account at all ! $oname=$new; $rinfo->{message}->{$msgid}->{contact}->{$oname}->{id}=$oname; $rinfo->{message}->{$msgid}->{contact}->{$oname}->{action}='create'; $rinfo->{message}->{$msgid}->{contact}->{$oname}->{exist}=1; } elsif ($name=~m/^(crDate)$/) { $rinfo->{message}->{$msgid}->{contact}->{$oname}->{$1}=DateTime::Format::ISO8601->new()->parse_datetime($c->getFirstChild()->getData()); } } continue { $c=$c->getNextSibling(); } } ## We take into account all parse functions, to be able to parse any result sub parse_poll { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); my $eppNS = $mes->ns('_main'); # both message and results are defined by the same no-ext-result schema my $NS = $mes->ns('no_result'); return unless $mes->is_success(); return if ( $mes->result_code() == 1300 ); # no messages in queue my $msgid = $mes->msg_id(); $rinfo->{message}->{session}->{last_id} = $msgid; ## Parse any message my $mesdata = $mes->get_response('no_result','message'); $rinfo->{$otype}->{$oname}->{message} = $mesdata; return unless $mesdata; my ( $epp, $rep, $ext, $ctag, @conds, @tags ); my $command = $mesdata->getAttribute('type'); @tags = $mesdata->getElementsByTagNameNS( $NS, 'desc' ); # We supplement the standard top desc with our more detailed one if (@tags && $tags[0]->getFirstChild() && $tags[0]->getFirstChild()->getData()) { $rinfo->{message}->{$msgid}->{nocontent} = $tags[0]->getFirstChild()->getData(); } # # Now the data tag @tags = $mesdata->getElementsByTagNameNS( $NS, 'data' ); return unless @tags; my $data = $tags[0]; ## # Inside a data we can have variants, # a normal result block in the start, then an # which is a sequence, the other is a late response which will contain # a complete and ordinary EPP response, only delayed. # # Parse any ordinary result block(s) # foreach my $result ($data->getElementsByTagNameNS($eppNS,'result')) { parse_resp_result($result, $eppNS, $rinfo, $msgid); } ### # Parse entry # @tags = $data->getElementsByTagNameNS( $NS, 'entry' ); foreach my $entry (@tags) { next unless ( defined( $entry->getAttribute('name') ) ); if ( $entry->getAttribute('name') eq 'objecttype' ) { $rinfo->{message}->{$msgid}->{object_type} = $entry->getFirstChild()->getData(); } elsif ( $entry->getAttribute('name') eq 'command' ) { $rinfo->{message}->{$msgid}->{action} = $entry->getFirstChild()->getData(); } elsif ( $entry->getAttribute('name') eq 'objectname' ) { $rinfo->{message}->{$msgid}->{object_id} = $entry->getFirstChild()->getData(); } elsif ( $entry->getAttribute('name') =~ /^(domain|contact|host)$/mx ) { $rinfo->{message}->{$msgid}->{object_type} = $1; $rinfo->{message}->{$msgid}->{object_id} = $entry->getFirstChild()->getData(); } } $rinfo->{message}->{$msgid}->{action} ||= $command; ### # The various EPP late response messages can be encapsulated in the service message data. # There may in principle be any type of object response, so we try to parse all variants # We try to use our various parse methods, copy the data and copy the data from it # into our message structure. The delete the source data to hopefully not # contaminate anything. ## # inside a data and a late-responses, an inner TRID pair should exist. # No more than one inner TRID pair is expected and handled # In case more exist, the first one is used. # Find the values and stash them in an $rinfo->{message}->{$msgid}->{trid} hash if (my $trid=(($data->getElementsByTagNameNS($eppNS,'trID'))[0])) { my $tmp=Net::DRI::Util::xml_child_content($trid,$eppNS,'clTRID'); $rinfo->{message}->{$msgid}->{trid}->{cltrid} = $tmp if defined($tmp); $tmp = Net::DRI::Util::xml_child_content($trid,$eppNS,'svTRID'); $rinfo->{message}->{$msgid}->{trid}->{svtrid} = $tmp if defined($tmp); } # Parse any domain command late response data if (my $infdata=$mes->get_response('domain','infData')) { Net::DRI::Protocol::EPP::Core::Domain::info_parse($po,'domain','info',$oname,$rinfo); if (defined($rinfo->{domain}) && $rinfo->{domain}) { $rinfo->{message}->{$msgid}->{domain} = $rinfo->{domain}; delete($rinfo->{domain}); } } # Parse any domain transfer late response data if (my $trndata = (($data->getElementsByTagNameNS($mes->ns('domain'), 'trnData'))[0])) { transfer_resp_parse($trndata, $oname, $rinfo, $msgid); } # Parse any any contact create late response data if (my $credata = (($data->getElementsByTagNameNS($mes->ns('contact'), 'creData'))[0])) { contact_resp_parse($credata, $oname, $rinfo, $msgid); } # Parse any any contact info late response data if (my $condata = $mes->get_extension('no_contact','infData')) { Net::DRI::Protocol::EPP::Extensions::NO::Contact::parse_info($po,'contact', 'info',$oname,$rinfo); if (defined($rinfo->{contact}) && $rinfo->{contact}) { $rinfo->{message}->{$msgid}->{contact} = $rinfo->{contact}; delete ($rinfo->{contact}); } } # Parse any any host info late response data if (my $condata = $mes->get_extension('no_host','infData')) { Net::DRI::Protocol::EPP::Extensions::NO::Host::parse_info($po,'host','info',$oname,$rinfo); if (defined($rinfo->{host}) && $rinfo->{host}) { $rinfo->{message}->{$msgid}->{host} = $rinfo->{host}; delete($rinfo->{host}); } } # Parse any result extension conditions my $innerepp=$data->getElementsByTagNameNS($eppNS,'epp')->shift(); my $condata; if (defined($innerepp) && ($condata = $innerepp->getElementsByTagNameNS($NS,'conditions'))) { Net::DRI::Protocol::EPP::Extensions::NO::Result::parse($mes,$otype,$oname,$rinfo,$condata->shift()); if ((defined($rinfo->{$otype}->{$oname}->{conditions})) && $rinfo->{$otype}->{$oname}->{conditions}) { $rinfo->{message}->{$msgid}->{conditions} = $rinfo->{$otype}->{$oname}->{conditions}; #delete ($rinfo->{$otype}->{$oname}->{conditions}); } } return 1; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CentralNic/0002755000175000017500000000000011352534417023015 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CentralNic/WebForwarding.pm0000644000175000017500000000653711352534377026131 0ustar patrickpatrick## Domain Registry Interface, CentralNic Web Forwarding EPP extension ## (http://labs.centralnic.com/epp/ext/wf.php) ## ## Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CentralNic::WebForwarding; use strict; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CentralNic::WebForwarding - EPP WebForwarding CentralNic extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create ], update => [ \&update ], info => [ undef, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('wf','infData'); return unless $infdata; my @c=$infdata->getChildrenByTagNameNS($mes->ns('wf'),'url'); return unless @c; $rinfo->{domain}->{$oname}->{web_forwarding}=$c[0]->getFirstChild()->getData(); } ############ Transform commands sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless (exists($rd->{web_forwarding}) && defined($rd->{web_forwarding})); my $eid=$mes->command_extension_register('wf:create',sprintf('xmlns:wf="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('wf'))); my @n=(['wf:url',$rd->{web_forwarding}]); $mes->command_extension($eid,\@n); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $toset=$todo->set('web_forwarding'); return unless defined($toset); my $eid=$mes->command_extension_register('wf:update',sprintf('xmlns:wf="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('wf'))); my @n=(['wf:url',$toset]); $mes->command_extension($eid,\@n); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CentralNic/Release.pm0000644000175000017500000000604711352534377024745 0ustar patrickpatrick## Domain Registry Interface, CentralNic Release EPP extension ## (http://labs.centralnic.com/epp/ext/release.php) ## ## Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CentralNic::Release; use strict; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Core::Domain; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CentralNic::Release - EPP Release CentralNic extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( release => [ \&release, \&release_parse ]); return { 'domain' => \%tmp }; } #################################################################################################### sub release { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); Net::DRI::Exception::usererr_invalid_parameters('release operation needs a clID') unless (defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{clID}) && defined($rd->{clID}) && $rd->{clID}); $mes->command([['transfer',{'op'=>'release'}],'domain:transfer',sprintf('xmlns:domain="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('domain'))]); my @d=(['domain:name',$domain],['domain:clID',$rd->{clID}]); $mes->command_body(\@d); } sub release_parse { return Net::DRI::Protocol::EPP::Core::Domain::transfer_parse(@_); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CentralNic/TTL.pm0000644000175000017500000000713411352534377024026 0ustar patrickpatrick## Domain Registry Interface, CentralNic DNS TTL EPP extension ## (http://labs.centralnic.com/epp/ext/ttl.php) ## ## Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CentralNic::TTL; use strict; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CentralNic::TTL - EPP DNS TTL CentralNic extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create ], update => [ \&update ], info => [ undef, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('ttl','infData'); return unless $infdata; my @secs=$infdata->getChildrenByTagNameNS($mes->ns('ttl'),'secs'); return unless @secs; $rinfo->{domain}->{$oname}->{ttl}=DateTime::Duration->new(seconds => $secs[0]->getFirstChild()->getData()); } ############ Transform commands sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless (exists($rd->{ttl}) && ((ref($rd->{ttl}) && UNIVERSAL::isa($rd->{ttl},'DateTime::Duration')) || $rd->{ttl}=~m/^\d+$/)); my $eid=$mes->command_extension_register('ttl:create',sprintf('xmlns:ttl="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('ttl'))); my @n=(['ttl:secs',ref($rd->{ttl})? $rd->{ttl}->in_units('seconds') : $rd->{ttl}]); $mes->command_extension($eid,\@n); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $toset=$todo->set('ttl'); return unless (defined($toset) && ((ref($toset) && UNIVERSAL::isa($toset,'DateTime::Duration')) || $toset=~m/^\d+$/)); my $eid=$mes->command_extension_register('ttl:update',sprintf('xmlns:ttl="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('ttl'))); my @n=(['ttl:secs',ref($toset)? $toset->in_units('seconds') : $toset]); $mes->command_extension($eid,\@n); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CIRA/0002755000175000017500000000000011352534417021511 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CIRA/Agreement.pm0000644000175000017500000000564411352534377023772 0ustar patrickpatrick## Domain Registry Interface, CIRA EPP Agreement commands ## ## Copyright (c) 2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CIRA::Agreement; use strict; use warnings; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'agreement' => { get => [ \&get, \&get_parse ] } }; } sub get { my ($epp,$language)=@_; my $mes=$epp->message(); my $eid=$mes->command_extension_register('cira:ciraInfo',sprintf('xmlns:cira="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('cira'))); $mes->command_extension($eid,[['cira:action','get CIRA latest agreement'],['cira:language',defined $language ? $language : 'en']]); return; } sub get_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('cira','ciraInfo'); return unless defined $infdata; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'language') { $rinfo->{agreement}->{cira}->{lang}=$c->textContent(); } elsif ($name eq 'ciraAgreementVersion') { $rinfo->{agreement}->{cira}->{version}=$c->textContent(); } elsif ($name eq 'ciraAgreement') { $rinfo->{agreement}->{cira}->{content}=$c->textContent(); } } } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CIRA::Agreement - CIRA EPP Agreement commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CIRA/Contact.pm0000644000175000017500000001165311352534377023453 0ustar patrickpatrick## Domain Registry Interface, CIRA EPP Contact commands ## ## Copyright (c) 2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CIRA::Contact; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], create => [ \&create, undef ], update => [ \&update ], ); return { 'contact' => \%tmp }; } sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:cira="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('cira'))); } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('cira','ciraInfo'); return unless defined $infdata; my %a; my $contact=$rinfo->{contact}->{$oname}->{self}; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'language') { $contact->lang($c->textContent()); } elsif ($name eq 'cprCategory') { $contact->legal_form($c->textContent()); } elsif ($name eq 'individual') { $contact->is_individual($c->textContent() eq 'Y' ? 1 : 0); } elsif ($name eq 'ciraAgreementVersion') { $a{version}=$c->textContent(); $a{signed}=1; } elsif ($name eq 'agreementTimestamp') { $a{timestamp}=$po->parse_iso8601($c->textContent()); $a{signed}=1; } elsif ($name eq 'originatingIpAddress') { $contact->ip_address($c->textContent()); } elsif ($name eq 'whoisDisplaySetting') { $contact->whois_display($c->textContent()); } } $contact->agreement(\%a) if keys %a; } #################################################################################################### ########### Transform commands sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); ## $contact->validate() has been called my @n; push @n,['cira:language',$contact->lang()]; push @n,['cira:originatingIpAddress',$contact->ip_address()] if defined $contact->ip_address(); push @n,['cira:cprCategory',$contact->legal_form()] if defined $contact->legal_form(); my $ra=$contact->agreement(); if (defined $ra) { push @n,['cira:ciraAgreementVersion',$ra->{version}]; push @n,['cira:agreementValue',$ra->{signed} ? 'Y' : 'N']; } push @n,['cira:createdByResellerId',$contact->reseller_id()] if defined $contact->reseller_id(); ## Whois privacy ? my $eid=build_command_extension($mes,$epp,'cira:ciraCreate'); $mes->command_extension($eid,[@n]); } sub update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); my $newc=$todo->set('info'); return unless defined $newc; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact '.$newc) unless Net::DRI::Util::isa_contact($newc,'Net::DRI::Data::Contact::CIRA'); $newc->validate(1); ## will trigger an Exception if needed my @n; push @n,['cira:cprCategory',$newc->legal_form()] if defined $newc->legal_form(); push @n,['cira:language',$newc->lang()] if defined $newc->lang(); return unless @n; my $eid=build_command_extension($mes,$epp,'cira:ciraUpdate'); $mes->command_extension($eid,['cira:ciraChg',@n]); } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CIRA::Contact - CIRA EPP Contact commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CIRA/Domain.pm0000644000175000017500000001322211352534377023261 0ustar patrickpatrick## Domain Registry Interface, CIRA EPP Domain extensions ## ## Copyright (c) 2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CIRA::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse], create => [ \&create, undef ], transfer_request => [ \&transfer_request, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:cira="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('cira'))); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('cira','ciraInfo'); return unless defined $infdata; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'domainStageOfLife') { $rinfo->{domain}->{$oname}->{stage_of_life}=$c->textContent(); } elsif ($name eq 'domainStageOfLifeEnd') { $rinfo->{domain}->{$oname}->{stage_of_life_end}=$po->parse_iso8601($c->textContent()); } } } sub create { my ($epp,$domain,$rd)=@_; Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory in .CA for domain_create') unless Net::DRI::Util::has_contact($rd); my $cs=$rd->{contact}; my @c=$cs->get('registrant'); Net::DRI::Exception::usererr_insufficient_parameters('one registrant is mandatory in .CA for domain_create') unless (@c==1 && Net::DRI::Util::isa_contact($c[0],'Net::DRI::Data::Contact::CIRA') && length $c[0]->srid() && $c[0]->validate(1)); @c=$cs->get('admin'); Net::DRI::Exception::usererr_insufficient_parameters('one admin contact is mandatory in .CA for domain_create') unless (@c==1 && Net::DRI::Util::isa_contact($c[0],'Net::DRI::Data::Contact::CIRA') && length $c[0]->srid() && $c[0]->validate(1)); @c=$cs->get('tech'); return unless @c; Net::DRI::Exception::usererr_insufficient_parameters('only up to 3 tech contacts are possible in .CA for domain_create') if (scalar(@c)!=scalar(grep { Net::DRI::Util::isa_contact($_,'Net::DRI::Data::Contact::CIRA') && length $_->srid() && $_->validate(1) } @c) || @c>3); } sub transfer_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless Net::DRI::Util::has_contact($rd); my @n; my $cs=$rd->{contact}; Net::DRI::Exception::usererr_insufficient_parameters('Both registrant and admin contacts are required for .CA domain name transfer if contacts are provided') unless ($cs->has_type('registrant') && $cs->has_type('admin')); my @c=$cs->get('registrant'); Net::DRI::Exception::usererr_insufficient_parameters('only one registrant is mandatory in .CA for domain_transfer_start if contacts are provided') unless (@c==1 && Net::DRI::Util::isa_contact($c[0],'Net::DRI::Data::Contact::CIRA') && length $c[0]->srid() && $c[0]->validate(1)); push @n,['cira:Registrant',$c[0]->srid()]; ## or ?? @c=$cs->get('admin'); Net::DRI::Exception::usererr_insufficient_parameters('only one admin contact is mandatory in .CA for domain_transfer_start if contacts are provided') unless (@c==1 && Net::DRI::Util::isa_contact($c[0],'Net::DRI::Data::Contact::CIRA') && length $c[0]->srid() && $c[0]->validate(1)); push @n,['cira:domainTransferAdmin',$c[0]->srid()]; ## or ?? @c=$cs->get('tech'); if (@c) { Net::DRI::Exception::usererr_insufficient_parameters('only up to 3 tech contacts are possible in .CA for domain_transfer_start') if (scalar(@c)!=scalar(grep { Net::DRI::Util::isa_contact($_,'Net::DRI::Data::Contact::CIRA') && length $_->srid() && $_->validate(1) } @c) || @c>3); push @n,map { ['cira:domainTransferTech',$_->srid()] } @c; ## or ?? } my $eid=build_command_extension($mes,$epp,'cira:ciraTransfer'); $mes->command_extension($eid,\@n); } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CIRA::Domain - CIRA (.CA) EPP Domain extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CIRA/Notifications.pm0000644000175000017500000000545711352534377024676 0ustar patrickpatrick## Domain Registry Interface, CIRA EPP Notifications ## ## Copyright (c) 2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CIRA::Notifications; use strict; use warnings; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; use Net::DRI::Exception; use Net::DRI::Util; #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( review_cira => [ undef, \&parse ], ); return { 'message' => \%tmp }; } #################################################################################################### sub parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $node=$mes->get_response('poll','extData'); return unless defined $node; my $id=$mes->msg_id(); $rinfo->{message}->{$id}->{action}='review_cira'; foreach my $el (Net::DRI::Util::xml_list_children($node)) { my ($name,$n)=@$el; unless ($name=~m/^(?:msgID|domainName|contactID|balance|deadline|hostName|ipAddress)$/o) { Net::DRI::Exception::err_assert('Unknown node name '.$name.' in .CA notification parsing, please report!'); } $rinfo->{message}->{$id}->{Net::DRI::Util::remcam($name)}=$n->textContent(); } return; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CIRA::Notifications - CIRA (.CA) EPP Notifications for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/US.pm0000644000175000017500000000400111352534377021656 0ustar patrickpatrick## Domain Registry Interface, .US EPP extensions (draft-liu-epp-usTLD-00) ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::US; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::US - .US EPP extensions (draft-liu-epp-usTLD-00) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; return; } sub default_extensions { return qw/US::Contact/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Nominet/0002755000175000017500000000000011352534417022404 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Host.pm0000644000175000017500000001227611352534377023672 0ustar patrickpatrick## Domain Registry Interface, .UK EPP Host commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Nominet::Host; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Nominet::Host - .UK EPP Host commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ \&info, \&info_parse ], update => [ \&update ], ); return { 'host' => \%tmp }; } sub build_command { my ($msg,$command,$hostname)=@_; my $roid=(Net::DRI::Util::isa_hosts($hostname))? $hostname->get_details(1)->[-1]->{roid} : $hostname; Net::DRI::Exception->die(1,'protocol/EPP',2,'Roid of NS object needed') unless (defined($roid) && $roid && !ref($roid)); Net::DRI::Exception->die(1,'protocol/EPP',2,'Invalid ROID: '.$roid) unless ($roid=~m/^NS\d+(?:-UK)?$/); $msg->command([$command,'ns:'.$command,sprintf('xmlns:ns="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('ns'))]); return (['ns:roid',$roid]); } #################################################################################################### ########### Query commands sub info { my ($epp,$ns)=@_; my $mes=$epp->message(); my @d=build_command($mes,'info',$ns); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('ns','infData'); return unless defined $infdata; parse_infdata($po,$mes,$infdata,$oname,$rinfo); } sub parse_infdata { my ($po,$mes,$infdata,$oname,$rinfo)=@_; my ($hostname,@ip4,@ip6); my %i; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'roid') { $oname=$c->textContent(); $i{action}='info'; $i{exist}=1; $i{roid}=$oname; } elsif ($name eq 'name') { $hostname=lc($c->textContent()); $i{name}=$hostname; } elsif ($name=~m/^(clID|crID|upID)$/) { $i{$1}=$c->textContent(); } elsif ($name=~m/^(crDate|upDate)$/) { $i{$1}=$po->parse_iso8601($c->textContent()); } elsif ($name eq 'addr') { my $ip=$c->textContent(); my $ipv=$c->getAttribute('ip'); push @ip4,$ip if ($ipv eq 'v4'); push @ip6,$ip if ($ipv eq 'v6'); } } while(my ($k,$v)=each(%i)) { $rinfo->{host}->{$hostname}->{$k}=$rinfo->{host}->{$oname}->{$k}=$v; } $rinfo->{host}->{$hostname}->{self}=$rinfo->{host}->{$oname}->{self}=$po->create_local_object('hosts',$hostname,\@ip4,\@ip6,1,{roid=>$oname}); return $rinfo->{host}->{$hostname}->{self}; } ############ Transform commands sub update { my ($epp,$ns,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:set)$/ } $todo->types('ip')) || (grep { ! /^(?:set)$/ } $todo->types('name')) ) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only IP/name set available for host'); } my $ipset=$todo->set('ip'); my $newname=$todo->set('name'); my @d=build_command($mes,'update',$ns); if (defined($newname) && $newname) { Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid host name: '.$newname) unless Net::DRI::Util::is_hostname($newname); push @d,['ns:name',$newname]; } if (defined($ipset) && $ipset) { Net::DRI::Exception::usererr_invalid_parameters($ipset.' must be a Net::DRI::Data::Hosts object') unless Net::DRI::Util::isa_hosts($ipset); my ($name,$r4,$r6)=$ipset->get_details(1); push @d,['ns:addr',{ip=>'v4'},$r4->[0]] if @$r4; ## it seems only one IP is allowed push @d,['ns:addr',{ip=>'v6'},$r6->[0]] if @$r6; ## ditto } $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Contact.pm0000644000175000017500000001373111352534377024345 0ustar patrickpatrick## Domain Registry Interface, .UK EPP Contact commands ## ## Copyright (c) 2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Nominet::Contact; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Nominet::Contact - .UK EPP Contact commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ \&info, \&info_parse ], update => [ \&update ], ); return { 'contact' => \%tmp }; } sub build_command { my ($msg,$command,$contact)=@_; Net::DRI::Exception->die(1,'protocol/EPP',2,'Contact id needed') unless (defined($contact)); my $id=Net::DRI::Util::isa_contact($contact,'Net::DRI::Data::Contact::Nominet')? $contact->roid() : $contact; Net::DRI::Exception->die(1,'protocol/EPP',2,'Contact id needed') unless (defined($id) && $id && !ref($id)); Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact id: '.$id) unless Net::DRI::Util::xml_is_token($id,3,16); ## inherited from Core EPP my $tcommand=(ref($command))? $command->[0] : $command; $msg->command([$command,'contact:'.$tcommand,sprintf('xmlns:contact="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('contact'))]); return (['contact:roid',$id]); } #################################################################################################### ########### Query commands sub info { my ($epp,$c)=@_; my $mes=$epp->message(); my @d=build_command($mes,'info',$c); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('contact','infData'); return unless defined $infdata; my $contact=$po->create_local_object('contact'); parse_infdata($po,$infdata,$contact,$oname,$rinfo); } sub parse_infdata { my ($po,$infdata,$contact,$oname,$rinfo)=@_; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'roid') { $oname=$c->textContent(); $contact->roid($oname); $rinfo->{contact}->{$oname}->{roid}=$contact->roid(); $rinfo->{contact}->{$oname}->{action}='info'; $rinfo->{contact}->{$oname}->{exist}=1; } elsif ($name eq 'name') { $contact->name($c->textContent()); } elsif ($name=~m/^(clID|crID|upID)$/) { $rinfo->{contact}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(crDate|upDate)$/) { $rinfo->{contact}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } elsif ($name eq 'email') { $contact->email($c->textContent()); } elsif ($name eq 'phone') ## diverving from EPP voice { $contact->voice(Net::DRI::Protocol::EPP::Util::parse_tel($c)); } elsif ($name eq 'fax') { $contact->fax(Net::DRI::Protocol::EPP::Util::parse_tel($c)); } elsif ($name eq 'mobile') { $contact->mobile(Net::DRI::Protocol::EPP::Util::parse_tel($c)); } } $rinfo->{contact}->{$oname}->{self}=$contact; } # ############ Transform commands sub build_cdata { my ($contact)=@_; my @d; push @d,['contact:name',$contact->name()] if (defined($contact->name())); push @d,Net::DRI::Protocol::EPP::Util::build_tel('contact:phone',$contact->voice()) if defined $contact->voice(); push @d,Net::DRI::Protocol::EPP::Util::build_tel('contact:fax',$contact->fax()) if defined $contact->fax(); push @d,Net::DRI::Protocol::EPP::Util::build_tel('contact:mobile',$contact->mobile()) if defined $contact->mobile(); push @d,['contact:email',$contact->email()] if defined($contact->email()); return @d; } sub update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if (grep { ! /^(?:set)$/ } $todo->types('info')) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only info set available for contact in .UK'); } my @d=build_command($mes,'update',$contact); my $newc=$todo->set('info'); if ($newc) { Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact '.$newc) unless (Net::DRI::Util::isa_contact($newc,'Net::DRI::Data::Contact::Nominet')); $newc->validate(1); ## will trigger an Exception if needed my @c=build_cdata($newc); if (@c) { push @d,@c; } else { Net::DRI::Exception->die(0,'protocol/EPP',11,'Nothing to update !'); } } else { Net::DRI::Exception->die(0,'protocol/EPP',11,'Nothing to update !'); } $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Account.pm0000644000175000017500000003477511352534377024361 0ustar patrickpatrick## Domain Registry Interface, .UK EPP Account commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Nominet::Account; use strict; use warnings; use Net::DRI::Protocol::EPP::Core::Contact; use Net::DRI::Protocol::EPP::Extensions::Nominet::Contact; use Net::DRI::Util; use Net::DRI::Exception;; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Nominet::Account - .UK EPP Account commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ \&info, \&info_parse ], update => [ \&update ], fork => [ \&fork, \&fork_parse ], merge => [ \&merge ], list_domains => [\&list_domains, \&list_domains_parse ], ); return { 'account' => \%tmp }; } sub build_command { my ($msg,$command,$contact)=@_; Net::DRI::Exception->die(1,'protocol/EPP',2,'Contact id needed') unless (defined($contact)); my $id=extract_contact_id($contact); Net::DRI::Exception->die(1,'protocol/EPP',2,'Contact id needed') unless (defined($id) && $id && !ref($id)); Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact id: '.$id) unless Net::DRI::Util::xml_is_token($id,3,16); ## inherited from Core EPP my $tcommand=(ref($command))? $command->[0] : $command; my $ns=($command eq 'update')? sprintf('xmlns:contact="%s" xmlns:account="%s" xsi:schemaLocation="%s %s"',$msg->ns('contact'),$msg->nsattrs('account')) : sprintf('xmlns:account="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('account')); $msg->command([$command,'account:'.$tcommand,$ns]); return (['account:roid',$id]); } sub extract_contact_id { my $contact=shift; my $id; if (Net::DRI::Util::isa_contactset($contact)) { my $c=$contact->get('registrant'); Net::DRI::Exception->die(1,'protocol/EPP',2,'ContactSet must contain a registrant contact object') unless (Net::DRI::Util::isa_contact($c,'Net::DRI::Data::Contact::Nominet')); $id=$c->roid(); } elsif (Net::DRI::Util::isa_contact($contact,'Net::DRI::Data::Contact::Nominet')) { $id=$contact->roid(); } else { $id=$contact; } return $id; } #################################################################################################### ########### Query commands sub info { my ($epp,$c)=@_; my $mes=$epp->message(); my @d=build_command($mes,'info',$c); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('account','infData'); return unless defined $infdata; parse_infdata($po,$mes,$infdata,$oname,$rinfo); } sub parse_infdata { my ($po,$mes,$infdata,$oname,$rinfo)=@_; my %c; my $addr=0; my $cs=$po->create_local_object('contactset'); my $ca=$po->create_local_object('contact'); foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'roid') { $oname=$c->textContent(); $ca->roid($oname); $cs->set($ca,'registrant'); $rinfo->{account}->{$oname}->{roid}=$rinfo->{contact}->{$oname}->{roid}=$oname; $rinfo->{account}->{$oname}->{action}=$rinfo->{contact}->{$oname}->{roid}='info'; $rinfo->{account}->{$oname}->{exist}=$rinfo->{contact}->{$oname}->{roid}=1; } elsif (my ($w)=($name=~m/^(name|trad-name|type|co-no|opt-out)$/)) { $w=~s/-/_/; $w='org' if $w eq 'trad_name'; $ca->$w($c->textContent()); } elsif ($name eq 'addr') { if ($addr) { ## Creating a second registrant contact to hold optional billing address my $ca2=$po->create_local_object('contact'); parse_addr($c,$ca2); $cs->add($ca2,'registrant'); } else { parse_addr($c,$ca); $addr++; } } elsif ($name eq 'contact') { my $type=$c->getAttribute('type'); ## admin or billing my $order=$c->getAttribute('order'); ## 1 or 2 or 3 my $co=$po->create_local_object('contact'); if ($c->getChildrenByTagNameNS($mes->ns('contact'),'infData')) { Net::DRI::Protocol::EPP::Extensions::Nominet::Contact::parse_infdata($po,$c->getChildrenByTagNameNS($mes->ns('contact'),'infData')->get_node(1),$co,undef,$rinfo); } $c{$type}->{$order}=$co; } elsif ($name=~m/^(clID|crID|upID)$/) { $rinfo->{account}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(crDate|upDate)$/) { $rinfo->{account}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } $cs->set([ map { $c{'admin'}->{$_} } sort { $a <=> $b } keys(%{$c{'admin'}}) ],'admin') if (exists($c{'admin'})); $cs->set([ map { $c{'billing'}->{$_} } sort { $a <=> $b } keys(%{$c{'billing'}}) ],'billing') if (exists($c{'billing'})); $rinfo->{account}->{$oname}->{self}=$cs; return $cs; } sub parse_addr { my ($n,$c)=@_; my @street; foreach my $el (Net::DRI::Util::xml_list_children($n)) { my ($name,$n)=@$el; if ($name eq 'street') { push @street,$n->textContent(); } elsif ($name eq 'locality') { push @street,$n->textContent(); } elsif ($name eq 'city') { $c->city($n->textContent()); } elsif ($name eq 'county') { $c->sp($n->textContent()); } elsif ($name eq 'postcode') { $c->pc($n->textContent()); } elsif ($name eq 'country') { $c->cc($n->textContent()); } } $c->street(\@street); } sub build_addr { my ($c,$type)=@_; my @d; my @s=$c->street(); if (@s) { @s=@{$s[0]}; push @d,['account:street',$s[0]]; push @d,['account:locality',$s[1]]; } push @d,['account:city',$c->city()] if $c->city(); push @d,['account:county',$c->sp()] if $c->sp(); push @d,['account:postcode',$c->pc()] if $c->pc(); push @d,['account:country',$c->cc()] if $c->cc(); return @d? ['account:addr',{type=>$type},@d] : (); } sub add_account_data { my ($mes,$cs,$ischange)=@_; my $modtype=$ischange? 'update' : 'create'; my @a; my @o=$cs->get('registrant'); if (Net::DRI::Util::isa_contact($o[0],'Net::DRI::Data::Contact::Nominet')) { $o[0]->validate($ischange); push @a,['account:name',$o[0]->name()] unless $ischange; push @a,['account:trad-name',$o[0]->org()] if $o[0]->org(); push @a,['account:type',$o[0]->type()] if (!$ischange || $o[0]->type()); push @a,['account:co-no',$o[0]->co_no()] if $o[0]->co_no(); push @a,['account:opt-out',$o[0]->opt_out()] if (!$ischange || $o[0]->opt_out()); push @a,build_addr($o[0],'admin'); } else { Net::DRI::Exception::usererr_insufficient_parameters('registrant data is mandatory') unless $ischange; } if (Net::DRI::Util::isa_contact($o[1],'Net::DRI::Data::Contact::Nominet')) { $o[1]->validate() unless $ischange; my @t=build_addr($o[1],'billing'); push @a,($ischange && !@t)? ['account:addr',{type=>'billing'}] : @t; } @o=$cs->get('admin'); Net::DRI::Exception::usererr_insufficient_parameters('admin data is mandatory') unless ($ischange || Net::DRI::Util::isa_contact($o[0],'Net::DRI::Data::Contact::Nominet')); foreach my $o (0..2) { last unless defined($o[$o]); my @t=Net::DRI::Protocol::EPP::Extensions::Nominet::Contact::build_cdata($o[$o]); my $contype=$ischange? (($o[$o]->srid())? 'update' : 'create') : $modtype; push @a,['account:contact',{type=>'admin',order=>$o+1},($ischange && !@t)? () : ['contact:'.$contype,@t]]; } @o=$cs->get('billing'); foreach my $o (0..2) { last unless defined($o[$o]); my @t=Net::DRI::Protocol::EPP::Extensions::Nominet::Contact::build_cdata($o[$o]); my $contype=$ischange? (($o[$o]->srid())? 'update' : 'create') : $modtype; push @a,['account:contact',{type=>'billing',order=>$o+1},($ischange && !@t)? () : ['contact:'.$contype,@t]]; } return @a; } sub update { my ($epp,$c,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); my $cs=$todo->set('contact'); Net::DRI::Exception::usererr_invalid_parameters($cs.' must be a Net::DRI::Data::ContactSet object') unless Net::DRI::Util::isa_contactset($cs); my @d=build_command($mes,'update',$c); push @d,add_account_data($mes,$cs,1); $mes->command_body(\@d); } sub fork { my ($epp,$c,$rh)=@_; Net::DRI::Exception::usererr_invalid_parameters('For account fork, a domains key must be there with a ref array of domain names to fork') unless (Net::DRI::Util::has_key($rh,'domains') && (ref($rh->{domains}) eq 'ARRAY')); my $mes=$epp->message(); $mes->command(['update','account:fork',sprintf('xmlns:account="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('account'))]); my @d; my $id=extract_contact_id($c); push @d,['account:roid',$id] if (defined($id) && $id); foreach my $d (@{$rh->{domains}}) { next unless (defined($d) && $d && Net::DRI::Util::is_hostname($d)); push @d,['account:domain-name',$d]; } $mes->command_body(\@d); } sub parse_credata { my ($mes,$node,$po,$cs,$rinfo)=@_; my %c; my $nsa=$mes->ns('account'); my $roid=$node->getChildrenByTagNameNS($nsa,'roid')->get_node(1)->textContent(); my $name=$node->getChildrenByTagNameNS($nsa,'name')->get_node(1)->textContent(); my $co=$po->create_local_object('contact')->srid($roid)->name($name); $cs->set($co,'registrant'); $rinfo->{contact}->{$roid}->{exist}=1; $rinfo->{contact}->{$roid}->{roid}=$roid; $rinfo->{contact}->{$roid}->{self}=$co; my $nsc=$mes->ns('contact'); foreach my $ac ($node->getChildrenByTagNameNS($nsa,'contact')) { my $type=$ac->getAttribute('type'); my $order=$ac->getAttribute('order'); my $credata=$ac->getChildrenByTagNameNS($nsc,'creData')->get_node(1); my $roid2=$credata->getChildrenByTagNameNS($nsc,'roid')->get_node(1)->textContent(); my $name2=$credata->getChildrenByTagNameNS($nsc,'name')->get_node(1)->textContent(); $co=$po->create_local_object('contact')->srid($roid2)->name($name2); $c{$type}->{$order}=$co; $rinfo->{contact}->{$roid2}->{exist}=1; $rinfo->{contact}->{$roid2}->{roid}=$roid2; $rinfo->{contact}->{$roid2}->{self}=$co; } $cs->set([ map { $c{'admin'}->{$_} } sort { $a <=> $b } keys(%{$c{'admin'}}) ],'admin') if (exists($c{'admin'})); $cs->set([ map { $c{'billing'}->{$_} } sort { $a <=> $b } keys(%{$c{'billing'}}) ],'billing') if (exists($c{'billing'})); $rinfo->{account}->{$roid}->{self}=$cs; $rinfo->{account}->{$roid}->{exist}=1; return $roid; } sub fork_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_response('account','creData'); return unless $credata; my $cs=$po->create_local_object('contactset'); my $roid=parse_credata($mes,$credata,$po,$cs,$rinfo); $rinfo->{account}->{$roid}->{action}='fork'; $rinfo->{account}->{$oname}->{fork_to}=$roid if defined($oname); ## roid not mandatory during fork call } sub merge { my ($epp,$c,$rh)=@_; my $mes=$epp->message(); my @d=build_command($mes,'merge',$c); my $cmd=$mes->command(); shift(@$cmd); $mes->command(['update',@$cmd]); $mes->command_body(\@d); if (Net::DRI::Util::has_key($rh,'roid_source') && (ref($rh->{roid_source}) eq 'ARRAY')) { push @d,map { ['account:roid',{source=>'y'},$_] } @{$rh->{roid_source}}; } if (Net::DRI::Util::has_key($rh,'names') && (ref($rh->{names}) eq 'ARRAY')) { push @d,map { ['account:name',$_] } @{$rh->{names}}; } Net::DRI::Exception::usererr_invalid_parameters('For account merge, a domains key must be there with a ref array of domain names to fork') unless (Net::DRI::Util::has_key($rh,'domains') && (ref($rh->{domains}) eq 'ARRAY')); foreach my $d (@{$rh->{domains}}) { next unless (defined($d) && $d && Net::DRI::Util::is_hostname($d)); push @d,['account:domain-name',$d]; } $mes->command_body(\@d); } #################################################################################################### ## In Nominet documentation this is listed as an operation acting on *one* domain ## See http://www.nominet.org.uk/registrars/systems/nominetepp/list/ sub list_domains { my ($epp,$rd,$rh)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('list_domains needs a ref hash with a registration or expiration key') unless Net::DRI::Util::has_key($rd,'registration') || Net::DRI::Util::has_key($rd,'expiration'); $mes->command(['info','domain:list',sprintf('xmlns:domain="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('domain'))]); my @d; if (Net::DRI::Util::has_key($rd,'registration')) { Net::DRI::Util::check_isa($rd->{registration},'DateTime'); push @d,['domain:month',$rd->{registration}->set_time_zone('UTC')->strftime('%Y-%m')]; } else { Net::DRI::Util::check_isa($rd->{expiration},'DateTime'); push @d,['domain:expiry',$rd->{registration}->set_time_zone('UTC')->strftime('%Y-%m')]; } push @d,['domain:fields','none']; ## with that we get only domain names back, if 'all' instead we get full infData for each domain, as in domain_info reply $mes->command_body(\@d); } sub list_domains_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); ## This should be the same as poll messages: registrar change, domains released, poor quality. TODO: some factorization my $list=$mes->get_response('domain','listData'); $rinfo->{account}->{domains}->{action}='list'; $rinfo->{account}->{domains}->{list}=defined $list ? [ map { $_->textContent() } $list->getChildrenByTagNameNS($mes->ns('domain'),'name') ] : []; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Domain.pm0000644000175000017500000003024211352534377024155 0ustar patrickpatrick## Domain Registry Interface, .UK EPP Domain commands ## ## Copyright (c) 2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Nominet::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Core::Domain; use Net::DRI::Protocol::EPP::Extensions::Nominet::Account; use Net::DRI::Protocol::EPP::Extensions::Nominet::Host; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Nominet::Domain - .UK EPP Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&Net::DRI::Protocol::EPP::Core::Domain::check, \&Net::DRI::Protocol::EPP::Core::Domain::check_parse ], info => [ \&info, \&info_parse ], delete => [ \&Net::DRI::Protocol::EPP::Core::Domain::delete ], renew => [ \&renew, \&Net::DRI::Protocol::EPP::Core::Domain::renew_parse ], transfer_request => [ \&transfer_request ], transfer_answer => [ \&transfer_answer ], create => [\&create, \&create_parse ], update => [\&update], unrenew => [\&unrenew], ); $tmp{check_multi}=$tmp{check}; return { 'domain' => \%tmp }; } #################################################################################################### ########### Query commands sub info { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'info',$domain); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('domain','infData'); return unless defined $infdata; my $ns=$po->create_local_object('hosts'); my @n; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{domain}->{$oname}->{action}='info'; $rinfo->{domain}->{$oname}->{exist}=1; } elsif ($name=~m/^(reg-status|first-bill|recur-bill|auto-bill|next-bill)$/) { ## See http://www.nominet.org.uk/registrars/systems/data/fields/ $rinfo->{domain}->{$oname}->{$1}=$c->textContent(); } elsif ($name eq 'notes') ## There may be more than one instance of this element. (http://www.nominet.org.uk/registrars/systems/epp/domainnamelistelements/) { push @n,$c->textContent(); } elsif ($name eq 'account') { my $cs=Net::DRI::Protocol::EPP::Extensions::Nominet::Account::parse_infdata($po,$mes,$c->getChildrenByTagNameNS($mes->ns('account'),'infData')->get_node(1),undef,$rinfo); $rinfo->{domain}->{$oname}->{contact}=$cs; } elsif ($name eq 'ns') { $rinfo->{domain}->{$oname}->{ns}=Net::DRI::Protocol::EPP::Util::parse_ns($po,$c); } elsif ($name=~m/^(clID|crID|upID)$/) { $rinfo->{domain}->{$oname}->{$1}=$c->textContent(); } elsif ($name=~m/^(crDate|upDate|exDate)$/) { $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } $rinfo->{domain}->{$oname}->{ns}=$ns; $rinfo->{domain}->{$oname}->{notes}=\@n; } ############ Transform commands #################################################################### sub renew { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'renew',$domain); push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd); $mes->command_body(\@d); } sub transfer_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>'request'}],$domain); Net::DRI::Exception::usererr_insufficient_parameters('Extra parameters must be provided for domain transfer request, at least a registrar_tag') unless Net::DRI::Util::has_key($rd,'registrar_tag'); Net::DRI::Exception::usererr_invalid_parameters('Registrar tag must be an XML token from 2 to 16 characters') unless Net::DRI::Util::xml_is_token($rd->{registrar_tag},2,16); push @d,['domain:registrar-tag',$rd->{registrar_tag}]; if (Net::DRI::Util::has_key($rd,'account_id')) { my $id=Net::DRI::Util::isa_contactset($rd->{account_id})? $rd->{account_id}->get('registrant')->srid() : $rd->{account_id}; Net::DRI::Exception::usererr_invalid_parameters('Account id must be an XML token with pattern [0-9]*(-UK)?') unless (Net::DRI::Util::xml_is_token($id) && $id=~m/^\d+(?:-UK)?$/); push @d,['domain:account',['domain:account-id',$id]]; } $mes->command_body(\@d); } sub transfer_answer { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); $mes->command([['transfer',{'op'=>(Net::DRI::Util::has_key($rd,'approve') && $rd->{approve})? 'approve' : 'reject'}]]); Net::DRI::Exception::usererr_insufficient_parameters('Extra parameters must be provided for domain transfer request, at least a case_id') unless Net::DRI::Util::has_key($rd,'case_id'); Net::DRI::Exception::usererr_invalid_parameters('Case id must be an XML token up to 12 characters') unless Net::DRI::Util::xml_is_token($rd->{case_id},undef,12); my @ns=@{$mes->ns()->{notifications}}; my @d=['n:rcCase',{ 'xmlns:n' => $ns[0], 'xsi:schemaLocation' => $ns[0].' '.$ns[1]},['n:case-id',$rd->{case_id}]]; $mes->command_body(\@d); } sub build_ns { my ($epp,$ns,$domain)=@_; my @d; foreach my $i (1..$ns->count()) { my ($n,$r4,$r6)=$ns->get_details($i); my @h; push @h,['domain:hostName',$n]; if (($n=~m/\S+\.${domain}$/i) || (lc($n) eq lc($domain))) { ## The registry accepts only ONE Ipv4 or IPv6 address :-( ! push @h,['domain:hostAddr',$r4->[0],{ip=>'v4'}] if @$r4; push @h,['domain:hostAddr',$r6->[0],{ip=>'v6'}] if @$r6; } push @d,['domain:host',@h]; } return ['domain:ns',@d]; } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'create',$domain); push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd); ## account=contact Net::DRI::Exception::usererr_insufficient_parameters('account data is mandatory') unless Net::DRI::Util::has_key($rd,'contact'); if (Net::DRI::Util::isa_contactset($rd->{contact})) { push @d,['domain:account',['account:create',{'xmlns:account'=>$mes->ns('account'),'xmlns:contact'=>$mes->ns('contact')},Net::DRI::Protocol::EPP::Extensions::Nominet::Account::add_account_data($mes,$rd->{contact},0)]]; } else { push @d,['domain:account',['domain:account-id',$rd->{contact}]]; } ## ns, optional push @d,build_ns($mes,$rd->{ns},$domain) if (Net::DRI::Util::has_ns($rd)); ## See http://www.nominet.org.uk/registrars/systems/data/fields/#billing push @d,['domain:first-bill',$rd->{'first-bill'}] if (Net::DRI::Util::has_key($rd,'first-bill') && $rd->{'first-bill'}=~m/^(?:th|bc)$/); push @d,['domain:recur-bill',$rd->{'recur-bill'}] if (Net::DRI::Util::has_key($rd,'recur-bill') && $rd->{'recur-bill'}=~m/^(?:th|bc)$/); push @d,['domain:auto-bill',$rd->{'auto-bill'}] if (Net::DRI::Util::has_key($rd,'auto-bill') && $rd->{'auto-bill'}=~m/^\d+$/ && $rd->{'auto-bill'}>=1 && $rd->{'auto-bill'}<=182); push @d,['domain:next-bill',$rd->{'next-bill'}] if (Net::DRI::Util::has_key($rd,'next-bill') && $rd->{'next-bill'}=~m/^\d+$/ && $rd->{'next-bill'}>=1 && $rd->{'next-bill'}<=182); push @d,['domain:notes',$rd->{notes}] if Net::DRI::Util::has_key($rd,'notes'); $mes->command_body(\@d); } sub create_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_response('domain','creData'); return unless defined $credata; my $cs=$po->create_local_object('contactset'); foreach my $el (Net::DRI::Util::xml_list_children($credata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); $rinfo->{domain}->{$oname}->{action}='create'; $rinfo->{domain}->{$oname}->{exist}=1; } elsif ($name eq 'account') { my $node=$c->getChildrenByTagNameNS($mes->ns('account'),'creData')->get_node(1); my $roid=Net::DRI::Protocol::EPP::Extensions::Nominet::Account::parse_credata($mes,$node,$po,$cs,$rinfo); $rinfo->{account}->{$roid}->{action}='create'; $rinfo->{domain}->{$oname}->{contact}=$cs; } elsif ($name=~m/^(crDate|exDate)$/) { $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent()); } } } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'update',$domain); my $ns=$todo->set('ns'); my $co=$todo->set('contact'); ## account if (Net::DRI::Util::isa_contactset($co)) { push @d,['domain:account',['account:update',{'xmlns:account'=>$mes->ns('account'),'xmlns:contact'=>$mes->ns('contact')},Net::DRI::Protocol::EPP::Extensions::Nominet::Account::add_account_data($mes,$co,1)]]; } ## NS if (Net::DRI::Util::isa_hosts($ns,1)) { if ($ns->is_empty()) { push @d,['domain:ns']; ## empty domain:ns means removal of all nameservers from domain } else { push @d,build_ns($mes,$ns,$domain); } } my $tmp=$todo->set('first-bill'); push @d,['domain:first-bill',$tmp] if (defined($tmp) && $tmp=~m/^(?:th|bc)$/); $tmp=$todo->set('recur-bill'); push @d,['domain:recur-bill',$tmp] if (defined($tmp) && $tmp=~m/^(?:th|bc)$/); Net::DRI::Exception::usererr_invalid_parameters('For domain_update auto-bill and next-bill can not be there at the same time') if (defined($todo->set('auto-bill')) && $todo->set('auto-bill') && defined($todo->set('next-bill')) && $todo->set('next-bill')); $tmp=$todo->set('auto-bill'); push @d,['domain:auto-bill',$tmp] if (defined($tmp) && ($tmp eq '' || ($tmp=~m/^\d+$/ && $tmp>=1 && $tmp<=182))); $tmp=$todo->set('next-bill'); push @d,['domain:next-bill',$tmp] if (defined($tmp) && ($tmp eq '' || ($tmp=~m/^\d+$/ && $tmp>=1 && $tmp<=182))); $tmp=$todo->set('notes'); push @d,['domain:notes',$tmp] if defined($tmp); $mes->command_body(\@d); } ## Warning: this can also be used for multiple domain names at once, ## see http://www.nominet.org.uk/registrars/systems/nominetepp/Unrenew/ ## However, if we accept that, we will probably have to tweak Core::Domain::renew_parse ## to handle multiple renData nodes in the response. sub unrenew { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command(['update','domain:unrenew',sprintf('xmlns:domain="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('domain'))]); my @d=(['domain:name',$domain]); $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Notifications.pm0000644000175000017500000002657011352534377025570 0ustar patrickpatrick## Domain Registry Interface, .UK EPP Notifications ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Nominet::Notifications; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Extensions::Nominet::Account; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Nominet::Notifications - .UK EPP Notifications for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmpn=( registrar_change => [ undef, \®istrar_change ], registrant_change => [ undef, \®istrant_change ], domain_cancelled => [ undef, \&domain_cancelled ], poor_quality => [ undef, \&poor_quality ], domains_released => [ undef, \&domains_released ], ); my %tmpd=map { $_ => [ undef, \&domain_failwarning ] } qw/info update create/; ## the documentation is not clear about when this happen => we take some cases as others below + create since it is in example my %tmpa=map { $_ => [ undef, \&account_failwarning ] } qw/info update/; my %tmpc=map { $_ => [ undef, \&contact_failwarning ] } qw/info update/; my %tmph=map { $_ => [ undef, \&host_failwarning ] } qw/info update/; return { 'notifications' => \%tmpn, 'domain' => \%tmpd, 'account' => \%tmpa, 'contact' => \%tmpc, 'host' => \%tmph, }; } #################################################################################################### ## http://www.nominet.org.uk/registrars/systems/epp/registrarchange/ ## http://www.nominet.org.uk/registrars/systems/epp/handshakerequest/ sub registrar_change { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rcdata=$mes->get_response('notifications','rcData'); return unless defined $rcdata; my $msgid=$mes->msg_id(); my $ns=$mes->ns('notifications'); $rinfo->{message}->{$msgid}->{action}='registrar_change'; $rinfo->{message}->{$msgid}->{orig}=Net::DRI::Util::xml_child_content($rcdata,$ns,'orig'); $rinfo->{message}->{$msgid}->{registrar_to}=Net::DRI::Util::xml_child_content($rcdata,$ns,'registrar-tag'); if ($rcdata->getChildrenByTagNameNS($ns,'case-id')->size()) { $rinfo->{message}->{$msgid}->{action}='handshake_request'; $rinfo->{message}->{$msgid}->{case_id}=Net::DRI::Util::xml_child_content($rcdata,$ns,'case-id'); } my $list=$mes->get_response('domain','listData'); ## attribute no-domains is not used, as there should be as many simpleInfData as domain names my @d=parse_listdata($mes,$list,$rinfo); $rinfo->{message}->{$msgid}->{domains}=\@d; my $ainfo=$mes->get_response('account','infData'); ## TODO : parse account info, see Account::parse_infdata } sub parse_listdata { my ($mes,$list,$rinfo)=@_; my $nsd=$mes->ns('domain'); my @d; foreach my $d ($list->getChildrenByTagNameNS($nsd,'simpleInfData')) { push @d,Net::DRI::Util::xml_child_content($d,$nsd,'name'); ## TODO : parse other keys, using Domain::info_parse stuff extracted into some sort of parse_infdata } return @d; } ## http://www.nominet.org.uk/registrars/systems/epp/registrantchange/ sub registrant_change { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rcdata=$mes->get_response('notifications','trnData'); return unless defined $rcdata; my $msgid=$mes->msg_id(); my $ns=$mes->ns('notifications'); $rinfo->{message}->{$msgid}->{action}='registrant_change'; $rinfo->{message}->{$msgid}->{account_from}=Net::DRI::Util::xml_child_content($rcdata,$ns,'old-account-id'); $rinfo->{message}->{$msgid}->{account_to}=Net::DRI::Util::xml_child_content($rcdata,$ns,'account-id'); ## domainList or listData ??? The documentation is very unclear on details like that ! my $list=$mes->get_response('domain','domainList'); ## attribute no-domains is not used, as there should be as many simpleInfData as domain names my @d=parse_listdata($mes,$list,$rinfo); $rinfo->{message}->{$msgid}->{domains}=\@d; my $ainfo=$mes->get_response('account','infData'); ## TODO : parse account info, see Account::parse_infdata } ## http://www.nominet.org.uk/registrars/systems/epp/accountdetails/ ## TODO : we do not parse the changed="Y" attribute ## http://www.nominet.org.uk/registrars/systems/epp/domaincancelled/ sub domain_cancelled { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $cancdata=$mes->get_response('notifications','cancData'); return unless defined $cancdata; my $ns=$mes->ns('notifications'); my $name=Net::DRI::Util::xml_child_content($cancdata,$ns,'domain-name'); $rinfo->{domain}->{$name}->{exist}=0; $rinfo->{domain}->{$name}->{action}='cancelled'; $rinfo->{domain}->{$name}->{cancelled_orig}=Net::DRI::Util::xml_child_content($cancdata,$ns,'orig'); } ## http://www.nominet.org.uk/registrars/systems/epp/handshakerejected/ ## seem totally bogus and conflicts with http://www.nominet.org.uk/registrars/systems/epp/domainsreleased/ ## http://www.nominet.org.uk/registrars/systems/epp/poorqualitydata/ sub poor_quality { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $pqdata=$mes->get_response('notifications','pqData'); return unless defined $pqdata; my $msgid=$mes->msg_id(); my $ns=$mes->ns('notifications'); $rinfo->{message}->{$msgid}->{action}='poor_quality'; $rinfo->{message}->{$msgid}->{poor_quality_stage}=$pqdata->getAttribute('stage'); my $d=$pqdata->getChildrenByTagNameNS($ns,'suspend-date'); $rinfo->{message}->{$msgid}->{poor_quality_suspend}=$po->parse_iso8601($d->get_node(1)->textContent()) if $d->size(); $d=$pqdata->getChildrenByTagNameNS($ns,'cancel-date'); $rinfo->{message}->{$msgid}->{poor_quality_cancel}=$po->parse_iso8601($d->get_node(1)->textContent()) if $d->size(); ## No account:infData, what a great idea (not) ! my $nsa=$mes->ns('account'); my $a=$po->create_local_object('contact'); ## Text & XML do not agree ! $a->roid(Net::DRI::Util::xml_child_content($pqdata,$nsa,'roid')); $a->name(Net::DRI::Util::xml_child_content($pqdata,$nsa,'name')); $d=$pqdata->getChildrenByTagNameNS($nsa,'addr'); if ($d->size()) { Net::DRI::Protocol::EPP::Extensions::Nominet::Account::parse_addr($d->get_node(1),$a); } $rinfo->{message}->{$msgid}->{poor_quality_account}=$a; my $list=$mes->get_response('domain','listData'); ## attribute no-domains is not used, as there should be as many simpleInfData as domain names ## here we do not use the same listData as everywhere else ! What a great idea (not) ! my $nsd=$mes->ns('domain'); my @d; foreach my $d ($list->getChildrenByTagNameNS($nsd,'name')) { push @d,$d->textContent(); } $rinfo->{message}->{$msgid}->{domains}=\@d; } ## http://www.nominet.org.uk/registrars/systems/epp/domainsreleased/ sub domains_released { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $reldata=$mes->get_response('notifications','relData'); return unless defined $reldata; my $msgid=$mes->msg_id(); my $ns=$mes->ns('notifications'); $rinfo->{message}->{$msgid}->{action}='domains_released'; my $n=$reldata->getChildrenByTagNameNS($ns,'account-id')->get_node(1); $rinfo->{message}->{$msgid}->{account_id}=$n->textContent(); $rinfo->{message}->{$msgid}->{account_moved}=$n->getAttribute('moved') eq 'Y'? 1 : 0; $rinfo->{message}->{$msgid}->{registrar_from}=Net::DRI::Util::xml_child_content($reldata,$ns,'from'); $rinfo->{message}->{$msgid}->{registrar_to}=Net::DRI::Util::xml_child_content($reldata,$ns,'registrar-tag'); my $list=$mes->get_response('domain','listData'); ## attribute no-domains is not used, as there should be as many simpleInfData as domain names ## here we do not use the same listData as everywhere else ! What a great idea (not) ! my $nsd=$mes->ns('domain'); my @d; foreach my $d ($list->getChildrenByTagNameNS($nsd,'name')) { push @d,$d->textContent(); } $rinfo->{message}->{$msgid}->{domains}=\@d; } #################################################################################################### # http://www.nominet.org.uk/registrars/systems/epp/error/ sub faildata_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); ## no test on success, as this obviously can happen when no success ! my $faildata=$mes->get_response($otype,'failData'); return unless defined $faildata; my $ns=$mes->ns($otype); my $name=Net::DRI::Util::xml_child_content($faildata,$ns,$otype eq 'domain'? 'name' : 'roid'); $rinfo->{$otype}->{$name}->{fail_reason}=Net::DRI::Util::xml_child_content($faildata,$ns,'reason'); $rinfo->{$otype}->{$name}->{action}='fail' unless exists $rinfo->{$otype}->{$name}->{action}; $rinfo->{$otype}->{$name}->{exist}=0 unless exists $rinfo->{$otype}->{$name}->{exist}; } sub warning_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); ## the documentation seems to imply it is only during success, but not very clear my $warning=$mes->get_extension($otype,'warning'); return unless defined $warning; ## No clear specification of the content $rinfo->{$otype}->{$oname}->{warning}=$warning->textContent(); } # http://www.nominet.org.uk/registrars/systems/epp/error/ (does not explain when this case can occur for domain operations) # http://www.nominet.org.uk/registrars/systems/epp/referralreject/ sub domain_failwarning { my ($po,$otype,$oaction,$oname,$rinfo)=@_; faildata_parse($po,'domain',$oaction,$oname,$rinfo); warning_parse($po,'domain',$oaction,$oname,$rinfo); } sub account_failwarning { my ($po,$otype,$oaction,$oname,$rinfo)=@_; faildata_parse($po,'account',$oaction,$oname,$rinfo); warning_parse($po,'account',$oaction,$oname,$rinfo); } sub contact_failwarning { my ($po,$otype,$oaction,$oname,$rinfo)=@_; faildata_parse($po,'contact',$oaction,$oname,$rinfo); warning_parse($po,'contact',$oaction,$oname,$rinfo); } sub host_failwarning { my ($po,$otype,$oaction,$oname,$rinfo)=@_; faildata_parse($po,'ns',$oaction,$oname,$rinfo); warning_parse($po,'ns',$oaction,$oname,$rinfo); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/E164Validation.pm0000644000175000017500000001540611352534377023774 0ustar patrickpatrick## Domain Registry Interface, EPP E.164 Validation (RFC5076) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::E164Validation; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='urn:ietf:params:xml:ns:e164val-1.0'; our @VALIDATION_MODULES=qw/RFC5076/; ## modules to handle validation information, override this variable to use other validation modules =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::E164Validation - EPP E.164 Validation (RFC5076) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], create => [ \&create, undef ], renew => [ \&renew, undef ], transfer_request => [ \&transfer_request, undef ], update => [ \&update, undef ], ); load_validation_modules(); return { 'domain' => \%tmp }; } sub capabilities_add { return ('domain_update','e164_validation_information',['add','del','set']); } our %VAL; sub load_validation_modules ## §4.4 §4.5 { foreach my $mod (@VALIDATION_MODULES) { my $class=($mod=~m/::/)? $mod : 'Net::DRI::Protocol::EPP::Extensions::E164Validation::'.$mod; $class->require or Net::DRI::Exception::err_failed_load_module('protocol/epp_e164validation',$class,$@); my ($uri)=$class->load(); $VAL{$uri}=$class; } } #################################################################################################### sub format_validation { my ($e,$what,$top)=@_; Net::DRI::Exception::usererr_insufficient_parameters('Each validation information must be a reference to an array with 3 elements : 2 strings (id & uri) and a reference of an hash') unless (ref($e) eq 'ARRAY' && @$e==3 && !ref($e->[0]) && length $e->[0] && !ref($e->[1]) && length $e->[1] && (ref($e->[2]) eq 'HASH') && keys(%{$e->[2]})); Net::DRI::Exception::usererr_invalid_parameters('Id is syntaxically invalid: '.$e->[0]) unless Net::DRI::Util::xml_is_ncname($e->[0]); Net::DRI::Exception::usererr_insufficient_parameters('No validation information module found for URI='.$e->[1]) unless exists($VAL{$e->[1]}); Net::DRI::Exception::usererr_invalid_parameters(sprintf('Validation module %s for URI %s must a have a %s method',$VAL{$e->[1]},$e->[1],$what)) unless $VAL{$e->[1]}->can($what); my @c=$VAL{$e->[1]}->$what($e->[2]); return [$top,{id=>$e->[0]},['e164val:validationInfo',@c]]; } sub add_validation_information { my ($epp,$domain,$rd,$action,$top)=@_; return unless (defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{e164_validation_information}) && (ref($rd->{e164_validation_information}) eq 'ARRAY') && @{$rd->{e164_validation_information}}); my $mes=$epp->message(); my $eid=$mes->command_extension_register('e164val:'.$action,'xmlns:e164val="'.$NS.'"'); my @n=map { format_validation($_,$action,$top) } as_array($rd->{e164_validation_information}); $mes->command_extension($eid,\@n); } sub as_array { my $ra=shift; if (grep { !ref($_) } @$ra) { return ($ra); } else { return @$ra; } } #################################################################################################### ########### Query commands sub info_parse ## §5.1.2 { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension($NS,'infData'); return unless defined $infdata; my @val; foreach my $el ($infdata->getChildrenByTagNameNS($NS,'inf')) { my $id=$el->getAttribute('id'); my $r=($el->getChildrenByTagNameNS($NS,'validationInfo'))[0]; $r=$r->getFirstChild(); while( $r->nodeType()!=1) { $r=$r->getNextSibling(); } my $uri=$r->namespaceURI(); Net::DRI::Exception::usererr_insufficient_parameters('No validation information module found for URI='.$uri) unless exists($VAL{$uri}); push @val,[$id,$uri,$VAL{$uri}->info_parse($po,$r)]; } $rinfo->{domain}->{$oname}->{e164_validation_information}=\@val; } #################################################################################################### ############ Transform commands sub create ## §5.2.1 { my ($epp,$domain,$rd)=@_; add_validation_information($epp,$domain,$rd,'create','e164val:add'); } sub renew ## §5.2.3 { my ($epp,$domain,$rd)=@_; add_validation_information($epp,$domain,$rd,'renew','e164val:add'); } sub transfer_request ## §5.2.4 { my ($epp,$domain,$rd)=@_; add_validation_information($epp,$domain,$rd,'transfer','e164val:add'); } sub update ## §5.2.5 { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $toadd=$todo->add('e164_validation_information'); my $todel=$todo->del('e164_validation_information'); my $toset=$todo->set('e164_validation_information'); return unless (defined($toadd) || defined($todel) || defined($toset)); my @n; push @n,map { format_validation($_,'update','e164val:add') } as_array($toadd) if (defined($toadd) && (ref($toadd) eq 'ARRAY')); push @n,map { ['e164val:rem',{id=>(ref($_) eq 'ARRAY')? $_->[0] : $_->[0]}] } as_array($todel) if (defined($todel) && (ref($todel) eq 'ARRAY')); push @n,map { format_validation($_,'update','e164val:chg') } (ref($toset) eq 'ARRAY')? @$toset : ($toset) if (defined($toset)); return unless @n; my $eid=$mes->command_extension_register('e164val:update','xmlns:e164val="'.$NS.'"'); $mes->command_extension($eid,\@n); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/DNSBE.pm0000644000175000017500000000601711352534377022173 0ustar patrickpatrick## Domain Registry Interface, DNSBE EPP extensions ## ## Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::DNSBE; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::BE; use Net::DRI::Protocol::EPP::Extensions::DNSBE::Message; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::DNSBE - DNSBE (.BE) EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; my $version=$self->version(); $self->ns({ dnsbe => ['http://www.dns.be/xml/epp/dnsbe-1.0','dnsbe-1.0.xsd'], nsgroup => ['http://www.dns.be/xml/epp/nsgroup-1.0','nsgroup-1.0.xsd'], }); $self->capabilities('contact_update','status',undef); ## No changes in status possible for .BE domains/contacts $self->capabilities('domain_update','status',undef); $self->capabilities('domain_update','auth',undef); ## No change in authinfo (since it is not used from the beginning) $self->capabilities('domain_update','nsgroup',['add','del']); $self->factories('contact',sub { return Net::DRI::Data::Contact::BE->new(); }); $self->factories('message',sub { my $m=Net::DRI::Protocol::EPP::Extensions::DNSBE::Message->new(@_); $m->ns($self->{ns}); $m->version($version); return $m;}); $self->default_parameters({domain_create => { auth => { pw => '' } } }); return; } sub core_contact_types { return ('admin','tech','billing','onsite'); } sub default_extensions { return qw/DNSBE::Domain DNSBE::Contact NSgroup/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CentralNic.pm0000644000175000017500000000452111352534377023360 0ustar patrickpatrick## Domain Registry Interface, CentralNic EPP extensions ## (http://labs.centralnic.com/epp/ext/) ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CentralNic; use strict; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CentralNic - CentralNic EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ttl => ['urn:centralnic:params:xml:ns:ttl-1.0','ttl-1.0.xsd'], wf => ['urn:centralnic:params:xml:ns:wf-1.0','wf-1.0.xsd'], }); $self->capabilities('domain_update','ttl',['set']); $self->capabilities('domain_update','web_forwarding',['set']); return; } sub default_extensions { return qw/CentralNic::TTL CentralNic::WebForwarding CentralNic::Release/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/FCCN.pm0000644000175000017500000000452111352534377022047 0ustar patrickpatrick## Domain Registry Interface, FCCN (.PT) EPP extensions ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::FCCN; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::FCCN - FCCN (.PT) EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ ptdomain => ['http://www.dns.pt/xml/epp/ptdomain-1.0','ptdomain-1.0.xsd'], ptcontact => ['http://www.dns.pt/xml/epp/ptcontact-1.0','ptcontact-1.0.xsd'], }); $self->capabilities('contact_update','status',undef); $self->default_parameters({domain_create => { auth => { pw => '' } } }); ## domain:authInfo is not used by FCCN return; } sub default_extensions { return qw/FCCN::Contact FCCN::Domain/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AERO.pm0000644000175000017500000000406711352534377022071 0ustar patrickpatrick## Domain Registry Interface, .AERO EPP extensions ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AERO; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AERO - .AERO EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({aero => ['urn:afilias:params:xml:ns:ext:aero-1.0','aero-1.0.xsd']}); return; } sub default_extensions { return qw/AERO::Domain AERO::Contact/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/IRegistry.pm0000644000175000017500000000545511352534377023266 0ustar patrickpatrick## Domain Registry Interface, .CO.CZ EPP extensions ## ## Copyright (c) 2008 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::IRegistry; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::IRegistry - .CO.CZ EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E or Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->{defaulti18ntype}='loc'; # The registry does not provide contact postalinfo i18n type, although it is mandatory by EPP $self->ns({ domain => ['http://www.nic.cz/xml/epp/domain-1.4','domain-1.4.xsd'], contact => ['http://www.nic.cz/xml/epp/contact-1.5','contact-1.5.xsd'], }); $self->capabilities('domain_update','status',undef); $self->capabilities('domain_update','nsset',['set']); $self->capabilities('nsset_update','ns',['add','del']); $self->capabilities('nsset_update','contact',['add','del']); $self->capabilities('nsset_update','auth',['set']); $self->capabilities('nsset_update','reportlevel',['set']); return; } sub core_contact_types { return ('admin','tech','billing','onsite'); } sub default_extensions { return qw/CZ::NSSET CZ::Contact CZ::Domain NSgroup/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/ARNES.pm0000644000175000017500000000441111352534377022204 0ustar patrickpatrick## Domain Registry Interface, ARNES (.SI) EPP extensions ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::ARNES; use strict; use Net::DRI::Data::Contact::ARNES; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::ARNES - ARNES (.SI) EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ dnssi => ['http://www.arnes.si/xml/epp/dnssi-1.1','dnssi-1.1.xsd'], }); $self->factories('contact',sub { return Net::DRI::Data::Contact::ARNES->new(@_); }); return; } sub core_contact_types { return ('admin','tech'); } ## No billing contact in .SI sub default_extensions { return qw/ARNES::Contact ARNES::Domain/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CZ.pm0000644000175000017500000000542511352534377021656 0ustar patrickpatrick## Domain Registry Interface, .CZ EPP extensions ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CZ; use strict; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CZ - .CZ EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E or Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->{defaulti18ntype}='loc'; # The registry does not provide contact postalinfo i18n type, although it is mandatory by EPP $self->ns({ domain => ['http://www.nic.cz/xml/epp/domain-1.3','domain-1.3.xsd'], contact => ['http://www.nic.cz/xml/epp/contact-1.4','contact-1.4.xsd'], }); $self->capabilities('domain_update','status',undef); $self->capabilities('domain_update','nsset',['set']); $self->capabilities('nsset_update','ns',['add','del']); $self->capabilities('nsset_update','contact',['add','del']); $self->capabilities('nsset_update','auth',['set']); $self->capabilities('nsset_update','reportlevel',['set']); return; } sub core_contact_types { return ('admin','tech','billing','onsite'); } sub default_extensions { return qw/CZ::NSSET CZ::Contact CZ::Domain NSgroup/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NO.pm0000644000175000017500000000626311352534377021657 0ustar patrickpatrick## Domain Registry Interface, NORID (.NO) EPP extensions ## ## Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NO; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::NO; our $VERSION = do { my @r = ( q$Revision: 1.5 $ =~ /\d+/gmx ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NO - .NO EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Trond Haugen, Einfo@norid.noE =head1 COPYRIGHT Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen Einfo@norid.noE All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ no_contact => [ 'http://www.norid.no/xsd/no-ext-contact-1.0','no-ext-contact-1.0.xsd' ], no_domain => [ 'http://www.norid.no/xsd/no-ext-domain-1.0','no-ext-domain-1.0.xsd' ], no_host => [ 'http://www.norid.no/xsd/no-ext-host-1.0','no-ext-host-1.0.xsd' ], no_result => [ 'http://www.norid.no/xsd/no-ext-result-1.0','no-ext-result-1.0.xsd' ], no_epp => [ 'http://www.norid.no/xsd/no-ext-epp-1.0','no-ext-epp-1.0.xsd' ], }); foreach my $o (qw/mobilephone identity xdisclose facets/) { $self->capabilities('contact_update',$o,['set']); } foreach my $o (qw/organization rolecontact xemail/) { $self->capabilities('contact_update',$o,['add','del']); } $self->capabilities('host_update','contact',['set']); $self->capabilities('host_update','facets',['set']); $self->capabilities('domain_update','facets',['set']); $self->factories('contact',sub { return Net::DRI::Data::Contact::NO->new(); }); return; } sub default_extensions { return qw/NO::Domain NO::Contact NO::Host NO::Result NO::Message/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/US/0002755000175000017500000000000011352534417021322 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/US/Contact.pm0000644000175000017500000000771011352534377023263 0ustar patrickpatrick## Domain Registry Interface, EPP .US Contact NEXUS Extensions ## ## Copyright (c) 2005,2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::US::Contact; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::US::Contact - .US EPP Contact NEXUS Extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], create => [ \&create, undef ], update => [ \&update, undef ], ); return { 'contact' => \%tmp }; } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $contact=$rinfo->{contact}->{$oname}->{self}; my $ext=$mes->node_extension(); return unless (defined($ext) && $ext && $ext->getFirstChild()); my %tmp=map { split(/=/,$_) } split(/\s+/,$ext->getFirstChild()->getData()); $contact->application_purpose($tmp{AppPurpose}) if exists($tmp{AppPurpose}); $contact->nexus_category($tmp{NexusCategory}) if exists($tmp{NexusCategory}); } ############ Transform commands sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); return unless Net::DRI::Util::isa_contact($contact,'Net::DRI::Data::Contact::US'); my $str=sprintf('AppPurpose=%s NexusCategory=%s',$contact->application_purpose(),$contact->nexus_category()); my $eid=$mes->command_extension_register('neulevel:extension','xmlns:neulevel="urn:ietf:params:xml:ns:neulevel-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:neulevel-1.0 neulevel-1.0.xsd"'); $mes->command_extension($eid,['neulevel:unspec',$str]); } sub update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); my $newc=$todo->set('info'); return unless Net::DRI::Util::isa_contact($newc,'Net::DRI::Data::Contact::US'); my @tmp; push @tmp,'AppPurpose='.$newc->application_purpose() if (defined($newc->application_purpose())); push @tmp,'NexusCategory='.$newc->nexus_category() if (defined($newc->nexus_category())); return unless @tmp; my $eid=$mes->command_extension_register('neulevel:extension','xmlns:neulevel="urn:ietf:params:xml:ns:neulevel-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:neulevel-1.0 neulevel-1.0.xsd"'); $mes->command_extension($eid,['neulevel:unspec',join(' ',@tmp)]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Afilias.pm0000644000175000017500000000407411352534377022711 0ustar patrickpatrick## Domain Registry Interface, Afilias EPP extensions ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Afilias; use strict; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Afilias - Afilias (.ORG & various ccTLDs) EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub default_extensions { return qw/Afilias::IDNLanguage Afilias::Restore GracePeriod/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/MOBI.pm0000644000175000017500000000413311352534377022063 0ustar patrickpatrick## Domain Registry Interface, .MOBI EPP extensions ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::MOBI; use strict; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::MOBI - .MOBI EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({mobi => ['urn:afilias:params:xml:ns:ext:mobi-1.0','mobi-1.0.xsd']}); $self->capabilities('domain_update','maintainer_url',['set']); return; } sub default_extensions { return qw/MOBI::Domain/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/COOP.pm0000644000175000017500000000435111352534377022077 0ustar patrickpatrick## Domain Registry Interface, .COOP EPP extensions ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::COOP; use strict; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::COOP; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::COOP - .COOP EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ coop => ['http://www.nic.coop/contactCoopExt-1.0','contactCoopExt-1.0.xsd'] }); ## fake XSD $self->capabilities('contact_update','sponsor',['add','del']); $self->factories('contact',sub { return Net::DRI::Data::Contact::COOP->new() }); return; } sub default_extensions { return qw/COOP::Contact/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/DNSBE/0002755000175000017500000000000011352534417021626 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/DNSBE/Contact.pm0000644000175000017500000000775611352534377023601 0ustar patrickpatrick## Domain Registry Interface, DNSBE Contact EPP extension commands ## (based on Registration_guidelines_v4_7_2-Part_4-epp.pdf) ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::DNSBE::Contact; use strict; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::DNSBE::Contact - DNSBE EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ undef, \&info_parse ], ); return { 'contact' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:dnsbe="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('dnsbe'))); } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); ## validate() has been called, we are sure that type & lang exists my @n; push @n,['dnsbe:type',($contact->type() eq 'registrant')? 'licensee' : $contact->type()]; push @n,['dnsbe:vat',$contact->vat()] if $contact->vat(); push @n,['dnsbe:lang',$contact->lang()]; my $eid=build_command_extension($mes,$epp,'dnsbe:ext'); $mes->command_extension($eid,['dnsbe:create',['dnsbe:contact',@n]]); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $newc=$todo->set('info'); return unless ($newc && (defined($newc->vat()) || defined($newc->lang()))); my @n; push @n,['dnsbe:vat',$newc->vat()] if defined($newc->vat()); push @n,['dnsbe:lang',$newc->lang()] if defined($newc->lang()); my $eid=build_command_extension($mes,$epp,'dnsbe:ext'); $mes->command_extension($eid,['dnsbe:update',['dnsbe:contact',['dnsbe:chg',@n]]]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('dnsbe','infData'); return unless $infdata; my $s=$rinfo->{contact}->{$oname}->{self}; my $el=$infdata->getChildrenByTagNameNS($mes->ns('dnsbe'),'type'); $s->type($el->get_node(1)->getFirstChild()->getData()); $el=$infdata->getChildrenByTagNameNS($mes->ns('dnsbe'),'vat'); $s->vat($el->get_node(1)->getFirstChild()->getData()) if defined($el->get_node(1)); $el=$infdata->getChildrenByTagNameNS($mes->ns('dnsbe'),'lang'); $s->lang($el->get_node(1)->getFirstChild()->getData()); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/DNSBE/Domain.pm0000644000175000017500000002105611352534377023402 0ustar patrickpatrick## Domain Registry Interface, DNSBE Domain EPP extension commands ## (based on Registration_guidelines_v4_7_2-Part_4-epp.pdf) ## ## Copyright (c) 2006-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::DNSBE::Domain; use strict; use warnings; use Carp; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::Hosts; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::DNSBE::Domain - DNSBE EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ undef, \&info_parse ], delete => [ \&delete, undef ], transfer_request => [ \&transfer_request, undef ], undelete => [ \&undelete, undef ], transferq_request => [ \&transferq_request, undef ], trade => [ \&trade, undef ], reactivate => [ \&reactivate, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:dnsbe="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('dnsbe'))); } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); ## Registrant contact is mandatory (optional in EPP), already added in Core, we just verify here Net::DRI::Exception->die(0,'protocol/EPP',11,'Registrant contact is mandatory in domain_create') unless (Net::DRI::Util::has_contact($rd) && $rd->{contact}->get('registrant')->srid()); return unless exists($rd->{nsgroup}); my @n=add_nsgroup($rd->{nsgroup}); my $eid=build_command_extension($mes,$epp,'dnsbe:ext'); $mes->command_extension($eid,['dnsbe:create',['dnsbe:domain',@n]]); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); if (grep { ! /^(?:add|del)$/ } $todo->types('nsgroup')) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only nsgroup add/del available for domain'); } my $nsgadd=$todo->add('nsgroup'); my $nsgdel=$todo->del('nsgroup'); return unless ($nsgadd || $nsgdel); my @n; push @n,['dnsbe:add',add_nsgroup($nsgadd)] if $nsgadd; push @n,['dnsbe:rem',add_nsgroup($nsgdel)] if $nsgdel; my $eid=build_command_extension($mes,$epp,'dnsbe:ext'); $mes->command_extension($eid,['dnsbe:update',['dnsbe:domain',@n]]); } ## This is not written in the PDF document, but it should probably be there, like for .EU sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('dnsbe','infData'); return unless $infdata; my @c; foreach my $el ($infdata->getChildrenByTagNameNS($mes->ns('dnsbe'),'nsgroup')) { push @c,Net::DRI::Data::Hosts->new()->name($el->getFirstChild()->getData()); } $rinfo->{domain}->{$oname}->{nsgroup}=\@c; } sub delete { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless (exists($rd->{deleteDate}) && $rd->{deleteDate}); Net::DRI::Util::check_isa($rd->{deleteDate},'DateTime'); my $eid=build_command_extension($mes,$epp,'dnsbe:ext'); my @n=('dnsbe:delete',['dnsbe:domain',['dnsbe:deleteDate',$rd->{deleteDate}->set_time_zone('UTC')->strftime("%Y-%m-%dT%T.%NZ")]]); $mes->command_extension($eid,\@n); } sub transfer_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @n=add_transfer($epp,$mes,$domain,$rd); my $eid=build_command_extension($mes,$epp,'dnsbe:ext'); $mes->command_extension($eid,['dnsbe:transfer',['dnsbe:domain',@n]]); } sub add_transfer { my ($epp,$mes,$domain,$rd)=@_; Net::DRI::Exception::usererr_insufficient_parameters('registrant and billing are mandatory') unless (Net::DRI::Util::has_contact($rd) && $rd->{contact}->has_type('registrant') && $rd->{contact}->has_type('billing')); my $cs=$rd->{contact}; my @n; my $creg=$cs->get('registrant'); Net::DRI::Exception::usererr_invalid_parameters('registrant must be a contact object or #AUTO#') unless (Net::DRI::Util::isa_contact($creg,'Net::DRI::Data::Contact::BE') || (!ref($creg) && ($creg eq '#AUTO#'))); push @n,['dnsbe:registrant',ref($creg)? $creg->srid() : '#AUTO#' ]; if (exists($rd->{trDate})) { Net::DRI::Util::check_isa($rd->{trDate},'DateTime'); push @n,['dnsbe:trDate',$rd->{trDate}->set_time_zone('UTC')->strftime('%Y-%m-%dT%T.%NZ')]; } my $cbill=$cs->get('billing'); Net::DRI::Exception::usererr_invalid_parameters('billing must be a contact object') unless Net::DRI::Util::isa_contact($cbill,'Net::DRI::Data::Contact::BE'); push @n,['dnsbe:billing',$cbill->srid()]; push @n,add_contact('accmgr',$cs,1) if $cs->has_type('accmgr'); push @n,add_contact('tech',$cs,9) if $cs->has_type('tech'); push @n,add_contact('onsite',$cs,5) if $cs->has_type('onsite'); if (Net::DRI::Util::has_ns($rd)) { my $n=Net::DRI::Protocol::EPP::Util::build_ns($epp,$rd->{ns},$domain,'dnsbe'); my @ns=$mes->nsattrs('domain'); push @$n,{'xmlns:domain'=>shift(@ns),'xsi:schemaLocation'=>sprintf('%s %s',@ns)}; push @n,$n; } push @n,add_nsgroup($rd->{nsgroup}) if (exists($rd->{nsgroup})); return @n; } sub add_nsgroup { my ($nsg)=@_; return unless (defined($nsg) && $nsg); my @a=grep { defined($_) && $_ && !ref($_) && Net::DRI::Util::xml_is_normalizedstring($_,1,100) } map { Net::DRI::Util::isa_hosts($_)? $_->name() : $_ } (ref($nsg) eq 'ARRAY')? @$nsg : ($nsg); return map { ['dnsbe:nsgroup',$_] } grep {defined} @a[0..8]; } sub add_contact { my ($type,$cs,$max)=@_; $max--; my @r=grep { Net::DRI::Util::isa_contact($_,'Net::DRI::Data::Contact::BE') } ($cs->get($type)); return map { ['dnsbe:'.$type,$_->srid()] } grep {defined} @r[0..$max]; } sub undelete { my ($epp,$domain)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'undelete',$domain); $mes->command_body(\@d); } sub transferq_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transferq',{'op'=>'request'}],$domain); Carp::croak('Key "period" should be key "duration"') if Net::DRI::Util::has_key($rd,'period'); push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{period}) if Net::DRI::Util::has_duration($rd); $mes->command_body(\@d); my @n=add_transfer($epp,$mes,$domain,$rd); my $eid=build_command_extension($mes,$epp,'dnsbe:ext'); $mes->command_extension($eid,['dnsbe:transferq',['dnsbe:domain',@n]]); } sub trade { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['trade',{'op'=>'request'}],$domain); $mes->command_body(\@d); my @n=add_transfer($epp,$mes,$domain,$rd); my $eid=build_command_extension($mes,$epp,'dnsbe:ext'); $mes->command_extension($eid,['dnsbe:trade',['dnsbe:domain',@n]]); } sub reactivate { my ($epp,$domain)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'reactivate',$domain); $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/DNSBE/Message.pm0000644000175000017500000000442211352534377023555 0ustar patrickpatrick## Domain Registry Interface, EPP Message for DNSBE ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::DNSBE::Message; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP::Message/; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::DNSBE::Message - DNSBE EPP Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub parse { my $self=shift; $self->SUPER::parse(@_); ## Parse dnsbe:ext my $result=$self->get_extension('dnsbe','result'); return unless $result; ## We add it to the latest status extra_info seen. foreach my $el ($result->getChildrenByTagNameNS($self->ns('dnsbe'),'msg')) { $self->add_to_extra_info({from => 'dnsbe', type => 'text', message => $el->textContent()}); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AU.pm0000644000175000017500000000441111352534377021641 0ustar patrickpatrick## Domain Registry Interface, .AU EPP extensions ## ## Copyright (c) 2007,2008,2009 Distribute.IT Pty Ltd, www.distributeit.com.au, Rony Meyer . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AU; use strict; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AU - .AU EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Rony Meyer, Eperl@spot-light.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Distribute.IT Pty Ltd, Ehttp://www.distributeit.com.auE, Rony Meyer . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({auext => ['urn:au:params:xml:ns:auext-1.0','auext-1.0.xsd'], auextnew=> ['urn:X-au:params:xml:ns:auext-1.1','auext-1.1.xsd'], }); $self->capabilities('domain_update','maintainer_url',['set']); return; } sub default_extensions { return qw/AU::Domain/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/COOP/0002755000175000017500000000000011352534417021533 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/COOP/Contact.pm0000644000175000017500000001326011352534377023471 0ustar patrickpatrick## Domain Registry Interface, .COOP Contact EPP extension commands ## (based on document: EPP Extensions for the .coop TLD Registrant Verification version 1.6) ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::EPP::Extensions::COOP::Contact; use strict; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::COOP::Contact - .COOP EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp1=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ undef, \&info_parse ], ); my %tmp2=( create => [ \&domain_create, \&domain_parse ], update => [ undef, \&domain_parse ], ); return { 'contact' => \%tmp1, 'domain' => \%tmp2 }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:coop="%s"',$mes->nsattrs('coop'))); } sub build_sponsors { my $s=shift; return map { ['coop:sponsor',$_] } (ref($s)? @$s : $s); } sub build_prefs { my $contact=shift; my @n; push @n,['coop:langPref',$contact->lang()] if $contact->lang(); push @n,['coop:mailingListPref',$contact->mailing_list()] if $contact->mailing_list(); return @n; } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); ## validate() has been called my @n; push @n,build_prefs($contact); push @n,build_sponsors($contact->sponsors()) if $contact->sponsors(); return unless @n; my $eid=build_command_extension($mes,$epp,'coop:create'); $mes->command_extension($eid,\@n); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my @n; push @n,['coop:add',build_sponsors($todo->add('sponsor'))] if $todo->add('sponsor'); push @n,['coop:rem',build_sponsors($todo->del('sponsor'))] if $todo->del('sponsor'); my @nn=build_prefs($todo->set('info')); push @n,['coop:chg',\@nn] if @nn; return unless @n; my $eid=build_command_extension($mes,$epp,'coop:update'); $mes->command_extension($eid,\@n); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('coop','infData'); return unless $infdata; my $s=$rinfo->{contact}->{$oname}->{self}; my $ns=$mes->ns('coop'); my $el=$infdata->getChildrenByTagNameNS($ns,'state'); $s->state($el->get_node(1)->getAttribute('code')) if defined($el->get_node(1)); my @s=map { $_->getFirstChild()->getData() } $infdata->getChildrenByTagNameNS($ns,'sponsor'); $s->sponsors(\@s) if @s; $el=$infdata->getChildrenByTagNameNS($ns,'langPref'); $s->lang($el->get_node(1)->getFirstChild()->getData()) if defined($el->get_node(1)); $el=$infdata->getChildrenByTagNameNS($ns,'mailingListPref'); $s->mailing_list($el->get_node(1)->getFirstChild()->getData()) if defined($el->get_node(1)); } #################################################################################################### sub domain_create { my ($epp,$domain,$rd)=@_; Net::DRI::Exception::usererr_insufficient_parameters('registrant is mandatory') unless (Net::DRI::Util::has_contact($rd) && $rd->{contact}->get('registrant')); Net::DRI::Exception::usererr_insufficient_parameters('registrant org is mandatory') unless $rd->{contact}->get('registrant')->org(); } sub domain_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $data=$mes->get_extension('coop','stateChange'); return unless $data; my $id=$data->getChildrenByTagNameNS($mes->ns('coop'),'id')->get_node(1)->getFirstChild()->getData(); $rinfo->{contact}->{$id}->{state}=$data->getChildrenByTagNameNS($mes->ns('coop'),'state')->get_node(1)->getAttribute('code'); $rinfo->{contact}->{$id}->{action}='verification_review'; if (defined($otype) && ($otype eq 'domain') && defined($oaction) && ($oaction eq 'create' || $oaction eq 'update')) { $rinfo->{domain}->{$oname}->{registrant_id}=$id; $rinfo->{domain}->{$oname}->{registrant_state}=$rinfo->{contact}->{$id}->{state}; } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PRO/0002755000175000017500000000000011352534417021433 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PRO/Domain.pm0000644000175000017500000001242011352534377023202 0ustar patrickpatrick## Domain Registry Interface, .PRO domain extensions ## ## Copyright (c) 2008 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::PRO::Domain; use strict; use Net::DRI::Util; use DateTime::Format::ISO8601; our $VERSION=do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::PRO::Domain - .PRO EPP domain extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bdsprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE, Alexander Biehl, Einfo@hexonet.netE, HEXONET Support GmbH, Ehttp://www.hexonet.net/E. =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&add_pro_extinfo ], update => [ \&add_pro_extinfo ], info => [ undef, \&parse ] ); return { 'domain' => \%tmp }; } #################################################################################################### ############ Transform commands sub add_pro_extinfo { my ($epp, $domain, $rd) = @_; my $mes = $epp->message(); my @prodata; my @tmdata; my $pw; $rd = +{ pro => $rd->set('pro') } if Net::DRI::Util::isa_changes($rd); return unless (Net::DRI::Util::has_key($rd,'pro') && (ref($rd->{pro}) eq 'HASH')); my $ph = $rd->{pro}; push(@prodata, ['rpro:tradeMarkName', $ph->{tmname}]) if (exists($ph->{tmname})); push(@prodata, ['rpro:tradeMarkJurisdiction', $ph->{tmjurisdiction}]) if (exists($ph->{tmjurisdiction})); push(@prodata, ['rpro:tradeMarkDate', $ph->{tmdate}->strftime('%Y-%m-%dT%H:%M:%S.%1NZ')]) if (exists($ph->{tmdate}) && UNIVERSAL::isa($ph->{tmdate}, 'DateTime')); push(@prodata, ['rpro:tradeMarkNumber', int($ph->{tmnumber})]) if (exists($ph->{tmnumber}) && int($ph->{tmnumber})); push(@prodata, ['rpro:registrationType', (exists($ph->{activate}) && $ph->{activate} ? +{ activate => 'y' } : +{}), $ph->{type}]) if (exists($ph->{type})); push(@prodata, ['rpro:redirectTarget', $ph->{redirect}]) if (exists($ph->{redirect}) && Net::DRI::Util::is_hostname($ph->{redirect})); push(@prodata, ['rpro:tradeMark', @tmdata]) if (@tmdata); if (Net::DRI::Util::has_auth($ph) && exists($ph->{auth}->{pw})) { $pw = $ph->{auth}->{pw}; delete($ph->{auth}->{pw}); } push(@prodata, ['rpro:authorization', $ph->{auth}, $pw]) if (exists($ph->{auth})); return unless (@prodata); my $eid = $mes->command_extension_register('rpro:proDomain',sprintf('xmlns:rpro="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('rpro'))); $mes->command_extension($eid, [@prodata]); } sub parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); my $infdata = $mes->get_extension('rpro','proDomain'); my $pro = {}; my $c; return unless ($infdata); my $pd = DateTime::Format::ISO8601->new(); $c = $infdata->getFirstChild(); while (defined($c) && $c) { my $name = $c->localname() || $c->nodeName(); next unless $name; if ($name eq 'registrationType') { $pro->{type} = $c->getFirstChild()->getData(); } elsif ($name eq 'redirectTarget') { $pro->{redirect} = $c->getFirstChild()->getData(); } elsif ($name eq 'tradeMark') { my $to = $c->getFirstChild(); while (defined($to) && $to) { my $totag = $to->localname() || $to->nodeName(); next unless ($totag); if ($totag eq 'tradeMarkName') { $pro->{tmname} = $to->getFirstChild()->getData(); } elsif ($totag eq 'tradeMarkJurisdiction') { $pro->{tmjurisdiction} = $to->getFirstChild()->getData(); } elsif ($totag eq 'tradeMarkDate') { $pro->{tmdate} = $pd->parse_datetime( $to->getFirstChild()->getData()); } elsif ($totag eq 'tradeMarkNumber') { $pro->{tmnumber} = int($to->getFirstChild()-> getData()); } } continue { $to=$to->getNextSibling(); } } } continue { $c=$c->getNextSibling(); } $rinfo->{$otype}->{$oname}->{pro} = $pro; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PRO/AV.pm0000644000175000017500000002122511352534377022304 0ustar patrickpatrick## Domain Registry Interface, .PRO A/V extensions ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::PRO::AV; use strict; use Net::DRI::Util; use Net::DRI::Exception; use DateTime::Format::ISO8601; our $VERSION=do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::PRO::AV - .PRO EPP A/V extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bdsprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE, Alexander Biehl, Einfo@hexonet.netE, HEXONET Support GmbH, Ehttp://www.hexonet.net/E. =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class, $version) = @_; my %avcmds = ( create => [ \&create, \&create_parse ], check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], ); return { 'av' => \%avcmds }; } #################################################################################################### ############ Query commands sub build_command { my ($msg, $command, $domain, $domainattr) = @_; my @dom = (ref($domain) ? @$domain : ($domain)); Net::DRI::Exception->die(1, 'protocol/EPP', 2, 'Domain name needed') unless @dom; foreach my $d (@dom) { Net::DRI::Exception->die(1, 'protocol/EPP', 2, 'Domain name needed') unless (defined($d) && $d); Net::DRI::Exception->die(1, 'protocol/EPP', 10, 'Invalid domain name: ' . $d) unless Net::DRI::Util::is_hostname($d); } my $tcommand = (ref($command) ? $command->[0] : $command); $msg->command([$command, 'av:' . $tcommand,sprintf('xmlns:av="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('av'))]); return map { ['av:id', $_, $domainattr] } @dom; } sub check { my ($epp, $av, $rd) = @_; my $mes = $epp->message(); my @d = build_command($mes, 'check', $av); $mes->command_body(\@d); } sub check_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless ($mes->is_success()); my $chkdata = $mes->get_response('av','chkData'); return unless $chkdata; my $cd = $chkdata->getFirstChild(); while (defined($cd) && $cd) { my $cdn; my $avid; my $c; next unless ($cd->nodeType() == 1); ## only for element nodes $cdn = $cd->localname() || $cd->nodeName(); $c = $cd->getFirstChild(); while (defined($c) && $c) { ## only for element nodes next unless ($c->nodeType() == 1); my $n = $c->localname() || $c->nodeName(); if ($n eq 'id') { $avid = $c->getFirstChild()->getData(); $rinfo->{av}->{$avid}->{action} = 'check'; $rinfo->{av}->{$avid}->{exist} = 1 - Net::DRI::Util::xml_parse_boolean($c->getAttribute('avail')); } elsif ($n eq 'reason') { $rinfo->{av}->{$avid}->{exist_reason} = $c->getFirstChild()->getData(); } } continue { $c = $c->getNextSibling(); } } continue { $cd = $cd->getNextSibling(); } } sub info { my ($epp, $av, $rd) = @_; my $mes = $epp->message(); my @d = build_command($mes, 'info', $av); $mes->command_body(\@d); } sub info_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); my $ns = $mes->ns('av'); my $infdata; my $avid; my $cd; my $pd; return unless ($mes->is_success()); $infdata = $mes->get_response('av','infData'); return unless $infdata; $cd = $infdata->getFirstChild(); $pd = DateTime::Format::ISO8601->new(); while (defined($cd) && $cd) { next unless ($cd->nodeType() == 1); ## only for element nodes my $cdn = $cd->localname() || $cd->nodeName(); if ($cdn eq 'id') { $avid = $cd->getFirstChild()->getData(); $rinfo->{av}->{$avid}->{id} = $avid; $rinfo->{av}->{$avid}->{action} = 'info'; } elsif ($cdn =~ /^(?:avurl|roid|host)$/i) { $rinfo->{av}->{$avid}->{lc($cdn)} = $cd->getFirstChild()->getData(); } elsif (lc($cdn) eq 'checktype') { $rinfo->{av}->{$avid}->{type} = $cd->getFirstChild()->getData(); } elsif ($cdn =~ /^(?:c[lr]|up)id$/i) { $cdn = lc($cdn); $cdn =~ s/id$/ID/; $rinfo->{av}->{$avid}->{$cdn} = $cd->getFirstChild()->getData(); } elsif ($cdn =~ /^(?:c[lr]|up)date$/i) { $cdn = lc($cdn); $cdn =~ s/date$/Date/; $rinfo->{av}->{$avid}->{$cdn} = $pd->parse_datetime( $cd->getFirstChild()->getData()); } elsif (lc($cdn) eq 'contactid') { my $c = $po->create_local_object('contact'); $c->srid($cd->getFirstChild()->getData()); $rinfo->{av}->{$avid}->{contact} = $c; } elsif (lc($cdn) eq 'avresult') { my $res = +{}; my $c = $cd->getFirstChild(); while (defined($c) && $c) { ## only for element nodes next unless ($c->nodeType() == 1); my $name = $c->localname() || $c->nodeName(); next unless ($name); if (lc($name) eq 'avcheckid') { $res->{checkid} = $c->getFirstChild()->getData(); } elsif (lc($name) eq 'personalavdatafingerprint') { $res->{persfingerprint} = $c->getFirstChild()->getData(); } elsif (lc($name) eq 'professionalavdatafingerprint') { $res->{proffingerprint} = $c->getFirstChild()->getData(); } elsif (lc($name) eq 'professionalavdatafingerprint') { $res->{proffingerprint} = $c->getFirstChild()->getData(); } elsif ($name =~ /^(?:oobmethodid|profession|jurisdiction|status)$/i) { $res->{lc($name)} = $c->getFirstChild()->getData(); } elsif (lc($name) eq 'resultdata') { my $inf = $c->getElementsByTagNameNS($ns, 'result'); $res->{avresult} = $inf->shift()->getFirstChild()->getData() if ($inf); $inf = $c->getElementsByTagNameNS($ns, 'date'); $res->{avDate} = $pd->parse_datetime($inf->shift()->getFirstChild()->getData()) if ($inf); } } continue { $c = $c->getNextSibling(); } $rinfo->{av}->{$avid}->{avresult} = $res; } } continue { $cd = $cd->getNextSibling(); } } #################################################################################################### ############ Transform commands sub create { my ($epp, $av, $rd) = @_; my $mes = $epp->message(); my @d = build_command($mes, 'create', $av); push(@d, ['av:checkType', $rd->{type}]) if Net::DRI::Util::has_key($rd, 'type'); push(@d, ['av:host', $rd->{host}]) if Net::DRI::Util::has_key($rd, 'host'); push(@d, ['av:contact', ['av:contactId', $rd->{contact}->srid()]]) if (Net::DRI::Util::has_key($rd,'contact') && Net::DRI::Util::isa_contact($rd->{contact})); $mes->command_body(\@d); } sub create_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); my $avid; return unless ($mes->is_success()); my $credata = $mes->get_response('av','creData'); return unless $credata; my $cd = $credata->getFirstChild(); my $pd = DateTime::Format::ISO8601->new(); while (defined($cd) && $cd) { next unless ($cd->nodeType() == 1); ## only for element nodes my $cdn = $cd->localname() || $cd->nodeName(); if ($cdn eq 'id') { $avid = $cd->getFirstChild()->getData(); $rinfo->{av}->{$avid}->{id} = $avid; $rinfo->{av}->{$avid}->{action} = 'create'; } elsif ($cdn =~ /^(avurl|roid)$/i) { $rinfo->{av}->{$avid}->{lc($cdn)} = $cd->getFirstChild()->getData(); } elsif (lc($cdn) eq 'crdate') { $rinfo->{av}->{$avid}->{crDate} = $pd->parse_datetime( $cd->getFirstChild()->getData()); } } continue { $cd = $cd->getNextSibling(); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/IENUMAT.pm0000644000175000017500000000405211352534377022437 0ustar patrickpatrick## Domain Registry Interface, Infrastructure ENUM .AT EPP extensions ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::EPP::Extensions::IENUMAT; use strict; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::IENUMAT - Infrastructure ENUM .AT EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->default_parameters()->{rfc4114_relax}=1; return; } sub default_extensions { return qw/AT::Result AT::IOptions E164/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Afilias/0002755000175000017500000000000011352534417022343 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Afilias/Restore.pm0000644000175000017500000000505111352534377024330 0ustar patrickpatrick## Domain Registry Interface, Afilias EPP Renew Redemption Period Extension ## ## Copyright (c) 2008 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Afilias::Restore; use strict; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Afilias::Restore - EPP renew redemption period support for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class, $version) = @_; my %tmp = ( renew => [ \&renew, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### ############ Transform commands sub renew { my ($epp, $domain, $rd) = @_; my $mes = $epp->message(); return unless Net::DRI::Util::has_key($rd,'rgp'); my $eid = $mes->command_extension_register('rgp:renew', 'xmlns:rgp="urn:EPP:xml:ns:ext:rgp-1.0" xsi:schemaLocation="urn:EPP:xml:ns:ext:rgp-1.0 rgp-1.0.xsd"'); $mes->command_extension($eid, ['rgp:restore']); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Afilias/IDNLanguage.pm0000644000175000017500000000563311352534377024771 0ustar patrickpatrick## Domain Registry Interface, EPP IDN Language (EPP-IDN-Lang-Mapping.pdf) ## ## Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Afilias::IDNLanguage; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Afilias::IDNLanguage - Afilias EPP IDN Language commands (EPP-IDN-Lang-Mapping.pdf) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bdsprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], check => [ \&check, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub add_language { my ($tag,$epp,$domain,$rd)=@_; my $mes=$epp->message(); if (Net::DRI::Util::has_key($rd,'language')) { Net::DRI::Exception::usererr_invalid_parameters('IDN language tag must be of type XML schema language') unless Net::DRI::Util::xml_is_language($rd->{language}); my $eid=$mes->command_extension_register($tag,'xmlns:idn="urn:iana:xml:ns:idn" xsi:schemaLocation="urn:iana:xml:ns:idn idn.xsd"'); $mes->command_extension($eid,['idn:script', $rd->{language}]); } } sub create { return add_language('idn:create',@_); } sub check { return add_language('idn:check',@_); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CAT.pm0000644000175000017500000000547611352534377021757 0ustar patrickpatrick## Domain Registry Interface, .CAT EPP extensions ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CAT; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CAT - .CAT EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ puntcat_contact => ['http://xmlns.domini.cat/epp/contact-ext-1.0','puntcat-contact-ext-1.0.xsd'], puntcat_domain => ['http://xmlns.domini.cat/epp/domain-ext-1.0','puntcat-domain-ext-1.0.xsd'], puntcat_defreg => ['http://xmlns.domini.cat/epp/defreg-1.0','puntcat-defreg-1.0.xsd'], }); $self->capabilities('host_update','name',undef); $self->capabilities('domain_update','name_variant',['add','del']); $self->capabilities('domain_update','lang',['set']); $self->capabilities('domain_update','maintainer',['set']); $self->capabilities('domain_update','intended_use',['set']); foreach my $o (qw/status contact/) { $self->capabilities('defreg_update',$o,['add','del']); } foreach my $o (qw/registrant auth maintainer trademark/) { $self->capabilities('defreg_update',$o,['set']); } return; } sub default_extensions { return qw/CAT::Domain CAT::Contact CAT::DefensiveRegistration/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/ASIA/0002755000175000017500000000000011352534417021510 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/ASIA/CED.pm0000644000175000017500000002241711352534377022452 0ustar patrickpatrick## Domain Registry Interface, ASIA CED extension ## ## Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::ASIA::CED; use strict; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::ASIA::CED - .ASIA EPP CED extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bdsprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %domtmp=( create => [ \&dom_create, undef ], update => [ \&dom_update, undef ], info => [ undef, \&dom_parse ] ); my %contacttmp=( create => [ \&user_create, undef ], update => [ \&user_update, undef ], info => [ undef, \&user_info ] ); return { 'domain' => \%domtmp, 'contact' => \%contacttmp }; } #################################################################################################### ############ Transform commands sub dom_create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $cs = $rd->{contact}; my @ceddata; if (defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{url})) { push(@ceddata, ['asia:maintainerUrl', $rd->{url}]); } if (defined($cs)) { foreach my $type ($cs->types()) { # Skip standard types and registration agent next if (grep { $_ eq $type } qw(registrant admin tech billing regAgent)); foreach my $c ($cs->get($type)) { push(@ceddata, ['asia:contact', {type => $type}, $c->srid()]); } } } if (@ceddata) { my $eid=$mes->command_extension_register('asia:create',sprintf('xmlns:asia="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('asia'))); $mes->command_extension($eid,[@ceddata]); } } sub dom_update { my ($epp, $domain, $todo) = @_; my $mes = $epp->message(); my $url = $todo->set('url'); my $cs = $todo->set('contact'); my @ceddata; push(@ceddata, ['asia:maintainerUrl', $url]) if (defined($url)); if (defined($cs)) { foreach my $type ($cs->types()) { # Skip standard types next if (grep { $_ eq $type } qw(registrant admin tech billing)); foreach my $c ($cs->get($type)) { push(@ceddata, ['asia:contact', {type => $type}, $c->srid()]); } } } if (@ceddata) { my $eid=$mes->command_extension_register('asia:create',sprintf('xmlns:asia="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('asia'))); $mes->command_extension($eid, ['asia:chg', @ceddata]); } } sub dom_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); my $ceddata=$mes->get_extension('asia','infData'); my $cs = $rinfo->{$otype}->{$oname}->{contact}; my $ct; my $c; $cs = $rinfo->{$otype}->{$oname}->{contact} if (defined($otype) && defined($oname) && defined($rinfo) && defined($rinfo->{$otype}) && defined($rinfo->{$otype}->{$oname}) && defined($rinfo->{$otype}->{$oname}->{contact}));; return unless ($ceddata && $cs); $c = $ceddata->getElementsByTagNameNS($mes->ns('asia'),'maintainerUrl'); $rinfo->{$otype}->{$oname}->{url} = $c->shift()->getFirstChild()->getData() if ($c); foreach my $ct ($ceddata->getElementsByTagNameNS($mes->ns('asia'),'contact')) { my $contact = $po->create_local_object('contact'); my $type = $ct->getAttribute('type'); my $srid = $ct->getFirstChild()->getData(); $contact->srid($srid); $cs->add($contact, $type); } } sub user_create { my ($epp,$contact,$rd)=@_; my $mes=$epp->message(); my @ceddata; return unless Net::DRI::Util::isa_contact($contact, 'Net::DRI::Data::Contact::ASIA'); push(@ceddata, ['asia:ccLocality', $contact->cedcc()]) if (UNIVERSAL::can($contact, 'cedcc') && defined($contact->cedcc()) && length($contact->cedcc())); push(@ceddata, ['asia:localitySp', $contact->cedsp()]) if (UNIVERSAL::can($contact, 'cedsp') && defined($contact->cedsp()) && length($contact->cedsp())); push(@ceddata, ['asia:localityCity', $contact->cedcity()]) if (UNIVERSAL::can($contact, 'cedcity') && defined($contact->cedcity()) && length($contact->cedcity())); push(@ceddata, ['asia:legalEntityType', $contact->cedetype()]) if (UNIVERSAL::can($contact, 'cedetype') && defined($contact->cedetype()) && length($contact->cedetype())); push(@ceddata, ['asia:identForm', $contact->cediform()]) if (UNIVERSAL::can($contact, 'cediform') && defined($contact->cediform()) && length($contact->cediform())); push(@ceddata, ['asia:identNumber', $contact->cedinum()]) if (UNIVERSAL::can($contact, 'cedinum') && defined($contact->cedinum()) && length($contact->cedinum())); push(@ceddata, ['asia:otherLEType', $contact->cedothertype()]) if (UNIVERSAL::can($contact, 'cedothertype') && defined($contact->cedothertype()) && length($contact->cedothertype())); push(@ceddata, ['asia:otherIdentForm', $contact->cedoiform()]) if (UNIVERSAL::can($contact, 'cedoiform') && defined($contact->cedoiform()) && length($contact->cedoiform())); return unless (@ceddata); my $eid=$mes->command_extension_register('asia:create',sprintf('xmlns:asia="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('asia'))); $mes->command_extension($eid,['asia:cedData', @ceddata]); } sub user_update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); my $newc=$todo->set('info'); my @ceddata; push(@ceddata, ['asia:ccLocality', $contact->cedcc()]) if (UNIVERSAL::can($contact, 'cedcc') && defined($contact->cedcc())); push(@ceddata, ['asia:localitySp', $contact->cedsp()]) if (UNIVERSAL::can($contact, 'cedsp') && defined($contact->cedsp())); push(@ceddata, ['asia:localityCity', $contact->cedcity()]) if (UNIVERSAL::can($contact, 'cedcity') && defined($contact->cedcity())); push(@ceddata, ['asia:legalEntityType', $contact->cedetype()]) if (UNIVERSAL::can($contact, 'cedetype') && defined($contact->cedetype())); push(@ceddata, ['asia:identForm', $contact->cediform()]) if (UNIVERSAL::can($contact, 'cediform') && defined($contact->cediform())); push(@ceddata, ['asia:identNumber', $contact->cedinum()]) if (UNIVERSAL::can($contact, 'cedinum') && defined($contact->cedinum())); push(@ceddata, ['asia:otherLEType', $contact->cedothertype()]) if (UNIVERSAL::can($contact, 'cedothertype') && defined($contact->cedothertype())); push(@ceddata, ['asia:otherIdentForm', $contact->cedoiform()]) if (UNIVERSAL::can($contact, 'cedoiform') && defined($contact->cedoiform())); return unless (@ceddata); my $eid=$mes->command_extension_register('asia:update',sprintf('xmlns:asia="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('asia'))); $mes->command_extension($eid,['asia:chg', ['asia:cedData', @ceddata]]); } sub user_info { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); my $infdata=$mes->get_extension('asia','infData'); my $ceddata; my $contact = $rinfo->{$otype}->{$oname}->{self}; my $c; my $ns=$mes->ns('asia'); $ceddata = $infdata->getElementsByTagNameNS($ns, 'cedData')->shift() if (defined($infdata)); return unless ($ceddata); $c = $ceddata->getElementsByTagNameNS($ns,'ccLocality'); $contact->cedcc($c->shift()->getFirstChild()->getData()) if ($c); $c = $ceddata->getElementsByTagNameNS($ns,'localitySp'); $contact->cedsp($c->shift()->getFirstChild()->getData()) if ($c); $c = $ceddata->getElementsByTagNameNS($ns,'localityCity'); $contact->cedcity($c->shift()->getFirstChild()->getData()) if ($c); $c = $ceddata->getElementsByTagNameNS($ns,'legalEntityType'); $contact->cedetype($c->shift()->getFirstChild()->getData()) if ($c); $c = $ceddata->getElementsByTagNameNS($ns,'identForm'); $contact->cediform($c->shift()->getFirstChild()->getData()) if ($c); $c = $ceddata->getElementsByTagNameNS($ns,'identNumber'); $contact->cedinum($c->shift()->getFirstChild()->getData()) if ($c); $c = $ceddata->getElementsByTagNameNS($ns,'otherLEType'); $contact->cedothertype($c->shift()->getFirstChild()->getData()) if ($c); $c = $ceddata->getElementsByTagNameNS($ns,'otherIdentForm'); $contact->cedoiform($c->shift()->getFirstChild()->getData()) if ($c); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/ASIA/IPR.pm0000644000175000017500000001272311352534377022510 0ustar patrickpatrick## Domain Registry Interface, ASIA IPR extension ## ## Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::ASIA::IPR; use strict; use DateTime::Format::ISO8601; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::ASIA::IPR - .ASIA EPP IPR extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bdsprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, \&create_parse ], info => [ undef, \&parse ] ); return { 'domain' => \%tmp }; } #################################################################################################### ############ Transform commands sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); if (defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{ipr})) { my @iprdata; push(@iprdata, ['ipr:name', $rd->{ipr}->{name}]) if (exists($rd->{ipr}->{name})); push(@iprdata, ['ipr:ccLocality', $rd->{ipr}->{cc}]) if (exists($rd->{ipr}->{cc})); push(@iprdata, ['ipr:number', $rd->{ipr}->{number}]) if (exists($rd->{ipr}->{number})); push(@iprdata, ['ipr:appDate', $rd->{ipr}->{appDate}->ymd()]) if (exists($rd->{ipr}->{appDate}) && ref($rd->{ipr}->{appDate}) eq 'DateTime'); push(@iprdata, ['ipr:regDate', $rd->{ipr}->{regDate}->ymd()]) if (exists($rd->{ipr}->{regDate}) && ref($rd->{ipr}->{regDate}) eq 'DateTime'); push(@iprdata, ['ipr:class', int($rd->{ipr}->{class})]) if (exists($rd->{ipr}->{class})); push(@iprdata, ['ipr:entitlement', $rd->{ipr}->{entitlement}]) if (exists($rd->{ipr}->{entitlement})); push(@iprdata, ['ipr:form', $rd->{ipr}->{form}]) if (exists($rd->{ipr}->{form})); push(@iprdata, ['ipr:type', $rd->{ipr}->{type}]) if (exists($rd->{ipr}->{type})); push(@iprdata, ['ipr:preVerified', $rd->{ipr}->{preVerified}]) if (exists($rd->{ipr}->{preVerified})); my $eid=$mes->command_extension_register('ipr:create',sprintf('xmlns:ipr="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('ipr'))); $mes->command_extension($eid,[@iprdata]); } } sub create_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); my $infdata = $mes->get_extension('asia','creData'); my $c; return unless ($infdata); $c = $infdata->getElementsByTagNameNS($mes->ns('asia'), 'domainRoid'); $rinfo->{$otype}->{$oname}->{roid} = $c->shift()->getFirstChild()->getData() if ($c); } sub parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); my $infdata=$mes->get_extension('ipr','infData'); my $ipr = {}; my $c; return unless ($infdata); my $pd=DateTime::Format::ISO8601->new(); my $ns=$mes->ns('ipr'); $c = $infdata->getElementsByTagNameNS($ns, 'name'); $ipr->{name} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'ccLocality'); $ipr->{cc} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'number'); $ipr->{number} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'appDate'); $ipr->{appDate} =$pd->parse_datetime ($c->shift()->getFirstChild()->getData()) if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'regDate'); $ipr->{regDate} = $pd->parse_datetime($c->shift()->getFirstChild()->getData()) if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'class'); $ipr->{class} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'entitlement'); $ipr->{entitlement} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'form'); $ipr->{form} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'preVerified'); $ipr->{preVerified} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getElementsByTagNameNS($ns, 'type'); $ipr->{type} = $c->shift()->getFirstChild()->getData() if ($c); $rinfo->{$otype}->{$oname}->{ipr} = $ipr; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/Nominet.pm0000644000175000017500000000752311352534377022754 0ustar patrickpatrick## Domain Registry Interface, .UK EPP extensions ## As seen on http://www.nominet.org.uk/registrars/systems/epp/ and http://www.nominet.org.uk/digitalAssets/16844_EPP_Mapping.pdf ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::Nominet; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::Nominet; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::Nominet - .UK EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### our @NS=qw/account-1.1 domain-2.0 contact-1.1 ns-1.1 notifications-1.2/; sub setup { my ($self,$rp)=@_; foreach my $ns (@NS) { $self->ns({ (split(/-/,$ns))[0] => ['http://www.nominet.org.uk/epp/xml/nom-'.$ns,'nom-'.$ns.'.xsd'] }); } foreach my $o (qw/ns contact first-bill recur-bill auto-bill next-bill notes/) { $self->capabilities('domain_update',$o,['set']); } $self->capabilities('contact_update','info',['set']); $self->capabilities('host_update','ip',['set']); $self->capabilities('host_update','name',['set']); $self->capabilities('account_update','contact',['set']); $self->factories('contact',sub { return Net::DRI::Data::Contact::Nominet->new(); }); $self->default_parameters({domain_create => { auth => { pw => '' } } }); ## domain:authInfo is not used by Nominet return; } sub core_contact_types { return ('admin','billing'); } ## not really used sub core_modules { my ($self,$rp)=@_; my @c=map { 'Net::DRI::Protocol::EPP::Extensions::Nominet::'.$_ } qw/Domain Contact Host Account Notifications/; push @c,'Net::DRI::Protocol::EPP::Core::Session'; push @c,'Net::DRI::Protocol::EPP::Core::RegistryMessage'; return @c; } sub transport_default { my ($self)=@_; my @p=$self->SUPER::transport_default(); push @p,(protocol_data => { login_service_filter => \&set_objuri }); return @p; } ## The registry gives back a mix of 1.0 1.1 1.2 and 1.3 versions of its namespaces and what not, see http://www.nominet.org.uk/registrars/systems/nominetepp/Namespace+URIs/ ## We previously kept only the highest seen, which does not seem a good idea ## Now we explicitely set them from what we support; this may break compatibility with registry as soon as they introduce a new version sub set_objuri { return (['objURI','urn:ietf:params:xml:ns:host-1.0'],map { ['objURI','http://www.nominet.org.uk/epp/xml/nom-'.$_] } @NS); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SecDNS.pm0000644000175000017500000001713711352534377022424 0ustar patrickpatrick## Domain Registry Interface, EPP DNS Security Extensions (RFC4310) ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SecDNS; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='urn:ietf:params:xml:ns:secDNS-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SecDNS - EPP DNS Security Extensions (RFC4310) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], create => [ \&create, undef ], update => [ \&update, undef ], ); return { 'domain' => \%tmp }; } sub capabilities_add { return (['domain_update','secdns',['add','del','set']],['domain_update','secdns_urgent',['set']]); } #################################################################################################### sub format_secdns { my $e=shift; my @mk=grep { ! Net::DRI::Util::has_key($e,$_) } qw/keyTag alg digestType digest/; Net::DRI::Exception::usererr_insufficient_parameters('Attributes missing: '.join(@mk)) if @mk; Net::DRI::Exception::usererr_invalid_parameters('keyTag must be 16-bit unsigned integer: '.$e->{keyTag}) unless Net::DRI::Util::verify_ushort($e->{keyTag}); Net::DRI::Exception::usererr_invalid_parameters('alg must be an unsigned byte: '.$e->{alg}) unless Net::DRI::Util::verify_ubyte($e->{alg}); Net::DRI::Exception::usererr_invalid_parameters('digestType must be an unsigned byte: '.$e->{digestType}) unless Net::DRI::Util::verify_ubyte($e->{digestType}); Net::DRI::Exception::usererr_invalid_parameters('digest must be hexadecimal: '.$e->{digest}) unless Net::DRI::Util::verify_hex($e->{digest}); my @c; push @c,['secDNS:keyTag',$e->{keyTag}]; push @c,['secDNS:alg',$e->{alg}]; push @c,['secDNS:digestType',$e->{digestType}]; push @c,['secDNS:digest',$e->{digest}]; if (exists($e->{maxSigLife})) { Net::DRI::Exception::usererr_invalid_parameters('maxSigLife must be a positive integer: '.$e->{maxSigLife}) unless Net::DRI::Util::verify_int($e->{maxSigLife},1); push @c,['secDNS:maxSigLife',$e->{maxSigLife}]; } if (exists($e->{key_flags}) && exists($e->{key_protocol}) && exists($e->{key_alg}) && exists($e->{key_pubKey})) { Net::DRI::Exception::usererr_invalid_parameters('key_flags mut be a 16-bit unsigned integer: '.$e->{key_flags}) unless Net::DRI::Util::verify_ushort($e->{key_flags}); Net::DRI::Exception::usererr_invalid_parameters('key_protocol must be an unsigned byte: '.$e->{key_protocol}) unless Net::DRI::Util::verify_ubyte($e->{key_protocol}); Net::DRI::Exception::usererr_invalid_parameters('key_alg must be an unsigned byte: '.$e->{key_alg}) unless Net::DRI::Util::verify_ubyte($e->{key_alg}); Net::DRI::Exception::usererr_invalid_parameters('key_pubKey must be a non empty base64 string: '.$e->{key_pubKey}) unless Net::DRI::Util::verify_base64($e->{key_pubKey},1); my @cc; push @cc,['secDNS:flags',$e->{key_flags}]; push @cc,['secDNS:protocol',$e->{key_protocol}]; push @cc,['secDNS:alg',$e->{key_alg}]; push @cc,['secDNS:pubKey',$e->{key_pubKey}]; push @c,['secDNS:keyData',@cc]; } return @c; } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension($NS,'infData'); return unless defined $infdata; my @ds; foreach my $el ($infdata->getChildrenByTagNameNS($NS,'dsData')) { my %n; foreach my $sel (Net::DRI::Util::xml_list_children($el)) { my ($name,$c)=@$sel; if ($name=~m/^(keyTag|alg|digestType|digest|maxSigLife)$/) { $n{$1}=$c->textContent(); } elsif ($name eq 'keyData') { foreach my $tel (Net::DRI::Util::xml_list_children($c)) { my ($name2,$cc)=@$tel; if ($name2=~m/^(flags|protocol|alg|pubKey)$/) { $n{'key_'.$1}=$cc->textContent(); } } } } push @ds,\%n; } $rinfo->{domain}->{$oname}->{secdns}=\@ds; } ############ Transform commands sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); ## Deactivated by suggestion of Elias Sidenbladh 2006-09 ## Net::DRI::Exception::usererr_insufficient_parameters('One or more secDNS data block must be provided') unless (exists($rd->{secdns}) && (ref($rd->{secdns}) eq 'ARRAY') && @{$rd->{secdns}}); return unless (exists($rd->{secdns}) && (ref($rd->{secdns}) eq 'ARRAY') && @{$rd->{secdns}}); my $eid=$mes->command_extension_register('secDNS:create','xmlns:secDNS="urn:ietf:params:xml:ns:secDNS-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:secDNS-1.0 secDNS-1.0.xsd"'); my @n=map { ['secDNS:dsData',format_secdns($_)] } (@{$rd->{secdns}}); $mes->command_extension($eid,\@n); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $toadd=$todo->add('secdns'); my $todel=$todo->del('secdns'); my $toset=$todo->set('secdns'); my $urgent=$todo->set('secdns_urgent'); my @def=grep { defined } ($toadd,$todel,$toset); return unless @def; ## no updates asked Net::DRI::Exception::usererr_invalid_parameters('Only add or del or chg is possible, not more than one of them') if (@def>1); my $urg=(defined($urgent) && $urgent)? 'urgent="1" ' : ''; my $eid=$mes->command_extension_register('secDNS:update',$urg.'xmlns:secDNS="urn:ietf:params:xml:ns:secDNS-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:secDNS-1.0 secDNS-1.0.xsd"'); my @n; push @n,['secDNS:add',map { ['secDNS:dsData',format_secdns($_)] } (ref($toadd) eq 'ARRAY')? @$toadd : ($toadd)] if (defined($toadd)); push @n,['secDNS:chg',map { ['secDNS:dsData',format_secdns($_)] } (ref($toset) eq 'ARRAY')? @$toset : ($toset)] if (defined($toset)); if (defined($todel)) { my @nn; foreach my $e ((ref($todel) eq 'ARRAY')? @$todel : ($todel)) { $e=$e->{keyTag} if (ref($e) eq 'HASH'); Net::DRI::Exception::usererr_invalid_parameters('keyTag must be 16-bit unsigned integer: '.$e) unless Net::DRI::Util::verify_ushort($e); push @nn,['secDNS:keyTag',$e]; } push @n,['secDNS:rem',@nn]; } $mes->command_extension($eid,\@n); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SWITCH.pm0000644000175000017500000000444611352534377022345 0ustar patrickpatrick## Domain Registry Interface, Switch .CH/.LI EPP extensions ## ## Copyright (c) 2008-2010 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SWITCH; use strict; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::SWITCH; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SWITCH - .CH/.LI EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E or Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008-2010 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->capabilities('domain_update','status',undef); $self->capabilities('contact_update','status',undef); $self->factories('contact',sub { return Net::DRI::Data::Contact::SWITCH->new(); }); return; } sub default_extensions { return qw/SecDNS/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/MOBI/0002755000175000017500000000000011352534417021521 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/MOBI/Domain.pm0000644000175000017500000000666211352534377023303 0ustar patrickpatrick## Domain Registry Interface, .MOBI Domain EPP extension commands ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::MOBI::Domain; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::MOBI::Domain - .MOBI EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ undef, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub add_maintainer_url { my ($mes,$tag,$url)=@_; my $eid=$mes->command_extension_register($tag,sprintf('xmlns:mobi="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('mobi'))); $mes->command_extension($eid,['mobi:maintainerUrl',$url]); } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless (defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{maintainer_url}) && $rd->{maintainer_url}); add_maintainer_url($mes,'mobi:create',$rd->{maintainer_url}); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); if (grep { ! /^(?:set)$/ } $todo->types('maintainer_url')) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only maintainer_url set available for domain'); } return unless $todo->set('maintainer_url'); add_maintainer_url($mes,'mobi:update',$todo->set('maintainer_url')); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('mobi','infData'); return unless $infdata; my $c=$infdata->getChildrenByTagNameNS($mes->ns('mobi'),'maintainerUrl'); return unless ($c && $c->size()==1); $rinfo->{domain}->{$oname}->{maintainer_url}=$c->shift()->getFirstChild()->getData(); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SE.pm0000644000175000017500000000456611352534377021656 0ustar patrickpatrick## Domain Registry Interface, Net::DRI::Protocol::EPP class for .SE ## Contributed by Elias Sidenbladh and Ulrich Wisser from NIC SE ## ## Copyright (c) 2006,2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SE; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Protocol::EPP::Extensions::SE::Message; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SE - .SE EPP Extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; my $version=$self->version(); $self->ns({iis=>['urn:se:iis:xml:epp:iis-1.1','iis-1.1.xsd']}); $self->factories('message',sub { my $m = Net::DRI::Protocol::EPP::Extensions::SE::Message->new(@_); $m->ns( $self->ns() ); $m->version($version); return $m; } ); return; } sub default_extensions { return qw/SE::Extensions SecDNS/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NeuLevel/0002755000175000017500000000000011352534417022512 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NeuLevel/UIN.pm0000644000175000017500000000711411352534377023511 0ustar patrickpatrick## Domain Registry Interface, EPP Extension for .travel UIN ## (ICANN Sponsored TLD Registry Agreement, Part IV) ## ## Copyright (c) 2008 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NeuLevel::UIN; use strict; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NeuLevel::UIN - EPP Extension for .TRAVEL UIN for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class, $version) = @_; my %tmp = ( create => [ \&add_uin, undef ], transfer_request => [ \&add_uin, undef ], renew => [ \&renew, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### ############ Transform commands sub add_uin { my ($epp, $domain, $rd) = @_; my $mes = $epp->message(); return unless Net::DRI::Util::has_key($rd,'uin'); my $eid = $mes->command_extension_register('neulevel:extension', 'xmlns:neulevel="urn:ietf:params:xml:ns:neulevel-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:neulevel-1.0 neulevel-1.0.xsd"'); $mes->command_extension($eid, ['neulevel:unspec', 'UIN=' . $rd->{uin}]); } sub renew { my ($epp, $domain, $rd) = @_; my $mes = $epp->message(); my @vals = qw(RestoreReasonCode RestoreComment TrueData ValidUse UIN); my %info; my $comment; if (defined($rd->{rgp}) && ref($rd->{rgp}) eq 'HASH') { $info{TrueData} = 'Y'; $info{ValidUse} = 'Y'; $info{RestoreReasonCode} = $rd->{rgp}->{code}; $comment = $rd->{rgp}->{comment}; $comment = join('', map { ucfirst($_) } split(/\s+/, $comment)); $info{RestoreComment} = $comment; } if (Net::DRI::Util::has_key($rd,'uin')) { $info{UIN} = $rd->{uin}; } my $eid = $mes->command_extension_register('neulevel:extension', 'xmlns:neulevel="urn:ietf:params:xml:ns:neulevel-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:neulevel-1.0 neulevel-1.0.xsd"'); $mes->command_extension($eid, ['neulevel:unspec', join(' ', map { $_ . '=' . $info{$_} } grep { defined($info{$_}) } @vals)]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NeuLevel/IDNLanguage.pm0000644000175000017500000000536111352534377025136 0ustar patrickpatrick## Domain Registry Interface, Neulevel EPP IDN Language ## ## Copyright (c) 2009 Jouanne Mickael . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NeuLevel::IDNLanguage; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NeuLevel::IDNLanguage - NeuLevel EPP IDN Language Commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Jouanne Mickael Egrigouze@gandi.netE =head1 COPYRIGHT Copyright (c) 2009 Jouanne Mickael . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub add_language { my ($tag,$epp,$domain,$rd)=@_; my $mes=$epp->message(); if (Net::DRI::Util::has_key($rd,'language')) { Net::DRI::Exception::usererr_invalid_parameters('IDN language tag must be of type XML schema language') unless Net::DRI::Util::xml_is_language($rd->{language}); my $eid=$mes->command_extension_register($tag,'xmlns:neulevel="urn:ietf:params:xml:ns:neulevel-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:neulevel-1.0 neulevel-1.0.xsd"'); $mes->command_extension($eid,['neulevel:unspec', 'IDNLang=' . $rd->{language}]); } } sub create { return add_language('idn:create',@_); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PRO.pm0000644000175000017500000000464711352534377022007 0ustar patrickpatrick## Domain Registry Interface, .PRO EPP extensions ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::PRO; use strict; use base qw/Net::DRI::Protocol::EPP/; our $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::PRO - .PRO EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE, Alexander Biehl Einfo@hexonet.netE, HEXONET Support GmbH, Ehttp://www.hexonet.net/E =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; # Namespaces $self->ns({ av => ['http://registrypro.pro/2003/epp/1/av-2.0', 'av-2.0.xsd'], rpro=> ['http://registrypro.pro/2003/epp/1/rpro-epp-2.0','rpro-epp-2.0.xsd'], }); $self->capabilities('domain_update','pro',['set']); return; } sub default_extensions { return qw/PRO::Domain PRO::AV GracePeriod/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/IT.pm0000644000175000017500000000464211352534377021656 0ustar patrickpatrick## Domain Registry Interface, .IT EPP extensions ## ## Copyright (c) 2009-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::IT; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::IT; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::IT - .IT EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ 'it_epp' => [ 'http://www.nic.it/ITNIC-EPP/extepp-1.0', 'extepp-1.0.xsd' ], 'it_contact' => [ 'http://www.nic.it/ITNIC-EPP/extcon-1.0', 'extcon-1.0.xsd' ], 'it_domain' => [ 'http://www.nic.it/ITNIC-EPP/extdom-1.0', 'extdom-1.0.xsd' ], }); $self->factories('contact', sub { return Net::DRI::Data::Contact::IT->new(); }); return; } sub default_extensions { return qw/GracePeriod IT::Contact IT::Domain IT::Notifications/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/EURid.pm0000644000175000017500000000610211352534377022303 0ustar patrickpatrick## Domain Registry Interface, EURid EPP extensions ## ## Copyright (c) 2005,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::EURid; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::EURid; use Net::DRI::Protocol::EPP::Extensions::EURid::Message; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::EURid - EURid (.EU) EPP extensions (release 5.6) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; my $version=$self->version(); $self->ns({_main => ['http://www.eurid.eu/xml/epp/epp-1.0','epp-1.0.xsd']}); foreach my $w (qw/domain contact eurid nsgroup registrar/) { $self->ns({ $w => ['http://www.eurid.eu/xml/epp/'.$w.'-1.0',$w.'-1.0.xsd'] }); } $self->capabilities('contact_update','status',undef); ## No changes in status possible for .EU domains/contacts $self->capabilities('domain_update','status',undef); $self->capabilities('domain_update','nsgroup',[ 'add','del']); $self->factories('contact',sub { return Net::DRI::Data::Contact::EURid->new(); }); $self->factories('message',sub { my $m=Net::DRI::Protocol::EPP::Extensions::EURid::Message->new(@_); $m->ns($self->{ns}); $m->version($version); return $m;} ); $self->default_parameters({domain_create => { auth => { pw => '' } } }); return; } sub core_contact_types { return ('admin','tech','billing','onsite'); } sub default_extensions { return qw/EURid::Domain EURid::Contact EURid::Registrar EURid::Notifications NSgroup/; } ## Sunrise should be added when calling, as it is not mandatory #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/E164.pm0000644000175000017500000001361711352534377021763 0ustar patrickpatrick## Domain Registry Interface, EPP E.164 Number Mapping (RFC4114) ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::E164; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='urn:ietf:params:xml:ns:e164epp-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::E164 - EPP E.164 Number Mapping (RFC4114) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], create => [ \&create, undef ], update => [ \&update, undef ], ); return { 'domain' => \%tmp }; } sub capabilities_add { return ('domain_update','e164',['add','del']); } #################################################################################################### sub format_naptr { my $e=shift; Net::DRI::Exception::usererr_insufficient_parameters('Attributes order, pref and svc must exist') unless ((ref($e) eq 'HASH') && exists($e->{order}) && exists($e->{pref}) && exists($e->{svc})); Net::DRI::Exception::usererr_invalid_parameters('Order must be 16-bit unsigned integer') unless Net::DRI::Util::verify_ushort($e->{order}); Net::DRI::Exception::usererr_invalid_parameters('Pref must be 16-bit unsigned integer') unless Net::DRI::Util::verify_ushort($e->{pref}); Net::DRI::Exception::usererr_invalid_parameters('Svc must be at least 1 character as xml token type') unless Net::DRI::Util::xml_is_token($e->{svc},1,undef); my @c; push @c,['e164:order',$e->{order}]; push @c,['e164:pref',$e->{pref}]; if (exists($e->{flags})) { Net::DRI::Exception::usererr_invalid_parameters('Flags must be a single letter or number') unless ($e->{flags}=~m/^[A-Z0-9]$/i); push @c,['e164:flags',$e->{flags}]; } push @c,['e164:svc',$e->{svc}]; if (exists($e->{regex})) { Net::DRI::Exception::usererr_invalid_parameters('Regex must be at least 1 character as xml token type') unless Net::DRI::Util::xml_is_token($e->{regex},1,undef); push @c,['e164:regex',$e->{regex}]; } if (exists($e->{replacement})) { Net::DRI::Exception::usererr_invalid_parameters('Regex must be between 1 and 255 characters as xml token type') unless Net::DRI::Util::xml_is_token($e->{regex},1,255); push @c,['e164:replacement',$e->{replacement}]; } return @c; } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension($NS,'infData'); return unless defined $infdata; my @naptr; foreach my $el ($infdata->getChildrenByTagNameNS($NS,'naptr')) { my %n; foreach my $sel (Net::DRI::Util::xml_list_children($el)) { my ($name,$c)=@$sel; if ($name=~m/^(order|pref|flags|svc|regex|replacement)$/) { $n{$1}=$c->textContent(); } } push @naptr,\%n; } $rinfo->{domain}->{$oname}->{e164}=\@naptr; } ############ Transform commands sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $def=$epp->default_parameters(); ## IENUMAT works without the e164 extension part unless (exists($rd->{e164}) && (ref($rd->{e164}) eq 'ARRAY') && @{$rd->{e164}}) { Net::DRI::Exception::usererr_insufficient_parameters('One or more E164 data block must be provided') unless (defined($def) && exists($def->{rfc4114_relax}) && $def->{rfc4114_relax}); return; } my $eid=$mes->command_extension_register('e164:create','xmlns:e164="urn:ietf:params:xml:ns:e164epp-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:e164epp-1.0 e164epp-1.0.xsd"'); my @n=map { ['e164:naptr',format_naptr($_)] } (@{$rd->{e164}}); $mes->command_extension($eid,\@n); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $toadd=$todo->add('e164'); my $todel=$todo->del('e164'); return unless (defined($toadd) || defined($todel)); my $eid=$mes->command_extension_register('e164:update','xmlns:e164="urn:ietf:params:xml:ns:e164epp-1.0" xsi:schemaLocation="urn:ietf:params:xml:ns:e164epp-1.0 e164epp-1.0.xsd"'); my @n; push @n,['e164:add',map { ['e164:naptr',format_naptr($_)] } (ref($toadd) eq 'ARRAY')? @$toadd : ($toadd)] if (defined($toadd)); push @n,['e164:rem',map { ['e164:naptr',format_naptr($_)] } (ref($todel) eq 'ARRAY')? @$todel : ($todel)] if (defined($todel)); $mes->command_extension($eid,\@n); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/FCCN/0002755000175000017500000000000011352534417021504 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/FCCN/Contact.pm0000644000175000017500000001056311352534377023445 0ustar patrickpatrick## Domain Registry Interface, FCCN (.PT) Contact EPP extension commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::FCCN::Contact; use strict; use warnings; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::FCCN::Contact - FCCN (.PT) EPP Contact extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ undef, \&info_parse ], ); return { 'contact' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:ptcontact="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('ptcontact'))); } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); # validate() has been called my @n; push @n,['ptcontact:type',$contact->type()]; push @n,['ptcontact:identification',{type=>$contact->identification()->{type}},$contact->identification()->{value}]; push @n,['ptcontact:mobile',$contact->mobile()] if $contact->mobile(); my $eid=build_command_extension($mes,$epp,'ptcontact:create'); $mes->command_extension($eid,\@n); } sub update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); my @n; my $auth=$contact->auth(); Net::DRI::Exception::usererr_insufficient_parameters('Contact password is mandatory for .PT contact update') unless (defined($auth) && (ref($auth) eq 'HASH') && exists($auth->{pw}) && Net::DRI::Util::xml_is_normalizedstring($auth->{pw})); push @n,['ptcontact:pw',$auth->{pw}]; my $newc=$todo->set('info'); if ($newc) { Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact '.$newc) unless Net::DRI::Util::isa_contact($newc,'Net::DRI::Data::Contact::FCCN'); push @n,['ptcontact:mobile',$newc->mobile()] if $newc->mobile(); } my $eid=build_command_extension($mes,$epp,'ptcontact:update'); $mes->command_extension($eid,\@n); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('ptcontact','infData'); return unless $infdata; my $ns=$mes->ns('ptcontact'); my $co=$rinfo->{contact}->{$oname}->{self}; my $c=$infdata->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'type') { $co->type($c->getFirstChild()->getData()); } elsif ($name eq 'identification') { $co->identification({type=>$c->getAttribute('type'),value=>$c->getFirstChild()->getData()}); } elsif ($name eq 'mobile') { $co->mobile($c->getFirstChild()->getData()); } } continue { $c=$c->getNextSibling(); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/FCCN/Domain.pm0000644000175000017500000002015411352534377023256 0ustar patrickpatrick## Domain Registry Interface, .PT Domain EPP extension commands ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::FCCN::Domain; use strict; use Net::DRI::Exception; use Net::DRI::Util; use DateTime::Duration; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::FCCN::Domain - FCCN (.PT) EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, \&create_parse ], info => [ \&info, \&info_parse ], update => [ \&update ], renew => [ \&renew ], renounce => [ \&renounce ], delete => [ \&delete ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:ptdomain="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('ptdomain'))); } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('Registrant contact required for .PT domain name creation') unless (Net::DRI::Util::has_contact($rd) && $rd->{contact}->has_type('registrant')); Net::DRI::Exception::usererr_insufficient_parameters('Tech contact required for .PT domain name creation') unless (Net::DRI::Util::has_contact($rd) && $rd->{contact}->has_type('tech')); foreach my $d (qw/legitimacy registration_basis add_period next_possible_registration auto_renew/) { Net::DRI::Exception::usererr_insufficient_parameters($d.' attribute is mandatory for .PT domain name creation') unless Net::DRI::Util::has_key($rd,$d); } Net::DRI::Exception::usererr_invalid_parameters('legitimacy attribute must be 0,1,2,3,4 or 5') unless ($rd->{legitimacy}=~m/^[01245]$/); Net::DRI::Exception::usererr_invalid_parameters('registration_basis attribute must be 010,020,030,040,050,060,070,080,090,100') unless ($rd->{registration_basis}=~m/^(?:0[123456789]0|100)$/); foreach my $d (qw/add_period next_possible_registration auto_renew/) { Net::DRI::Exception::usererr_invalid_parameters($d.' must be either 0 or 1 for .PT domain name creation') unless ($rd->{$d}==0 || $rd->{$d}==1); } my @n; push @n,['ptdomain:legitimacy',{type => $rd->{legitimacy}}]; push @n,['ptdomain:registration_basis',{type => $rd->{registration_basis}}]; push @n,['ptdomain:addPeriod',$rd->{add_period}]; push @n,['ptdomain:nextPossibleRegistration',$rd->{next_possible_registration}]; push @n,['ptdomain:autoRenew',$rd->{auto_renew}]; my $eid=build_command_extension($mes,$epp,'ptdomain:create'); $mes->command_extension($eid,\@n); } sub create_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_extension('ptdomain','creData'); return unless $credata; my $c=$credata->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); if ($n eq 'roid') { $rinfo->{domain}->{$oname}->{roid}=$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } } sub add_roid { my ($roid)=@_; return ['ptdomain:roid',$roid]; } sub info { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('roid attribute required for .PT domain name info') unless (Net::DRI::Util::has_key($rd,'roid')); my $eid=build_command_extension($mes,$epp,'ptdomain:info'); my @n=add_roid($rd->{roid}); $mes->command_extension($eid,\@n); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('ptdomain','infData'); return unless $infdata; my $c=$infdata->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name=~m/^(?:legitimacy|registration_basis)$/) { $rinfo->{domain}->{$oname}->{$name}=$c->getAttribute('type'); } elsif ($name=~m/^(?:autoRenew|notRenew|nextPossibleRegistration|addPeriod|waitingRemoval)$/) { $rinfo->{domain}->{$oname}->{Net::DRI::Util::remcam($name)}=Net::DRI::Util::xml_parse_boolean($c->getFirstChild()->getData()); } elsif ($name eq 'renew') { $rinfo->{domain}->{$oname}->{renew_period}=DateTime::Duration->new(years => $c->getAttribute('period')); } } continue { $c=$c->getNextSibling(); } } sub update { my ($epp,$domain,$toc,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('roid attribute required for .PT domain name update') unless (Net::DRI::Util::has_key($rd,'roid')); my $eid=build_command_extension($mes,$epp,'ptdomain:update'); my @n=add_roid($rd->{roid}); $mes->command_extension($eid,\@n); } sub renew { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('roid attribute required for .PT domain name renew') unless (Net::DRI::Util::has_key($rd,'roid')); my $c=Net::DRI::Util::has_key($rd,'duration'); foreach my $d (qw/auto_renew not_renew/) { next unless Net::DRI::Util::has_key($rd,$d); Net::DRI::Exception::usererr_invalid_parameters($d.' must be either 0 or 1 for .PT domain name creation') unless ($rd->{$d}==0 || $rd->{$d}==1); $c+=$rd->{$d}; } Net::DRI::Exception::usererr_invalid_parameters('only one of duration, auto_renew and not_renew attributes can be set for .PT domain name renew') if $c > 1; my $eid=build_command_extension($mes,$epp,'ptdomain:renew'); my @n=add_roid($rd->{roid}); push @n,['ptdomain:autoRenew',$rd->{auto_renew}] if Net::DRI::Util::has_key($rd,'auto_renew'); push @n,['ptdomain:notRenew',$rd->{not_renew}] if Net::DRI::Util::has_key($rd,'not_renew'); $mes->command_extension($eid,\@n); } sub renounce { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('roid attribute required for .PT domain name renounce') unless (Net::DRI::Util::has_key($rd,'roid')); my $eid=build_command_extension($mes,$epp,'ptdomain:renounce'); my @n=(['ptdomain:name',$domain]); push @n,add_roid($rd->{roid}); push @n,['ptdomain:clTRID',$mes->cltrid()]; $mes->command_extension($eid,\@n); } sub delete { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('roid attribute required for .PT domain name delete') unless (Net::DRI::Util::has_key($rd,'roid')); my $eid=build_command_extension($mes,$epp,'ptdomain:delete'); my @n=add_roid($rd->{roid}); $mes->command_extension($eid,\@n); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/BR/0002755000175000017500000000000011352534417021276 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/BR/Contact.pm0000644000175000017500000002302111352534377023230 0ustar patrickpatrick## Domain Registry Interface, .BR Contact EPP extension commands ## draft-neves-epp-brorg-03.txt ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::BR::Contact; use strict; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Data::ContactSet; use Net::DRI::Data::Contact::BR; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::BR::Contact - .BR EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], create => [ \&create, undef ], update => [ \&update, undef ], review_complete => [ undef, \&pandata_parse ], ); $tmp{check_multi}=$tmp{check}; return { 'contact' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:brorg="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('brorg'))); } sub check { my ($epp,$contact,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'brorg:check'); my @n; foreach my $c ((ref($contact) eq 'ARRAY')? @$contact : ($contact)) { Net::DRI::Exception::usererr_invalid_parameters('contact must be Net::DRI::Data::Contact::BR object') unless Net::DRI::Util::isa_contact($c,'Net::DRI::Data::Contact::BR'); my $orgid=$c->orgid(); if (defined($orgid)) { Net::DRI::Exception::usererr_invalid_parameters('orgid must be an xml token string with 1 to 30 characters') unless Net::DRI::Util::xml_is_token($orgid,1,30); push @n,['brorg:cd',['brorg:id',$c->srid()],['brorg:organization',$orgid]]; } else { push @n,['brorg:cd',['brorg:id',$c->srid()]]; } } $mes->command_extension($eid,\@n); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $chkdata=$mes->get_extension('brorg','chkData'); return unless $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($mes->ns('brorg'),'ticketInfo')) { my $c=$cd->getFirstChild(); my ($orgid,$ticket,$domain); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); if ($n eq 'organization') { $orgid=$c->getFirstChild()->getData(); } elsif ($n eq 'ticketNumber') { $ticket=$c->getFirstChild()->getData(); } elsif ($n eq 'domainName') { $domain=$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } $rinfo->{orgid}->{$orgid}->{ticket}=$ticket; $rinfo->{orgid}->{$orgid}->{domain}=$domain; $rinfo->{domain}->{$domain}->{ticket}=$ticket; $rinfo->{domain}->{$domain}->{orgid}=$orgid; } } sub info { my ($epp,$contact,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters('contact must be Net::DRI::Data::Contact::BR object') unless Net::DRI::Util::isa_contact($contact,'Net::DRI::Data::Contact::BR'); my $orgid=$contact->orgid(); return unless defined($orgid); ## to be able to create pure contacts Net::DRI::Exception::usererr_invalid_parameters('orgid must be an xml token string with 1 to 30 characters') unless Net::DRI::Util::xml_is_token($orgid,1,30); my $eid=build_command_extension($mes,$epp,'brorg:info'); my @n=(['brorg:organization',$orgid]); $mes->command_extension($eid,\@n); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('brorg','infData'); return unless $infdata; my $id=(keys(%{$rinfo->{contact}}))[0]; my $co=$rinfo->{contact}->{$id}->{self}; my $cs=Net::DRI::Data::ContactSet->new(); my ($orgid,@d); my $c=$infdata->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); if ($n eq 'organization') { $orgid=$c->getFirstChild()->getData(); $co->orgid($orgid); $rinfo->{contact}->{$id}->{orgid}=$orgid; } elsif ($n eq 'contact') { my $co=Net::DRI::Data::Contact::BR->new(); $co->srid($c->getFirstChild()->getData()); $co->orgid($orgid); my $type=$c->getAttribute('type'); $co->type($type); $cs->add($co,$type); } elsif ($n eq 'responsible') { $co->responsible($c->getFirstChild()->getData()); } elsif ($n eq 'proxy') { $co->proxy($c->getFirstChild()->getData()); } elsif ($n eq 'domainName') { push @d,$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } $co->associated_contacts($cs) unless $cs->is_empty(); $co->associated_domains(\@d) if @d; } sub build_contacts { my $cs=shift; my @n; foreach my $t (sort($cs->types())) { push @n,map { ['brorg:contact',$_->srid(),{'type'=>$t}] } ($cs->get($t)); } return @n; } sub create { my ($epp,$contact,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters('contact must be Net::DRI::Data::Contact::BR object') unless Net::DRI::Util::isa_contact($contact,'Net::DRI::Data::Contact::BR'); my $orgid=$contact->orgid(); return unless defined($orgid); ## to be able to create pure contacts Net::DRI::Exception::usererr_invalid_parameters('orgid must be an xml token string with 1 to 30 characters') unless Net::DRI::Util::xml_is_token($orgid,1,30); my $cs=$contact->associated_contacts(); Net::DRI::Exception::usererr_invalid_parameters('associated_contacts must be a ContactSet object') unless Net::DRI::Util::isa_contactset($cs); Net::DRI::Exception::usererr_insufficient_parameters('associated_contacts must not be empty') if $cs->is_empty(); my $eid=build_command_extension($mes,$epp,'brorg:create'); my @n=(['brorg:organization',$orgid]); push @n,build_contacts($cs); push @n,['brorg:responsible',$contact->responsible()] if $contact->responsible(); $mes->command_extension($eid,\@n); } sub update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters('contact must be Net::DRI::Data::Contact::BR object') unless Net::DRI::Util::isa_contact($contact,'Net::DRI::Data::Contact::BR'); my $orgid=$contact->orgid(); return unless defined($orgid); ## to be able to update pure contacts Net::DRI::Exception::usererr_invalid_parameters('orgid must be an xml token string with 1 to 30 characters') unless Net::DRI::Util::xml_is_token($orgid,1,30); my $cadd=$todo->add('associated_contacts'); my $cdel=$todo->del('associated_contacts'); Net::DRI::Exception::usererr_invalid_parameters('associated_contacts to add must be a ContactSet object') if (defined($cadd) && !Net::DRI::Util::isa_contactset($cadd)); Net::DRI::Exception::usererr_invalid_parameters('associated_contacts to del must be a ContactSet object') if (defined($cdel) && !Net::DRI::Util::isa_contactset($cdel)); my $resp=$todo->set('responsible'); return unless (defined($cadd) || defined($cdel) || defined($resp)); my @n=(['brorg:organization',$orgid]); push @n,['brorg:add',build_contacts($cadd)] if defined($cadd); push @n,['brorg:rem',build_contacts($cdel)] if defined($cdel); push @n,['brorg:chg',['brorg:responsible',Net::DRI::Util::isa_contact($resp,'Net::DRI::Data::Contact::BR')? $resp->responsible() : $resp]] if defined($resp); my $eid=build_command_extension($mes,$epp,'brorg:update'); $mes->command_extension($eid,\@n); } sub pandata_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $pandata=$mes->get_extension('brorg','panData'); return unless $pandata; my $c=$pandata->firstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); next unless $n; if ($n eq 'organization') { $rinfo->{$otype}->{$oname}->{orgid}=$c->getFirstChild()->getData(); } elsif ($n eq 'reason') { $rinfo->{$otype}->{$oname}->{reason}=$c->textContent(); ## this may be empty $rinfo->{$otype}->{$oname}->{reason_lang}=$c->getAttribute('lang') || 'en'; } } continue { $c=$c->getNextSibling(); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/BR/Domain.pm0000644000175000017500000002620611352534377023054 0ustar patrickpatrick## Domain Registry Interface, .BR Domain EPP extension commands ## draft-neves-epp-brdomain-03.txt ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::BR::Domain; use strict; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::BR::Domain - .BR EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], create => [ \&create, \&create_parse ], renew => [ undef, \&renew_parse ], update => [ \&update, \&update_parse ], review_complete => [ undef, \&pandata_parse ], ## needs to have same name for key as in Core/Domain to make sure this will be called after Core parsing ! ); $tmp{check_multi}=$tmp{check}; return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:brdomain="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('brdomain'))); } sub check { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless Net::DRI::Util::has_key($rd,'orgid'); Net::DRI::Exception::usererr_invalid_parameters('orgid must be an xml token string with 1 to 30 characters') unless Net::DRI::Util::xml_is_token($rd->{orgid},1,30); my $eid=build_command_extension($mes,$epp,'brdomain:check'); my @n=('brdomain:organization',$rd->{orgid}); $mes->command_extension($eid,\@n); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $chkdata=$mes->get_extension('brdomain','chkData'); return unless $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($mes->ns('brdomain'),'cd')) { my $hc=$cd->getAttribute('hasConcurrent'); my $irp=$cd->getAttribute('inReleaseProcess'); my $c=$cd->getFirstChild(); my $domain; my @tn; while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); if ($n eq 'name') { $domain=lc($c->getFirstChild()->getData()); $rinfo->{domain}->{$domain}->{has_concurrent}=Net::DRI::Util::xml_parse_boolean($hc) if defined($hc); $rinfo->{domain}->{$domain}->{in_release_process}=Net::DRI::Util::xml_parse_boolean($irp) if defined($irp); } elsif ($n eq 'equivalentName') { $rinfo->{domain}->{$domain}->{equivalent_name}=$c->getFirstChild()->getData(); } elsif ($n eq 'organization') { $rinfo->{domain}->{$domain}->{orgid}=$c->getFirstChild()->getData(); } elsif ($n eq 'ticketNumber') { push @tn,$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } $rinfo->{domain}->{$domain}->{ticket}=\@tn; } } sub info { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless Net::DRI::Util::has_key($rd,'ticket'); Net::DRI::Exception::usererr_invalid_parameters('ticket parameter must be an integer') unless Net::DRI::Util::isint($rd->{ticket}); my $eid=build_command_extension($mes,$epp,'brdomain:info'); my @n=('brdomain:ticketNumber',$rd->{ticket}); $mes->command_extension($eid,\@n); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('brdomain','infData'); return unless $infdata; parse_extra_data($po,$oname,$rinfo,$mes,$infdata); } sub parse_extra_data { my ($po,$oname,$rinfo,$mes,$c)=@_; my $ns=$mes->ns('brdomain'); $c=$c->getFirstChild(); my @tnc; while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); if ($n eq 'ticketNumber') { $rinfo->{domain}->{$oname}->{ticket}=$c->getFirstChild()->getData(); } elsif ($n eq 'organization') { $rinfo->{domain}->{$oname}->{orgid}=$c->getFirstChild()->getData(); } elsif ($n eq 'releaseProcessFlags') { my %f; foreach my $f (1..3) { next unless $c->hasAttribute('flag'.$f); $f{'flag'.$f}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('flag'.$f)); } $rinfo->{domain}->{$oname}->{release_process}=\%f; } elsif ($n eq 'pending') { my $cc=$c->getFirstChild(); my %p; my $pd=DateTime::Format::ISO8601->new(); while($cc) { next unless ($cc->nodeType() == 1); my $nn=$cc->localName() || $c->nodeName(); if ($nn eq 'doc') { my $d=$cc->getChildrenByTagNameNS($ns,'description')->shift(); push @{$p{doc}}, { status => $cc->getAttribute('status'), type => $cc->getChildrenByTagNameNS($ns,'docType')->shift()->getFirstChild()->getData(), limit => $pd->parse_datetime($cc->getChildrenByTagNameNS($ns,'limit')->shift()->getFirstChild()->getData()), description => $d->getFirstChild()->getData(), lang => $d->getAttribute('lang'), }; } elsif ($nn eq 'dns') { push @{$p{dns}},{ status => $cc->getAttribute('status'), hostname => $cc->getChildrenByTagNameNS($ns,'hostName')->shift()->getFirstChild()->getData(), limit => $pd->parse_datetime($cc->getChildrenByTagNameNS($ns,'limit')->shift()->getFirstChild()->getData()), }; } elsif ($nn eq 'releaseProc') { $p{release}={ status => $cc->getAttribute('status'), limit => $pd->parse_datetime($cc->getChildrenByTagNameNS($ns,'limit')->shift()->getFirstChild()->getData()), }; } } continue { $cc=$cc->getNextSibling(); } $rinfo->{domain}->{$oname}->{pending}=\%p; } elsif ($n eq 'ticketNumberConc') { push @tnc,$c->getFirstChild()->getData(); } elsif ($n eq 'publicationStatus') { $rinfo->{domain}->{$oname}->{publication}=parse_publication($ns,$c); } elsif ($n eq 'autoRenew') { $rinfo->{domain}->{$oname}->{auto_renew}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('active')); } } continue { $c=$c->getNextSibling(); } $rinfo->{domain}->{$oname}->{ticket_concurrent}=\@tnc; } sub parse_publication { my ($ns,$c)=@_; my %s; $s{flag}=$c->getAttribute('publicationFlag'); foreach my $r ($c->getChildrenByTagNameNS($ns,'onHoldReason')) { push @{$s{onhold_reason}},$r->getFirstChild()->getData(); } return \%s; } sub build_release { my $rh=shift; my %f=map { $_ => (defined($rh->{$_}) && $rh->{$_})? 1 : 0 } grep { exists($rh->{$_}) } qw/flag1 flag2 flag3/; return keys(%f)? ['brdomain:releaseProcessFlags',\%f] : (); } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('orgid is mandatory for domain_create') unless Net::DRI::Util::has_key($rd,'orgid'); Net::DRI::Exception::usererr_invalid_parameters('orgid must be an xml token string with 1 to 30 characters') unless Net::DRI::Util::xml_is_token($rd->{orgid},1,30); my @n=(['brdomain:organization',$rd->{orgid}]); push @n,build_release($rd->{release}) if (Net::DRI::Util::has_key($rd,'release') && (ref($rd->{release}) eq 'HASH')); push @n,['brdomain:autoRenew',{active => $rd->{auto_renew}? 1 : 0 }] if (Net::DRI::Util::has_key($rd,'auto_renew')); my $eid=build_command_extension($mes,$epp,'brdomain:create'); $mes->command_extension($eid,\@n); } sub create_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $credata=$mes->get_extension('brdomain','creData'); return unless $credata; parse_extra_data($po,$oname,$rinfo,$mes,$credata); } sub renew_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rendata=$mes->get_extension('brdomain','renData'); return unless $rendata; my $ns=$mes->ns('brdomain'); my $pub=$rendata->getChildrenByTagNameNS($ns,'publicationStatus'); return unless $pub->size(); $rinfo->{domain}->{$oname}->{publication}=parse_publication($ns,$pub->shift()); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $ticket=$todo->set('ticket'); my $release=$todo->set('release'); my $autorenew=$todo->set('auto_renew'); return unless (defined($ticket) || defined($release) || defined($autorenew)); my @n; push @n,['brdomain:ticketNumber',$ticket] if (defined($ticket) && Net::DRI::Util::isint($ticket)); my @c; push @c,build_release($release) if (defined($release) && (ref($release) eq 'HASH')); push @c,['brdomain:autoRenew',{active => $autorenew? 1 : 0}] if defined($autorenew); push @n,['brdomain:chg',@c] if @c; return unless @n; my $eid=build_command_extension($mes,$epp,'brdomain:update'); $mes->command_extension($eid,\@n); } sub update_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $upddata=$mes->get_extension('brdomain','updData'); return unless $upddata; parse_extra_data($po,$oname,$rinfo,$mes,$upddata); } sub pandata_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $pandata=$mes->get_extension('brdomain','panData'); return unless $pandata; my $c=$pandata->firstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); next unless $n; if ($n eq 'ticketNumber') { $rinfo->{$otype}->{$oname}->{ticket}=$c->getFirstChild()->getData(); } elsif ($n eq 'reason') { $rinfo->{$otype}->{$oname}->{reason}=$c->getFirstChild()->getData(); $rinfo->{$otype}->{$oname}->{reason_lang}=$c->getAttribute('lang') || 'en'; } } continue { $c=$c->getNextSibling(); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AT/0002755000175000017500000000000011352534417021277 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AT/Contact.pm0000644000175000017500000000673311352534377023244 0ustar patrickpatrick## Domain Registry Interface, NIC.AT Contact extension ## Contributed by Michael Braunoeder from NIC.AT ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AT::Contact; use strict; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='http://www.nic.at/xsd/at-ext-contact-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AT::Contact - NIC.AT Contact Extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&parse_info ], update => [ \&update, undef ], create => [ \&create, undef ], ); return { 'contact' => \%tmp }; } sub parse_info { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless ($mes->result_code() == 1000); my $c=$rinfo->{contact}->{$oname}->{self}; $c->email(undef) if ($c->email() eq 'n/a'); my $condata=$mes->get_extension($NS,'infData'); return unless $condata; my @options; my $el=$condata->getElementsByTagNameNS($NS,'type'); my $type=$el? $el->get_node(1)->getFirstChild()->getData() : undef; $c->type($type) if (defined($type) && $type); # $rinfo->{contact}->{$oname}->{type}=$type if $type; } sub create { my ($epp,$contact,$rd)=@_; my $mes=$epp->message(); my $type=$contact->type(); return unless (defined($type)); my $eid=$mes->command_extension_register('at-ext-contact:create','xmlns:at-ext-contact="'.$NS.'" xsi:schemaLocation="'.$NS.' at-ext-contact-1.0.xsd"'); $mes->command_extension($eid,['at-ext-contact:type',$type]); } sub update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); my $newc=$todo->set('info'); my $type=$newc->type(); return unless (defined($type)); my $eid=$mes->command_extension_register('at-ext-contact:update','xmlns:at-ext-contact="'.$NS.'" xsi:schemaLocation="'.$NS.' at-ext-contact-1.0.xsd"'); $mes->command_extension($eid,['at-ext-contact:chg',['at-ext-contact:type',$type]]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AT/ATResult.pm0000644000175000017500000000747111352534377023354 0ustar patrickpatrick## Domain Registry Interface, nic.at domain transactions extension ## Contributed by Michael Braunoeder from NIC.AT ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AT::ATResult; use strict; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='http://www.nic.at/xsd/at-ext-result-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AT::ATResult - NIC.AT Result Condition EPP Mapping for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( login => [ undef, \&condition_parse ], check => [ undef, \&condition_parse ], info => [ undef, \&condition_parse ], transfer_query => [ undef, \&condition_parse ], create => [ undef, \&condition_parse ], delete => [ undef, \&condition_parse], transfer_request => [ undef, \&condition_parse ], transfer_cancel => [ undef,\&condition_parse ], transfer_answer => [ undef,\&condition_parse ], update => [ undef, \&condition_parse ], nocommand => [ undef, \&condition_parse ], ); return { 'domain' => \%tmp, 'contact' => \%tmp }; } sub condition_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); my $condata=$mes->get_extension($NS,'conditions'); return unless $condata; my @conditions; foreach my $el ($condata->getElementsByTagNameNS($NS,'condition')) { my %con; my $c=$el->getFirstChild(); $con{code}=$el->getAttribute('code') if $el->getAttribute('code'); $con{severity}=$el->getAttribute('severity') if $el->getAttribute('severity'); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name=~m/^(msg|details)$/) { $con{$1}=$c->getFirstChild()->getData(); } elsif ($name=~m/^attributes$/) { foreach my $attr ($c->getChildrenByTagNameNS($NS,'attr')) { my $attrname=$attr->getAttribute('name'); $con{"attr " .$attrname} = $attr->getFirstChild()->getData(); } } } continue { $c=$c->getNextSibling(); } push @conditions,\%con; } $rinfo->{domain}->{$oname}->{conditions}=\@conditions; $rinfo->{contact}->{$oname}->{conditions}=\@conditions; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AT/Result.pm0000644000175000017500000000671711352534377023131 0ustar patrickpatrick## Domain Registry Interface, ENUM.AT Result Condition ## Contributed by Michael Braunoeder from ENUM.AT ## ## Copyright (c) 2006,2007 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AT::Result; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='http://www.enum.at/rxsd/ienum43-result-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AT::Result - ENUM.AT Result Condition EPP Mapping for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( login => [ undef, \&condition_parse ], check => [ undef, \&condition_parse ], info => [ undef, \&condition_parse ], transfer_query => [ undef, \&condition_parse ], create => [ undef, \&condition_parse ], delete => [ undef, \&condition_parse], transfer_request => [ undef, \&condition_parse ], transfer_cancel => [ undef,\&condition_parse ], transfer_answer => [ undef,\&condition_parse ], update => [ undef, \&condition_parse ], ); return { 'domain' => \%tmp }; } sub condition_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); my $condata=$mes->get_extension($NS,'conditions'); return unless $condata; my @conditions; foreach my $el ($condata->getElementsByTagNameNS($NS,'condition')) { my %con; my $c=$el->getFirstChild(); $con{code}=$el->getAttribute('code') if $el->getAttribute('code'); $con{severity}=$el->getAttribute('severity') if $el->getAttribute('severity'); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name=~m/^(msg|details)$/) { $con{$1}=$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } push @conditions,\%con; } $rinfo->{domain}->{$oname}->{conditions}=\@conditions; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AT/Domain.pm0000644000175000017500000001456311352534377023060 0ustar patrickpatrick## Domain Registry Interface, nic.at domain transactions extension ## Contributed by Michael Braunoeder from NIC.AT ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AT::Domain; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION = do { my @r = ( q$Revision: 1.4 $ =~ /\d+/g ); sprintf( "%d" . ".%02d" x $#r, @r ); }; our $NS = 'http://www.nic.at/xsd/at-ext-domain-1.0'; our $ExtNS = 'http://www.nic.at/xsd/at-ext-epp-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AT::Domain - NIC.AT EPP Domain extension for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ( $class, $version ) = @_; my %tmp = ( nocommand => [ \&extonly, undef ], delete => [ \&delete, undef ], transfer_request => [ \&transfer_request, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub extonly { my ( $epp, $domain, $rd ) = @_; my $transaction; $transaction = $rd->{transactionname} if $rd->{transactionname}; return unless ($transaction); my $mes = $epp->message(); Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); ##$mes->command_body([['domain:name',$domain]]); ## Useless if pure extension my $eid = $mes->command_extension_register( 'command', 'xmlns="' . $ExtNS . '" xsi:schemaLocation="' . $ExtNS . ' at-ext-epp-1.0.xsd"' ); my $cltrid=$mes->cltrid(); if ( $transaction eq 'withdraw' ) { my %domns; $domns{'xmlns:domain'} = $NS; $domns{'xsi:schemaLocation'} = $NS . ' at-ext-domain-1.0.xsd'; my %zdhash; $zdhash{'value'} = $rd->{zd} ? $rd->{zd} : 0; $mes->command_extension( $eid, [ ['withdraw', [ 'domain:withdraw', ['domain:name', $domain], \%domns , ['domain:zd', \%zdhash], \%domns ]], ['clTRID', $cltrid ] ] ); } elsif ( $transaction eq 'transfer_execute' ) { my $token; $token = $rd->{token} if $rd->{token}; return unless ( defined($token) ); my %domns; $domns{'xmlns:domain'} = 'urn:ietf:params:xml:ns:domain-1.0'; $domns{'xsi:schemaLocation'} = 'urn:ietf:params:xml:ns:domain-1.0 domain-1.0.xsd'; my %domns2; $domns2{'xmlns:at-ext-domain'} = $NS; $domns2{'xsi:schemaLocation'} = $NS . ' at-ext-domain-1.0.xsd'; $mes->command_extension( $eid, [ ['transfer', { 'op' => 'execute' }, [ 'domain:transfer', \%domns, [ 'domain:name', $domain ] ] ], ['extension', ['at-ext-domain:transfer' , \%domns2, ['at-ext-domain:token',$token] ] ], ['clTRID', $cltrid] ] ); } } sub delete { my ( $epp, $domain, $rd ) = @_; my $mes = $epp->message(); my $scheduledate; $scheduledate = $rd->{scheduledate} if $rd->{scheduledate}; return unless ( defined($scheduledate) ); my $eid = $mes->command_extension_register( 'at-ext-domain:delete', 'xmlns:at-ext-domain="' . $NS . '" xsi:schemaLocation="' . $NS . ' at-ext-domain-1.0.xsd"' ); $mes->command_extension( $eid, [ 'at-ext-domain:scheduledate', $scheduledate ] ); } sub transfer_request { my ( $epp, $domain, $rd ) = @_; my $mes = $epp->message(); my $registrarinfo; $registrarinfo = $rd->{registrarinfo} if $rd->{registrarinfo}; return unless ( defined($registrarinfo) ); my $eid = $mes->command_extension_register( 'at-ext-domain:clientdata', 'xmlns:at-ext-domain="' . $NS . '" xsi:schemaLocation="' . $NS . ' at-ext-domain-1.0.xsd"' ); my %entryname; $entryname{name} = 'Registrarinfo'; $mes->command_extension( $eid, [ 'at-ext-domain:entry', \%entryname, $registrarinfo ] ); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AT/IOptions.pm0000644000175000017500000000736311352534377023415 0ustar patrickpatrick## Domain Registry Interface, ENUM.AT Options extension ## Contributed by Michael Braunoeder from ENUM.AT ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AT::IOptions; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='http://www.enum.at/rxsd/ienum43-options-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AT::IOptions - ENUM.AT Options EPP Mapping for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&parse_options ], update => [ \&set_options, undef ], #create => [ \&set_options, undef ], ); return { 'domain' => \%tmp }; } sub capabilities_add { return ('domain_update','options',['set']); } sub parse_options { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); my $condata=$mes->get_extension($NS,'options'); return unless $condata; my @options; foreach my $el ($condata->getElementsByTagNameNS($NS,'naptr-application')) { my %opts; my $c=$el->getFirstChild(); $opts{'naptr_application_origin'} =$el->getAttribute('origin') if (defined $el->getAttribute('origin')); $opts{'naptr_application_wildcard'}=$el->getAttribute('wildcard') if (defined $el->getAttribute('wildcard')); push @options,\%opts; } $rinfo->{domain}->{$oname}->{options}=\@options; } sub set_options { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $roptions=$rd->set('options'); return unless (defined($roptions) && (ref($roptions) eq 'HASH') && keys(%$roptions)); my %options; foreach my $d ('origin','wildcard') { next unless exists($roptions->{'naptr_application_'.$d}); Net::DRI::Exception::usererr_invalid_paramaters("Option naptr_application_${d} must be of an XML boolean") unless Net::DRI::Utils::xml_is_boolean($roptions->{'naptr_application_'.$d}); $options{$d}=$roptions->{'naptr_application_'.$d}; } return unless keys(%options); my $eid=$mes->command_extension_register('ienum43:update','xmlns:ienum43="'.$NS.'" xsi:schemaLocation="'.$NS.' ienum43-options-1.0.xsd"'); $mes->command_extension($eid,[['ienum43:options',['ienum43:naptr-application',\%options]]]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AT/Message.pm0000644000175000017500000001345511352534377023234 0ustar patrickpatrick## Domain Registry Interface, nic.at domain transactions extension ## Contributed by Michael Braunoeder from NIC.AT ## Extended by Tonnerre Lombard ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AT::Message; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='http://www.nic.at/xsd/at-ext-message-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AT::Message - NIC.AT Message EPP Mapping for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( atretrieve => [ \&pollreq, \&parse_poll ], atdelete => [ \&pollack, undef ], ); return { 'message' => \%tmp }; } sub pollack { my ($epp,$msgid)=@_; my $mes=$epp->message(); $mes->command([['poll',{op=>'ack',msgID=>$msgid}]]); } sub pollreq { my ($epp,$msgid)=@_; Net::DRI::Exception::usererr_invalid_parameters('In EPP, you can not specify the message id you want to retrieve') if defined($msgid); my $mes=$epp->message(); $mes->command([['poll',{op=>'req'}]]); } ## We take into account all parse functions, to be able to parse any result sub parse_poll { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); my $eppNS = $mes->ns('_main'); my $resNS = 'http://www.nic.at/xsd/at-ext-result-1.0'; return unless $mes->is_success(); return if ($mes->result_code() == 1300); # no messages in queue my $msgid=$mes->msg_id(); $rinfo->{message}->{session}->{last_id}=$msgid; my $mesdata=$mes->get_response($NS,'message'); $rinfo->{$otype}->{$oname}->{message}=$mesdata; return unless $mesdata; my ($epp,$rep,$ext,$ctag,@conds,@tags); my $command=$mesdata->getAttribute('type'); @tags = $mesdata->getElementsByTagNameNS($NS, 'desc'); $rinfo->{message}->{$msgid}->{content} = $tags[0]->getFirstChild()->getData() if @tags; @tags = $mesdata->getElementsByTagNameNS($NS, 'data'); return unless @tags; my $data = $tags[0]; @tags = $data->getElementsByTagNameNS($NS, 'entry'); foreach my $entry (@tags) { next unless (defined($entry->getAttribute('name'))); if ($entry->getAttribute('name') eq 'objecttype') { $rinfo->{message}->{$msgid}->{object_type} = $entry->getFirstChild()->getData(); } elsif ($entry->getAttribute('name') eq 'command') { $rinfo->{message}->{$msgid}->{action} = $entry->getFirstChild()->getData(); } elsif ($entry->getAttribute('name') eq 'objectname') { $rinfo->{message}->{$msgid}->{object_id} = $entry->getFirstChild()->getData(); } elsif ($entry->getAttribute('name') =~ /^(domain|contact|host)$/) { my $text = $entry->getFirstChild(); $rinfo->{message}->{$msgid}->{object_type}=$1; $rinfo->{message}->{$msgid}->{object_id} = $text->getData() if (defined($text)); } } $rinfo->{message}->{$msgid}->{action} ||= $command; @tags = $data->getElementsByTagNameNS($eppNS, 'epp'); return unless (@tags); $epp = $tags[0]; @tags = $epp->getElementsByTagNameNS($eppNS, 'response'); return unless (@tags); $rep = $tags[0]; @tags = $rep->getElementsByTagNameNS($eppNS, 'extension'); return unless (@tags); $ext = $tags[0]; foreach my $node ($ext->childNodes()) { my $name = $node->localName() || $node->nodeName(); if ($name eq 'conditions') { @tags = $node->getElementsByTagNameNS($resNS, 'condition'); foreach my $cond (@tags) { my %con; my $c = $cond->getFirstChild(); $con{code} = $cond->getAttribute('code') if ($cond->getAttribute('code')); $con{severity} = $cond->getAttribute('severity') if ($cond->getAttribute('severity')); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $cname = $c->localname() || $c->nodeName(); next unless $cname; if ($cname =~ m/^(msg|details)$/) { $con{$1} = $c->getFirstChild()->getData(); } elsif ($cname eq 'attributes') { foreach my $attr ($c->getChildrenByTagNameNS($NS,'attr')) { my $attrname = $attr->getAttribute('name'); $con{'attr ' . $attrname} = $attr->getFirstChild()->getData(); } } } continue { $c = $c->getNextSibling(); } push(@conds, \%con); } } elsif ($name eq 'keydate') { $rinfo->{message}->{$msgid}->{keydate} = $node->getFirstChild()->getData(); } } $rinfo->{message}->{$msgid}->{conditions} = \@conds; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SIDN.pm0000644000175000017500000000572611352534377022103 0ustar patrickpatrick## Domain Registry Interface, SIDN (.NL) EPP extensions ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SIDN; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Util; use Net::DRI::Data::Contact::SIDN; use Net::DRI::Protocol::EPP::Extensions::SIDN::Message; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub setup { my ($self,$rp)=@_; my $version=$self->version(); $self->ns({sidn=>['http://rxsd.domain-registry.nl/sidn-ext-epp-1.0','sidn-ext-epp-1.0.xsd']}); $self->capabilities('domain_update','status',undef); ## No changes in status possible $self->capabilities('contact_update','status',undef); $self->capabilities('contact_update','disclose',undef); $self->capabilities('host_update','status',undef); $self->capabilities('host_update','name',undef); $self->factories('message',sub { my $m=Net::DRI::Protocol::EPP::Extensions::SIDN::Message->new(@_); $m->ns($self->{ns}); $m->version($version); return $m;} ); $self->factories('contact',sub { return Net::DRI::Data::Contact::SIDN->new(); }); $self->default_parameters({domain_create => { auth => { pw => '' } } }); ## authInfo not used by SIDN return; } sub core_contact_types { return ('admin','tech'); } ## No billing contact in .NL sub default_extensions { return qw/SIDN::Domain SIDN::Contact SIDN::Host SIDN::Notifications/; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SIDN - SIDN (.NL) EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AFNIC.pm0000644000175000017500000000557111352534377022164 0ustar patrickpatrick## Domain Registry Interface, AFNIC (.FR/.RE) EPP extensions ## From http://www.afnic.fr/data/divers/public/afnic-epp-rc1.pdf (2008-06-30) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AFNIC; use strict; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::AFNIC; use Net::DRI::Protocol::EPP::Extensions::AFNIC::Status; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AFNIC - AFNIC (.FR/.RE) EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({frnic=>['http://www.afnic.fr/xml/epp/frnic-1.0','frnic-1.0.xsd']}); $self->capabilities('domain_update','registrant',undef); ## a trade is required $self->capabilities('contact_update','status',undef); ## No changes in status possible for .FR contacts $self->capabilities('contact_update','disclose',['add','del']); $self->factories('contact',sub { return Net::DRI::Data::Contact::AFNIC->new(); }); $self->factories('status',sub { return Net::DRI::Protocol::EPP::Extensions::AFNIC::Status->new(); }); $self->default_parameters({domain_create => { ns => undef } }); ## No nameservers allowed during domain create return; } sub core_contact_types { return ('admin','tech'); } ## No billing contact in .FR sub default_extensions { return qw/AFNIC::Domain AFNIC::Contact AFNIC::Notifications GracePeriod/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/BR.pm0000644000175000017500000000504211352534377021640 0ustar patrickpatrick## Domain Registry Interface, .BR EPP extensions ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::BR; use strict; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::BR; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::BR - .BR EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({brdomain=> ['urn:ietf:params:xml:ns:brdomain-1.0','brdomain-1.0.xsd'], brorg => ['urn:ietf:params:xml:ns:brorg-1.0','brorg-1.0.xsd'], }); $self->capabilities('domain_update','ticket',['set']); $self->capabilities('domain_update','release',['set']); $self->capabilities('domain_update','auto_renew',['set']); $self->capabilities('contact_update','associated_contacts',['add','del']); $self->capabilities('contact_update','responsible',['set']); $self->factories('contact',sub { return Net::DRI::Data::Contact::BR->new(); }); return; } sub default_extensions { return qw/BR::Domain BR::Contact SecDNS/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/IT/0002755000175000017500000000000011352534417021307 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/IT/Contact.pm0000644000175000017500000000500611352534377023244 0ustar patrickpatrick## Domain Registry Interface, .IT Contact EPP extension ## ## Copyright (C) 2009-2010 Tower Technologies. All rights reserved. ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License v2. # # # package Net::DRI::Protocol::EPP::Extensions::IT::Contact; use strict; use warnings; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::IT::Contact - .IT EPP Contact extension for Net::DRI =head1 SUPPORT For now, support questions should be sent to: Enoc@towertech.itE Please also see the SUPPORT file in the distribution. =head1 AUTHOR Alessandro Zummo, Ea.zummo@towertech.itE =head1 COPYRIGHT Copyright (C) 2009-2010 Tower Technologies. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License v2 as published by the Free Software Foundation. See the LICENSE file that comes with this distribution for more details. =cut sub register_commands { my ($class, $version) = @_; my $ops = { 'create' => [ \&create, undef ], }; return { 'contact' => $ops }; } sub build_command_extension { my ($msg, $epp, $tag) = @_; return $msg->command_extension_register($tag, sprintf('xmlns:extcon="%s" xsi:schemaLocation="%s %s"', $msg->nsattrs('it_contact'))); } sub fix_contact { my ($epp, $c, $op) = @_; my $msg = $epp->message; my $eid = build_command_extension($msg, $epp, 'extcon:' . $op); my @ext; push @ext, [ 'extcon:consentForPublishing', $c->consent_for_publishing ] if defined $c->consent_for_publishing; # registrant data (do not alter the order, there's people # who likes to use in xsds) my @registrant; push @registrant, [ 'extcon:nationalityCode', $c->nationality_code ] if defined $c->nationality_code; push @registrant, [ 'extcon:entityType', $c->entity_type ] if defined $c->entity_type; push @registrant, [ 'extcon:regCode', $c->reg_code ] if defined $c->reg_code; push @ext, [ 'extcon:registrant', @registrant ] if scalar @registrant; $msg->command_extension($eid, [ @ext ]) if scalar @ext; } sub create { my ($epp, $contact) = @_; return fix_contact($epp, $contact, 'create'); } 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/IT/Domain.pm0000644000175000017500000000441711352534377023065 0ustar patrickpatrick## Domain Registry Interface, .IT Domain extension ## ## Copyright (C) 2009-2010 Tower Technologies. All rights reserved. ## ## This program free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License v2. ## # # # package Net::DRI::Protocol::EPP::Extensions::IT::Domain; use strict; use warnings; our $VERSION = do { my @r = ( q$Revision: 1.1 $ =~ /\d+/gxm ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::IT::Domain - .IT EPP Domain extension for Net::DRI =head1 SUPPORT For now, support questions should be sent to: Enoc@towertech.itE Please also see the SUPPORT file in the distribution. =head1 AUTHOR Alessandro Zummo, Ea.zummo@towertech.itE =head1 COPYRIGHT Copyright (C) 2009-2010 Tower Technologies. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License v2 as published by the Free Software Foundation. See the LICENSE file that comes with this distribution for more details. =cut sub register_commands { my ($class, $version) = @_; my $ops = { 'info' => [ undef, \&parse ], }; return { 'domain' => $ops, }; } sub parse { my ($po, $type, $action, $name, $info) = @_; my $msg = $po->message; my $ns = $msg->ns('it_domain'); my $infdata = $msg->get_extension('it_domain', 'infData'); my $infns = $msg->get_extension('it_domain', 'infNsToValidateData'); if (defined $infdata) { $info->{'domain'}{$name}{'own_status'} = $infdata->getChildrenByTagNameNS($ns, 'ownStatus') ->shift ->getAttribute('s'); } if (defined $infns) { # cannot match ./extdom:nsToValidate/domain:hostAttr/domain:hostName # due to mixed namespace foreach ($infns->findnodes('./extdom:nsToValidate/*/*')) { push(@{$info->{'domain'}{$name}{'ns_to_validate'}}, $_->textContent) if $_->getName eq 'domain:hostName'; } } return 1; } 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/IT/Notifications.pm0000644000175000017500000001153211352534377024463 0ustar patrickpatrick## Domain Registry Interface, .IT message extensions ## ## Copyright (C) 2009-2010 Tower Technologies. All rights reserved. ## ## This program free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License v2. ## # # # package Net::DRI::Protocol::EPP::Extensions::IT::Notifications; use strict; use warnings; our $VERSION = do { my @r = ( q$Revision: 1.1 $ =~ /\d+/gmx ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::IT::Notifications - .IT EPP Notifications Parsing for Net::DRI =head1 SUPPORT For now, support questions should be sent to: Enoc@towertech.itE Please also see the SUPPORT file in the distribution. =head1 AUTHOR Alessandro Zummo, Ea.zummo@towertech.itE =head1 COPYRIGHT Copyright (C) 2009-2010 Tower Technologies. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License v2 as published by the Free Software Foundation. See the LICENSE file that comes with this distribution for more details. =cut sub register_commands { my ($class, $version) = @_; my $ops = { 'review_credit' => [ undef, \&parse_credit ], 'review_passwd' => [ undef, \&parse_reminder ], 'review_simple' => [ undef, \&parse_simple ], 'review_change' => [ undef, \&parse_chgstatus ], 'review_dnserror' => [ undef, \&parse_dnserror ], }; return { 'message' => $ops, }; } sub retrieve_ext { my ($po,$ns,$node)=@_; my $msg = $po->message; return unless $msg->is_success; my $ext = $msg->get_extension($ns,$node); return unless defined $ext; my $id = $msg->msg_id; return ($ext,$id); } sub parse_credit { my ($po, $type, $action, $name, $rinfo) = @_; my ($ext,$id)=retrieve_ext('it_epp','creditMsgData'); return unless defined $ext; $rinfo->{'message'}->{$id}->{credit}=($ext->getElementsByTagName('extepp:credit'))[0]->textContent; ## TODO: use xml_child_content() instead } sub parse_reminder { my ($po, $type, $action, $name, $rinfo) = @_; my ($ext,$id)=retrieve_ext('it_epp','passwdReminder'); return unless defined $ext; $rinfo->{'message'}->{$id}->{'passwd_expires_on'}= ($ext->getElementsByTagName('extepp:exDate'))[0]->textContent; ## TODO: use xml_child_content() instead + convert date to DateTime object ? } sub parse_simple { my ($po, $type, $action, $name, $rinfo) = @_; my ($ext,$id)=retrieve_ext('it_domain','simpleMsgData'); return unless defined $ext; $rinfo->{'message'}->{$id}->{'domain'}=($ext->getElementsByTagName('extdom:name'))[0]->textContent; ## TODO: use xml_child_content() instead } sub parse_chgstatus { my ($po, $type, $action, $name, $rinfo) = @_; my ($ext,$id)=retrieve_ext('it_domain','chgStatusMsgData'); return unless defined $ext; $rinfo->{'message'}->{$id}->{'domain'}=($ext->getElementsByTagName('extdom:name'))[0]->textContent; ## TODO: use xml_child_content() instead foreach ($ext->findnodes('//extdom:targetStatus/*')) { $rinfo->{'message'}->{$id}->{'status'} = $_->getAttribute('s') if $_->nodeName eq 'domain:status'; $rinfo->{'message'}->{$id}->{'own_status'} = $_->getAttribute('s') if $_->nodeName eq 'extdom:ownStatus'; ## TODO : what is the difference between the two statuses ? + create a true StatusList object } } sub parse_dnserror { my ($po, $type, $action, $name, $rinfo) = @_; my ($ext,$id)=retrieve_ext('it_domain','dnsErrorMsgData'); return unless defined $ext; $rinfo->{'message'}->{$id}->{'domain'} = ($ext->getElementsByTagName('extdom:domain'))[0] ->getAttribute('name'); ## TODO: use xml_child_content() instead $rinfo->{'message'}->{$id}->{'status'} = ($ext->getElementsByTagName('extdom:domain'))[0] ->getAttribute('status'); ## TODO: use xml_child_content() instead $rinfo->{'message'}->{$id}->{'response_id'} = ($ext->getElementsByTagName('extdom:responseId'))[0]->textContent; ## TODO: use xml_child_content() instead $rinfo->{'message'}->{$id}->{'validation_date'} = ($ext->getElementsByTagName('extdom:validationDate'))[0]->textContent; ## TODO: use xml_child_content() instead foreach my $test ($ext->findnodes('//extdom:test')) { my $name = $test->getAttribute('name'); $rinfo->{'message'}->{$id}->{'test'}{$name}{'status'} = $test->getAttribute('status'); foreach my $dns ($test->findnodes('./extdom:dns')) { $rinfo->{'message'}->{$id}->{'test'}{$name}{'dns'}{$dns->getAttribute('name')} = $dns->getAttribute('status'); } } } 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NAME.pm0000644000175000017500000000436611352534377022065 0ustar patrickpatrick## Domain Registry Interface, .NAME EPP extensions ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NAME; use strict; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Protocol::EPP::Extensions::NAME::EmailFwd; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NAME - .NAME EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E or Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ emailFwd => ['http://www.nic.name/epp/emailFwd-1.0','emailFwd-1.0.xsd'] }); $self->capabilities('emailfwd_update','info',['set']); return; } sub default_extensions { return qw/NAME::EmailFwd/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/E164Validation/0002755000175000017500000000000011352534417023425 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/E164Validation/RFC5076.pm0000644000175000017500000001073411352534377024727 0ustar patrickpatrick## Domain Registry Interface, EPP E.164 Validation Information Example from RFC5076 ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::E164Validation::RFC5076; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='urn:ietf:params:xml:ns:e164valex-1.1'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::E164Validation::RFC5076 - EPP E.164 Validation Information Example from RFC5076 for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub load { return $NS; } sub info_parse { my ($class,$po,$top)=@_; Net::DRI::Exception::usererr_insufficient_parameters('Root element for information validation of URI='.$NS.' must be simpleVal') unless (($top->localname() || $top->nodeName()) eq 'simpleVal'); my %n; foreach my $el (Net::DRI::Util::xml_list_children($top)) { my ($name,$c)=@$el; if ($name=~m/^(methodID|validationEntityID|registrarID)$/) { $n{Net::DRI::Util::remcam($1)}=$c->textContent(); } elsif ($name=~m/^(executionDate|expirationDate)$/) { $n{Net::DRI::Util::remcam($1)}=$po->parse_iso8601($c->textContent()); } } return \%n; } sub output_date { my $d=shift; return unless defined($d); if (UNIVERSAL::isa($d,'DateTime')) { return $d->strftime('%Y-%m-%d'); } else { return unless ($d=~m/^\d{4}-\d{2}-\d{2}$/); return $d; } } sub create { my ($class,$rd)=@_; my @c; Net::DRI::Exception::usererr_insufficient_parameters('method_id and execution_date are mandatory in validation information') unless (exists $rd->{method_id} && exists $rd->{execution_date}); Net::DRI::Exception::usererr_invalid_parameters('method_id must be an xml token from 1 to 63 characters') unless Net::DRI::Util::xml_is_token($rd->{method_id},1,63); push @c,['valex:methodID',$rd->{method_id}]; if (exists $rd->{validation_entity_id}) { Net::DRI::Exception::usererr_invalid_parameters('validation_entity_id must be an xml token from 3 to 16 characters') unless Net::DRI::Util::xml_is_token($rd->{validation_entity_id},3,16); push @c,['valex:validationEntityID',$rd->{validation_entity_id}]; } if (exists $rd->{registrar_id}) { Net::DRI::Exception::usererr_invalid_parameters('registrar_id must be an xml token from 3 to 16 characters') unless Net::DRI::Util::xml_is_token($rd->{registrar_id},3,16); push @c,['valex:registrarID',$rd->{registrar_id}]; } my $d=output_date($rd->{execution_date}); Net::DRI::Exception::usererr_invalid_parameters('execution_date must be a DateTime object or a string like YYYY-MM-DD') unless defined($d); push @c,['valex:executionDate',$d]; if (exists $rd->{expiration_date}) { $d=output_date($rd->{expiration_date}); Net::DRI::Exception::usererr_invalid_parameters('expiration_date must be a DateTime object or a string like YYYY-MM-DD') unless defined($d); push @c,['valex:expirationDate',$d]; } return ['valex:simpleVal',{'xmlns:valex' => $NS},@c]; } sub renew { return create(@_); } sub transfer { return create(@_); } sub update { return create(@_); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/LU/0002755000175000017500000000000011352534417021313 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/LU/Status.pm0000644000175000017500000000474011352534377023144 0ustar patrickpatrick## Domain Registry Interface, EPP Status for .LU ## ## Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::LU::Status; use base qw!Net::DRI::Protocol::EPP::Core::Status!; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::LU::Status - EPP .LU Status for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new(shift); bless($self,$class); ## .LU accepts only some EPP status, and adds inactive, serverTradeProhibited, serverRestoreProhibited my %s=( 'renew' => 'clientRenewProhibited', 'publish' => 'clientHold', 'active' => 'inactive', ); $self->_register_pno(\%s); ## this will overwrite what has been done in SUPER::new return $self; } sub is_core_status { return (shift=~m/^(?:client(?:Hold|(?:Delete|Renew|Update|Transfer)Prohibited)|inactive)$/); } sub is_active { return shift->has_not('inactive'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/LU/Contact.pm0000644000175000017500000001236511352534377023256 0ustar patrickpatrick## Domain Registry Interface, .LU Contact EPP extension commands ## ## Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::LU::Contact; use strict; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::LU::Contact - .LU EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], create => [ \&create, undef ], update => [ \&update, undef ], ); return { 'contact' => \%tmp }; } sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:dnslu="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('dnslu'))); } #################################################################################################### sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('dnslu','ext'); return unless $infdata; my $ns=$mes->ns('dnslu'); $infdata=$infdata->getChildrenByTagNameNS($ns,'resData'); return unless $infdata->size(); $infdata=$infdata->shift()->getChildrenByTagNameNS($ns,'infData'); return unless $infdata->size(); $infdata=$infdata->shift()->getChildrenByTagNameNS($ns,'contact'); return unless $infdata->size(); $infdata=$infdata->shift(); my $co=$rinfo->{contact}->{$oname}->{self}; my $t=$infdata->getChildrenByTagNameNS($ns,'type'); $co->type($t->shift->getFirstChild()->getData()) if $t->size(); my $c=$infdata->getChildrenByTagNameNS($ns,'disclose'); if ($c->size()) { $c=$c->shift()->getFirstChild(); $co->disclose({}) unless defined($co->disclose()); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; $co->disclose()->{$name.'_loc'}=$c->getAttribute('flag'); } continue { $c=$c->getNextSibling(); } } } sub build_disclose { my ($rd,$type)=@_; return () unless (defined($rd) && (ref($rd) eq 'HASH') && %$rd); my @d=(); push @d,['dnslu:name',{flag=>$rd->{name_loc}}] if (exists($rd->{name_loc}) && Net::DRI::Util::xml_is_boolean($rd->{name_loc})); push @d,['dnslu:addr',{flag=>$rd->{addr_loc}}] if (exists($rd->{addr_loc}) && Net::DRI::Util::xml_is_boolean($rd->{addr_loc})); if ($type eq 'contact') { push @d,['dnslu:org',{flag=>$rd->{org_loc}}] if (exists($rd->{org_loc}) && Net::DRI::Util::xml_is_boolean($rd->{org_loc})); push @d,['dnslu:voice',{flag=>$rd->{voice}}] if (exists($rd->{voice}) && Net::DRI::Util::xml_is_boolean($rd->{voice})); push @d,['dnslu:fax',{flag=>$rd->{fax}}] if (exists($rd->{fax}) && Net::DRI::Util::xml_is_boolean($rd->{fax})); push @d,['dnslu:email',{flag=>$rd->{email}}] if (exists($rd->{email}) && Net::DRI::Util::xml_is_boolean($rd->{email})); } return \@d; } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); ## validate() has been called, we are sure that type exists my @n; push @n,['dnslu:type',$contact->type()]; my $rd=build_disclose($contact->disclose(),$contact->type()); push @n,['dnslu:disclose',@$rd] if $rd; my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:create',['dnslu:contact',@n]]); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my @n; push @n,['dnslu:add',['dnslu:disclose',@{build_disclose($todo->add('disclose'),'contact')}]] if $todo->add('disclose'); push @n,['dnslu:rem',['dnslu:disclose',@{build_disclose($todo->del('disclose'),'contact')}]] if $todo->del('disclose'); return unless @n; my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:update',['dnslu:contact',@n]]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/LU/Domain.pm0000644000175000017500000003127611352534377023074 0ustar patrickpatrick## Domain Registry Interface, .LU Domain EPP extension commands ## ## Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::LU::Domain; use strict; use Net::DRI::Exception; use Net::DRI::Util; use DateTime::Format::ISO8601; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::LU::Domain - .LU EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], create => [ \&create, undef ], update => [ \&update, undef ], delete => [ \&delete, undef ], restore => [ \&restore, undef ], transfer_request => [ \&transfer_request, \&transfer_parse ], transfer_query => [ undef , \&transfer_parse ], trade_request => [ \&trade_request , \&trade_parse ], trade_query => [ \&trade_query , \&trade_parse ], trade_cancel => [ \&trade_cancel , undef ], transfer_trade_request => [ \&transfer_trade_request, \&transfer_trade_parse ], transfer_trade_query => [ \&transfer_trade_query , \&transfer_trade_parse ], transfer_trade_cancel => [ \&transfer_trade_cancel , undef ], transfer_restore_request => [ \&transfer_restore_request, \&transfer_restore_parse ], transfer_restore_query => [ \&transfer_restore_query , \&transfer_restore_parse ], transfer_restore_cancel => [ \&transfer_restore_cancel , undef ], ); return { 'domain' => \%tmp }; } sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:dnslu="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('dnslu'))); } #################################################################################################### sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('dnslu','ext'); return unless $infdata; my $ns=$mes->ns('dnslu'); $infdata=$infdata->getChildrenByTagNameNS($ns,'resData'); return unless $infdata->size(); $infdata=$infdata->shift()->getChildrenByTagNameNS($ns,'infData'); return unless $infdata->size(); $infdata=$infdata->shift()->getChildrenByTagNameNS($ns,'domain'); return unless $infdata->size(); my $pd=DateTime::Format::ISO8601->new(); my $c=$infdata->shift()->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'idn') { ## currently not used } elsif ($name eq 'status') { $rinfo->{domain}->{$oname}->{status}->add($c->getFirstChild()->getData()); } elsif ($name eq 'crReqID') { $rinfo->{domain}->{$oname}->{$name}=$c->getFirstChild()->getData(); } elsif ($name=~m/^(crReqDate|delReqDate|delDate)$/) { $rinfo->{domain}->{$oname}->{$name}=$pd->parse_datetime($c->getFirstChild()->getData()); } } continue { $c=$c->getNextSibling(); } } sub verify_contacts { my $rd=shift; Net::DRI::Exception::usererr_invalid_parameters('.LU needs contact for domain_create/domain_transfer/domain_trade') unless Net::DRI::Util::has_contact($rd); my @t=$rd->{contact}->types(); Net::DRI::Exception::usererr_invalid_parameters('.LU needs registrant, admin and tech contacts only') unless ($t[0] eq 'admin' && $t[1] eq 'registrant' && $t[2] eq 'tech'); foreach my $t (qw/registrant admin tech/) { my @t=$rd->{contact}->get($t); Net::DRI::Exception::usererr_invalid_parameters('.LU needs only one contact of type '.$t) unless @t==1; } } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); verify_contacts($rd); ## idn is not handled return unless Net::DRI::Util::has_key($rd,'status'); my @n=map { ['dnslu:status',{ s => $_ }] } (Net::DRI::Util::isa_statuslist($rd->{status})? $rd->{status}->list_status() : @{$rd->{status}}); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:create',['dnslu:domain',@n]]); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my @n; my $sadd=$todo->add('status'); my $sdel=$todo->del('status'); my (@add,@del); push @add,$sadd->build_xml('dnslu:status','dnslu') if $sadd; push @del,$sdel->build_xml('dnslu:status','dnslu') if $sdel; push @n,['dnslu:add',@add] if @add; push @n,['dnslu:rem',@del] if @del; return unless @n; my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:update',['dnslu:domain',@n]]); } sub delete { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless (defined($rd) && ref($rd) && exists($rd->{delDate}) && ($rd->{delDate}=~m/^(?:immediate|cancel)$/ || UNIVERSAL::isa($rd->{delDate},'DateTime'))); my @n; if ($rd->{delDate}=~m/^(?:immediate|cancel)$/) { @n=['dnslu:op',$rd->{delDate}]; } else { @n=['dnslu:op','setDate']; push @n,['dnslu:delDate',$rd->{delDate}->set_time_zone('UTC')->strftime('%Y-%m-%dT%TZ')]; } my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:delete',['dnslu:domain',@n]]); } sub build_command { my ($domain)=@_; Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless (defined($domain) && $domain && !ref($domain)); Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); Net::DRI::Exception->die(1,'protocol/EPP',10,'Domain name not in .LU: '.$domain) unless $domain=~m/\.LU$/i; return ['dnslu:name',$domain]; } sub restore { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:restore',['dnslu:domain',build_command($domain)]]]); } sub build_transfer_trade_restore { my ($rd)=@_; my @n; verify_contacts($rd); push @n,['dnslu:ns',map { ['dnslu:hostObj',$_] } $rd->{ns}->get_names() ] if Net::DRI::Util::has_ns($rd); my $cs=$rd->{contact}; push @n,['dnslu:registrant',$cs->get('registrant')->srid()]; push @n,['dnslu:contact',{type => 'admin'},$cs->get('admin')->srid()]; push @n,['dnslu:contact',{type => 'tech'},$cs->get('tech')->srid()]; push @n,map { ['dnslu:status',{ s => $_ }] } (Net::DRI::Util::isa_statuslist($rd->{status})? $rd->{status}->list_status() : @{$rd->{status}}) if Net::DRI::Util::has_key($rd,'status'); ## IDN not used push @n,['dnslu:trDate',$rd->{trDate}->set_time_zone('UTC')->strftime('%Y-%m-%d')] if (exists($rd->{trDate}) && defined($rd->{trDate}) && Net::DRI::Util::check_isa($rd->{trDate},'DateTime')); return @n; } sub transfer_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:transfer',['dnslu:domain',build_transfer_trade_restore($rd)]]); } sub transfer_parse ## for request & query { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); parse_transfer_trade_restore($po,$otype,$oaction,$oname,$rinfo,'trnData'); } sub parse_transfer_trade_restore { my ($po,$otype,$oaction,$oname,$rinfo,$s)=@_; my $mes=$po->message(); my $infdata=$mes->get_extension('dnslu','ext'); return unless $infdata; my $ns=$mes->ns('dnslu'); $infdata=$infdata->getChildrenByTagNameNS($ns,'resData'); return unless $infdata->size(); $infdata=$infdata->shift()->getChildrenByTagNameNS($ns,$s); return unless $infdata->size(); $infdata=$infdata->shift()->getChildrenByTagNameNS($ns,'domain'); return unless $infdata->size(); my $pd=DateTime::Format::ISO8601->new(); my $c=$infdata->shift->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'idn') { ## currently not used } elsif ($name=~m/^(trStatus|reID)$/) { $rinfo->{domain}->{$oname}->{$name}=$c->getFirstChild()->getData(); } elsif ($name=~m/^(reDate|acDate|trDate)$/) { $rinfo->{domain}->{$oname}->{$name}=$pd->parse_datetime($c->getFirstChild()->getData()); } } continue { $c=$c->getNextSibling(); } } sub trade_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:trade',{op=>'request'},['dnslu:domain',build_command($domain),build_transfer_trade_restore($rd)]]]); } sub trade_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); parse_transfer_trade_restore($po,$otype,$oaction,$oname,$rinfo,'traData'); } sub trade_query { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:trade',{op=>'query'},['dnslu:domain',build_command($domain)]]]); } sub trade_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:trade',{op=>'cancel'},['dnslu:domain',build_command($domain)]]]); } sub transfer_trade_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:transferTrade',{op=>'request'},['dnslu:domain',build_command($domain),build_transfer_trade_restore($rd)]]]); } sub transfer_trade_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); parse_transfer_trade_restore($po,$otype,$oaction,$oname,$rinfo,'trnTraData'); } sub transfer_trade_query { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:transferTrade',{op=>'query'},['dnslu:domain',build_command($domain)]]]); } sub transfer_trade_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:transferTrade',{op=>'cancel'},['dnslu:domain',build_command($domain)]]]); } sub transfer_restore_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:transferRestore',{op=>'request'},['dnslu:domain',build_command($domain),build_transfer_trade_restore($rd)]]]); } sub transfer_restore_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); parse_transfer_trade_restore($po,$otype,$oaction,$oname,$rinfo,'trnResData'); } sub transfer_restore_query { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:transferRestore',{op=>'query'},['dnslu:domain',build_command($domain)]]]); } sub transfer_restore_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'dnslu:ext'); $mes->command_extension($eid,['dnslu:command',['dnslu:transferRestore',{op=>'cancel'},['dnslu:domain',build_command($domain)]]]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/LU/Poll.pm0000644000175000017500000000646711352534377022577 0ustar patrickpatrick## Domain Registry Interface, EPP DNS-LU Poll extensions ## ## Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::LU::Poll; use strict; use Net::DRI::Util; use DateTime::Format::ISO8601; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::LU::Poll - EPP DNS-LU Poll extensions (DocRegistrar-2.0.6.pdf pages 35-37) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( dnslu => [ undef, \&parse ], ); return { 'message' => \%tmp }; } #################################################################################################### sub parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->node_msg(); return unless $infdata; my $pollmsg=$infdata->getFirstChild(); my %w=(action => 'dnslu_notification', type => $infdata->getAttribute('type')); ## list of types p.36 $w{type}=$pollmsg->getAttribute('type') if (!defined($w{type}) && $pollmsg->localname() eq 'pollmsg'); my (%ns,%e); my $c=$pollmsg->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name=~m/^(roid|object|clTRID|svTRID|reason)$/) { $w{$name}=$c->getFirstChild()->getData(); } elsif ($name eq 'exDate') { $w{$name}=DateTime::Format::ISO8601->new()->parse_datetime($c->getFirstChild()->getData()); } elsif ($name eq 'ns') { $ns{$c->getAttribute('name')}=$c->getFirstChild()->getData(); } elsif ($name eq 'extra') { $e{$c->getAttribute('name')}=$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } $w{ns}=\%ns if %ns; $w{extra}=\%e if %e; $rinfo->{session}->{notification}=\%w; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/ARNES/0002755000175000017500000000000011352534417021643 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/ARNES/Contact.pm0000644000175000017500000000721011352534377023577 0ustar patrickpatrick## Domain Registry Interface, ARNES (.SI) Contact EPP extension commands ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::ARNES::Contact; use strict; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::ARNES::Contact - ARNES (.SI) EPP Contact extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], info => [ undef, \&info_parse ], ); return { 'contact' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:dnssi="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('dnssi'))); } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); # validate() has been called return unless ($contact->maticna() || $contact->emso()); my @n; push @n,['dnssi:contact',{type=>$contact->maticna()? 'org' : 'person'}]; push @n,['dnssi:maticna',$contact->maticna()] if $contact->maticna(); push @n,['dnssi:EMSO',$contact->emso()] if $contact->emso(); my $eid=build_command_extension($mes,$epp,'dnssi:ext'); $mes->command_extension($eid,[['dnssi:create'],\@n]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('dnssi','ext'); return unless $infdata; $infdata=$infdata->getChildrenByTagNameNS($mes->ns('dnssi'),'info'); return unless ($infdata && $infdata->size()==1); $infdata=$infdata->shift()->getChildrenByTagNameNS($mes->ns('dnssi'),'contact'); return unless ($infdata && $infdata->size()==1); my $co=$rinfo->{contact}->{$oname}->{self}; my $c=$infdata->shift()->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'maticna') { $co->maticna($c->textContent()); } elsif ($name eq 'EMSO') { $co->emso($c->textContent()); } } continue { $c=$c->getNextSibling(); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/ARNES/Domain.pm0000644000175000017500000000763411352534377023425 0ustar patrickpatrick## Domain Registry Interface, .SI Domain EPP extension commands ## ## Copyright (c) 2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::ARNES::Domain; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::ARNES::Domain - ARNES (.SI) EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( transfer_registrant_request => [ \&trade ], transfer_request => [ \&transfer ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub transfer_registrant { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>'request'}],$domain); my $cs=$rd->{contact}; my $creg=$cs->get('registrant'); Net::DRI::Exception::usererr_invalid_parameters('registrant must be a contact object') unless (Net::DRI::Util::isa_contact($creg,'Net::DRI::Data::Contact::ARNES')); push @d,['domain:registrant',$creg->srid()]; push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd); push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:dnssi="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('dnssi'))); } sub transfer_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d; push @d,Net::DRI::Protocol::EPP::Util::build_ns($epp,$rd->{ns},$domain) if Net::DRI::Util::has_ns($rd); Net::DRI::Exception::usererr_insufficient_parameters('Registrant, admin and tech contact are required for .SI domain name transfer') unless (Net::DRI::Util::has_contact($rd) && $rd->{contact}->has_type('registrant') && $rd->{contact}->has_type('admin') && $rd->{contact}->has_type('tech')); my $cs=$rd->{contact}; my @o=$cs->get('registrant'); push @d,['domain:registrant',$o[0]->srid()]; push @d,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cs); my $eid=build_command_extension($mes,$epp,'dnssi:ext'); $mes->command_extension($eid,['dnssi:transfer',['dnssi:domain',\@d]]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/EURid/0002755000175000017500000000000011352534417021743 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/EURid/Contact.pm0000644000175000017500000001123411352534377023700 0ustar patrickpatrick## Domain Registry Interface, EURid Contact EPP extension commands ## (based on EURid registration_guidelines_v1_0E-epp.pdf) ## ## Copyright (c) 2005,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::EURid::Contact; use strict; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::EURid::Contact - EURid EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ \&info, \&info_parse ], ); return { 'contact' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:eurid="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('eurid'))); } sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); ## validate() has been called, we are sure that type & lang exists my @n; push @n,['eurid:type',$contact->type()]; push @n,['eurid:vat',$contact->vat()] if $contact->vat(); push @n,['eurid:lang',$contact->lang()]; my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:create',['eurid:contact',@n]]); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $newc=$todo->set('info'); return unless ($newc && (defined($newc->vat()) || defined($newc->lang()))); my @n; push @n,['eurid:vat',$newc->vat()] if defined($newc->vat()); push @n,['eurid:lang',$newc->lang()] if defined($newc->lang()); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:update',['eurid:contact',['eurid:chg',@n]]]); } sub info { my ($epp,$contact)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:info',['eurid:contact',{version => '2.0'}]]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('eurid','ext'); return unless $infdata; my $ns=$mes->ns('eurid'); $infdata=$infdata->getChildrenByTagNameNS($ns,'infData'); return unless $infdata->size(); $infdata=$infdata->shift(); $infdata=$infdata->getChildrenByTagNameNS($ns,'contact'); return unless $infdata->size(); $infdata=$infdata->shift(); my $s=$rinfo->{contact}->{$oname}->{self}; my $el=$infdata->getChildrenByTagNameNS($ns,'type'); $s->type($el->get_node(1)->getFirstChild()->getData()); $el=$infdata->getChildrenByTagNameNS($ns,'vat'); $s->vat($el->get_node(1)->getFirstChild()->getData()) if defined($el->get_node(1)); $el=$infdata->getChildrenByTagNameNS($ns,'lang'); $s->lang($el->get_node(1)->getFirstChild()->getData()); $el=$infdata->getChildrenByTagNameNS($ns,'onhold'); $s->onhold($el->get_node(1)->getFirstChild()->getData()) if defined($el->get_node(1)); $el=$infdata->getChildrenByTagNameNS($ns,'monitoringStatus'); $s->monitoring_status($el->get_node(1)->getFirstChild()->getData()) if defined($el->get_node(1)); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/EURid/Domain.pm0000644000175000017500000003671111352534377023523 0ustar patrickpatrick## Domain Registry Interface, EURid Domain EPP extension commands ## (based on EURid registration_guidelines_v1_0E-epp.pdf) ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::EURid::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.15 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::EURid::Domain - EURid EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ \&info, \&info_parse ], check => [ \&check, \&check_parse ], delete => [ \&delete, undef ], transfer_request => [ \&transfer_request, undef ], transfer_cancel => [ \&transfer_cancel, undef ], undelete => [ \&undelete, undef ], transferq_request => [ \&transferq_request, undef ], transferq_cancel => [ \&transferq_cancel, undef ], trade_request => [ \&trade_request, undef ], trade_cancel => [ \&trade_cancel, undef ], reactivate => [ \&reactivate, undef ], check_contact_for_transfer => [ \&checkcontact, \&checkcontact_parse ], remind => [ \&remind, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:eurid="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('eurid'))); } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless Net::DRI::Util::has_key($rd,'nsgroup'); my @n=add_nsgroup($rd->{nsgroup}); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:create',['eurid:domain',@n]]); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); if (grep { ! /^(?:add|del)$/ } $todo->types('nsgroup')) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only nsgroup add/del available for domain'); } my $nsgadd=$todo->add('nsgroup'); my $nsgdel=$todo->del('nsgroup'); return unless ($nsgadd || $nsgdel); my @n; push @n,['eurid:add',add_nsgroup($nsgadd)] if $nsgadd; push @n,['eurid:rem',add_nsgroup($nsgdel)] if $nsgdel; my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:update',['eurid:domain',@n]]); } sub info { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:info',['eurid:domain',{version=>'2.0'}]]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('eurid','ext'); return unless defined $infdata; my $ns=$mes->ns('eurid'); $infdata=Net::DRI::Util::xml_traverse($infdata,$ns,'infData','domain'); return unless defined $infdata; my @c; foreach my $el ($infdata->getChildrenByTagNameNS($ns,'nsgroup')) { push @c,$po->create_local_object('hosts')->name($el->textContent()); } $rinfo->{domain}->{$oname}->{nsgroup}=\@c; my $cs=$rinfo->{domain}->{$oname}->{status}; foreach my $s (qw/onhold quarantined/) ## onhold here has nothing to do with EPP client|serverHold, unfortunately { my @s=$infdata->getChildrenByTagNameNS($ns,$s); next unless @s; $cs->add($s) if Net::DRI::Util::xml_parse_boolean($s[0]->textContent()); ## should we also remove 'ok' status then ? } foreach my $d (qw/availableDate deletionDate/) { my @d=$infdata->getChildrenByTagNameNS($ns,$d); next unless @d; $rinfo->{domain}->{$oname}->{$d}=$po->parse_iso8601($d[0]->textContent()); } my $pt=$infdata->getChildrenByTagNameNS($ns,'pendingTransaction'); if ($pt->size()) { $pt=$pt->shift(); my %p; foreach my $t (qw/trade transfer transferq/) { my $r=$pt->getChildrenByTagNameNS($ns,$t); next unless $r->size(); $p{type}=$t; $cs->add(($t eq 'trade')? 'pendingUpdate' : 'pendingTransfer'); foreach my $el (Net::DRI::Util::xml_list_children($r->get_node(1))) { my ($name,$c)=@$el; if ($name eq 'domain') { my $cs2=$po->create_local_object('contactset'); foreach my $sel (Net::DRI::Util::xml_list_children($c)) { my ($name2,$cc)=@$sel; if ($name2=~m/^(registrant|tech|billing)$/) { $cs2->set($po->create_local_object('contact')->srid($cc->textContent()),$name2); } elsif ($name2=~m/^(trDate)$/) { $p{$1}=$po->parse_iso8601($cc->textContent()); } } $p{contact}=$cs2; } elsif ($name=~m/^(initiationDate|unscreenedFax)$/) { $p{$1}=$po->parse_iso8601($c->textContent()); } elsif ($name=~m/^(status|replySeller|replyBuyer|replyOwner)$/) { $p{$1}=$c->textContent(); } } last; } $rinfo->{domain}->{$oname}->{pending_transaction}=\%p; } } sub check { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:check',['eurid:domain',{version=>'2.0'}]]); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $chkdata=$mes->get_extension('eurid','ext'); return unless defined $chkdata; my $ns=$mes->ns('eurid'); $chkdata=Net::DRI::Util::xml_traverse($chkdata,$ns,'chkData','domain'); return unless defined $chkdata; foreach my $cd ($chkdata->getChildrenByTagNameNS($ns,'cd')) { my $domain; foreach my $el (Net::DRI::Util::xml_list_children($cd)) { my ($n,$c)=@$el; if ($n eq 'name') { $domain=lc($c->textContent()); $rinfo->{domain}->{$domain}->{action}='check'; foreach my $ef (qw/accepted expired initial rejected/) ## only for domain applications { next unless $c->hasAttribute($ef); $rinfo->{domain}->{$domain}->{'application_'.$ef}=Net::DRI::Util::xml_parse_boolean($c->getAttribute($ef)); } } elsif ($n eq 'availableDate') { $rinfo->{domain}->{$domain}->{availableDate}=$po->parse_iso8601($c->textContent()); } } } } sub delete { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless (exists $rd->{deleteDate} && $rd->{deleteDate}); Net::DRI::Util::check_isa($rd->{deleteDate},'DateTime'); my $eid=build_command_extension($mes,$epp,'eurid:ext'); my @n=(['eurid:deleteDate',$rd->{deleteDate}->set_time_zone('UTC')->strftime('%Y-%m-%dT%T.%NZ')]); push @n,['eurid:overwriteDeleteDate','true'] if Net::DRI::Util::has_key($rd,'overwrite') && $rd->{overwrite}; $mes->command_extension($eid,['eurid:delete',['eurid:domain',@n]]); } sub transfer_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @n=(['eurid:domain',add_transfer($epp,$mes,$domain,$rd)]); push @n,['eurid:ownerAuthCode',$rd->{owner_auth_code}] if (Net::DRI::Util::has_key($rd,'owner_auth_code') && $rd->{owner_auth_code}=~m/^\d{15}$/); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:transfer',@n]); } sub transfer_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('reason is mandatory for transfer_cancel') unless (Net::DRI::Util::has_key($rd,'reason') && $rd->{reason}); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:cancel',['eurid:reason',$rd->{reason}]]); } sub add_transfer { my ($epp,$mes,$domain,$rd)=@_; Net::DRI::Exception::usererr_insufficient_parameters('registrant and billing are mandatory') unless (Net::DRI::Util::has_contact($rd) && $rd->{contact}->has_type('registrant') && $rd->{contact}->has_type('billing')); my $cs=$rd->{contact}; my @n; my $creg=$cs->get('registrant'); Net::DRI::Exception::usererr_invalid_parameters('registrant must be a contact object or the string #AUTO#') unless (Net::DRI::Util::isa_contact($creg,'Net::DRI::Data::Contact::EURid') || (!ref($creg) && (uc($creg) eq '#AUTO#'))); push @n,['eurid:registrant',ref($creg)? $creg->srid() : '#AUTO#' ]; if (exists($rd->{trDate})) { Net::DRI::Util::check_isa($rd->{trDate},'DateTime'); push @n,['eurid:trDate',$rd->{trDate}->set_time_zone('UTC')->strftime('%Y-%m-%dT%T.%NZ')]; } my $cbill=$cs->get('billing'); Net::DRI::Exception::usererr_invalid_parameters('billing must be a contact object') unless Net::DRI::Util::isa_contact($cbill,'Net::DRI::Data::Contact::EURid'); push @n,['eurid:billing',$cbill->srid()]; push @n,add_contact('tech',$cs,9) if $cs->has_type('tech'); push @n,add_contact('onsite',$cs,5) if $cs->has_type('onsite'); if (Net::DRI::Util::has_ns($rd)) { my $n=Net::DRI::Protocol::EPP::Util::build_ns($epp,$rd->{ns},$domain,'eurid'); my @ns=$mes->nsattrs('domain'); push @$n,{'xmlns:domain'=>shift(@ns),'xsi:schemaLocation'=>sprintf('%s %s',@ns)}; push @n,$n; } push @n,add_nsgroup($rd->{nsgroup}) if Net::DRI::Util::has_key($rd,'nsgroup'); return @n; } sub add_nsgroup { my ($nsg)=@_; return unless (defined($nsg) && $nsg); my @a=grep { defined($_) && $_ && !ref($_) && Net::DRI::Util::xml_is_normalizedstring($_,1,100) } map { Net::DRI::Util::isa_nsgroup($_)? $_->name() : $_ } (ref($nsg) eq 'ARRAY')? @$nsg : ($nsg); return map { ['eurid:nsgroup',$_] } grep {defined} @a[0..8]; } sub add_contact { my ($type,$cs,$max)=@_; $max--; my @r=grep { Net::DRI::Util::isa_contact($_,'Net::DRI::Data::Contact::EURid') } ($cs->get($type)); return map { ['eurid:'.$type,$_->srid()] } grep {defined} @r[0..$max]; } sub undelete { my ($epp,$domain)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'undelete',$domain); $mes->command_body(\@d); } sub transferq_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transferq',{'op'=>'request'}],$domain); push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd); $mes->command_body(\@d); my @n=add_transfer($epp,$mes,$domain,$rd); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:transferq',['eurid:domain',@n]]); } sub transferq_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transferq',{'op'=>'cancel'}],$domain); $mes->command_body(\@d); Net::DRI::Exception::usererr_insufficient_parameters('reason is mandatory for transferq_cancel') unless (Net::DRI::Util::has_key($rd,'reason') && $rd->{reason}); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:cancel',['eurid:reason',$rd->{reason}]]); } sub trade_request { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['trade',{'op'=>'request'}],$domain); $mes->command_body(\@d); my @n=add_transfer($epp,$mes,$domain,$rd); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:trade',['eurid:domain',@n]]); } sub trade_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['trade',{'op'=>'cancel'}],$domain); $mes->command_body(\@d); Net::DRI::Exception::usererr_insufficient_parameters('reason is mandatory for trade_cancel') unless (Net::DRI::Util::has_key($rd,'reason') && $rd->{reason}); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:cancel',['eurid:reason',$rd->{reason}]]); } sub reactivate { my ($epp,$domain)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'reactivate',$domain); $mes->command_body(\@d); } sub checkcontact { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); my @d=(['eurid:domainName',$domain]); Net::DRI::Exception::usererr_insufficient_parameters('registrant key is mandatory for check_contact_for_transfer') unless Net::DRI::Util::has_key($rd,'registrant'); Net::DRI::Exception::usererr_invalid_parameters('registrant must be a contact object') unless Net::DRI::Util::isa_contact($rd->{registrant},'Net::DRI::Data::Contact::EURid'); push @d,['eurid:registrant',$rd->{registrant}->srid()]; my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:command',['eurid:checkContactForTransfer',@d]]); } sub checkcontact_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $chkdata=$mes->get_extension('eurid','ext'); return unless defined $chkdata; my $ns=$mes->ns('eurid'); $chkdata=Net::DRI::Util::xml_traverse($chkdata,$ns,'response','checkContactForTransfer'); return unless defined $chkdata; my $p=Net::DRI::Util::xml_child_content($chkdata,$ns,'percentage'); $rinfo->{domain}->{$oname}->{'percentage'}=$p if defined $p; } sub remind { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); Net::DRI::Exception::usererr_insufficient_parameters('destination is mandatory for trade_cancel') unless (Net::DRI::Util::has_key($rd,'destination') && length $rd->{destination}); Net::DRI::Exception::usererr_invalid_parameters('destination must be either owner or buyer') unless ($rd->{destination} eq 'owner' || $rd->{destination} eq 'buyer'); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:command',['eurid:transferRemind',['eurid:domainname',$domain],['eurid:destination',$rd->{destination}]],['eurid:clTRID',$mes->cltrid()]]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/EURid/Sunrise.pm0000644000175000017500000002114711352534377023741 0ustar patrickpatrick## Domain Registry Interface, EURid Sunrise EPP extension for Net::DRI ## (from registration_guidelines_v1_0F-appendix2-sunrise.pdf ) ## ## Copyright (c) 2005,2007,2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::EURid::Sunrise; use strict; use Email::Valid; use DateTime::Format::ISO8601; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Extensions::EURid::Domain; use Net::DRI::DRD::EURid; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.14 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::EURid::Sunrise - EURid Sunrise EPP extension for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( apply => [ \&apply, \&apply_parse ], apply_info => [ \&info, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### ########### Query commands sub info { my ($epp,$reference)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('Apply_info action needs a reference') unless defined($reference) && $reference; Net::DRI::Exception::usererr_invalid_parameters('reference must be a xml normalizedstring from 1 to 100 characters long') unless Net::DRI::Util::xml_is_normalizedstring($reference,1,100); $mes->command(['apply-info','domain:apply-info',sprintf('xmlns:domain="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('domain'))]); $mes->command_body([['domain:reference',$reference]]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('domain','appInfoData'); return unless $infdata; my $cs=Net::DRI::Data::ContactSet->new(); my $pd=DateTime::Format::ISO8601->new(); my $c=$infdata->firstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->nodeName(); next unless $name; if ($name=~m/^domain:(name|reference|code)$/) { $rinfo->{domain}->{$oname}->{$1}=$c->firstChild->getData(); } elsif ($name eq 'domain:status') { $rinfo->{domain}->{$oname}->{application_status}=$c->firstChild->getData(); } elsif ($name=~m/^domain:(crDate|docsReceivedDate)$/) { $rinfo->{domain}->{$oname}->{$1}=$pd->parse_datetime($c->firstChild->getData()); } elsif ($name eq 'domain:registrant') { $cs->set($po->create_local_object('contact')->srid($c->firstChild->getData()),'registrant'); } elsif ($name eq 'domain:contact') { $cs->add($po->create_local_object('contact')->srid($c->firstChild->getData()),$c->getAttribute('type')); } elsif ($name eq 'domain:ns') { $rinfo->{domain}->{$oname}->{ns}=Net::DRI::Protocol::EPP::Util::parse_ns($po,$c); } elsif ($name eq 'domain:adr') { $rinfo->{domain}->{$oname}->{adr}=Net::DRI::Util::xml_parse_boolean($c->firstChild->getData()); } } continue { $c=$c->getNextSibling(); } $rinfo->{domain}->{$oname}->{contact}=$cs; } ############ Transform commands sub apply { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'apply',$domain); Net::DRI::Exception::usererr_insufficient_parameters('Apply action needs parameters') unless (defined($rd) && (ref($rd) eq 'HASH')); my @need=grep { !(exists($rd->{$_}) && $rd->{$_}) } qw/reference right prior-right-on-name prior-right-country documentaryevidence evidence-lang/; Net::DRI::Exception::usererr_insufficient_parameters('The following parameters are needed: '.join(' ',@need)) if @need; Net::DRI::Exception::usererr_invalid_parameters('reference must be a xml normalizedstring from 1 to 100 characters long') unless Net::DRI::Util::xml_is_normalizedstring($rd->{reference},1,100); push @d,['domain:reference',$rd->{reference}]; Net::DRI::Exception::usererr_invalid_parameters('right must be PUBLICBODY, REG-TM-NAT, REG-TM-COM-INTL, GEO-DOO, COMP-ID, UNREG-TM, TITLES-ART, OTHER') unless ($rd->{right}=~m/^(?:PUBLICBODY|REG-TM-NAT|REG-TM-COM-INTL|GEO-DOO|COMP-ID|UNREG-TM|TITLES-ART|OTHER)/); push @d,['domain:right',$rd->{right}]; Net::DRI::Exception::usererr_invalid_parameters('prior-right-on-name must be a xml token from 1 to 255 characters long') unless Net::DRI::Util::xml_is_token($rd->{'prior-right-on-name'},1,255); push @d,['domain:prior-right-on-name',$rd->{'prior-right-on-name'}]; Net::DRI::Exception::usererr_invalid_parameters('prior-right-country must be a CC of EU member') unless (length($rd->{'prior-right-country'})==2 && exists($Net::DRI::DRD::EURid::CCA2_EU{uc($rd->{'prior-right-country'})})); #### push @d,['domain:prior-right-country',uc($rd->{'prior-right-country'})]; Net::DRI::Exception::usererr_invalid_parameters('documentaryevidence must be applicant, registrar or thirdparty') unless $rd->{documentaryevidence}=~m/^(?:applicant|registrar|thirdparty)$/; if ($rd->{documentaryevidence} eq 'thirdparty') { Net::DRI::Exception::usererr_invalid_parameters('documentaryevidence_email must be a valid email address') unless (defined($rd->{documentaryevidence_email}) && Email::Valid->rfc822($rd->{documentaryevidence_email})); push @d,['domain:documentaryevidence',['domain:thirdparty',$rd->{documentaryevidence_email}]]; } else { push @d,['domain:documentaryevidence',['domain:'.$rd->{documentaryevidence}]]; } Net::DRI::Exception::usererr_invalid_parameters('evidence-lang must be a lang of EU member') unless (length($rd->{'evidence-lang'})==2 && exists($Net::DRI::DRD::EURid::LANGA2_EU{lc($rd->{'evidence-lang'})})); #### push @d,['domain:evidence-lang',lc($rd->{'evidence-lang'})]; ## Nameservers, OPTIONAL push @d,Net::DRI::Protocol::EPP::Util::build_ns($epp,$rd->{ns},$domain,'domain') if Net::DRI::Util::has_ns($rd); ## Contacts, all OPTIONAL if (Net::DRI::Util::has_contact($rd)) { my $cs=$rd->{contact}; my @o=$cs->get('registrant'); push @d,['domain:registrant',$o[0]->srid()] if (@o); push @d,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cs); } $mes->command_body(\@d); ## Nameserver groups if (exists($rd->{nsgroup})) { my @n=Net::DRI::Protocol::EPP::Extensions::EURid::Domain::add_nsgroup($rd->{nsgroup}); my $eid=Net::DRI::Protocol::EPP::Extensions::EURid::Domain::build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:apply',['eurid:domain',@n]]); } } sub apply_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); $rinfo->{_internal}->{must_reconnect}=1; ## All apply commands (successful or not) close the connection return unless $mes->is_success(); my $credata=$mes->get_response('domain','appData'); return unless $credata; $rinfo->{domain}->{$oname}->{exist}=1; my $c=$credata->firstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->nodeName(); next unless $name; if ($name=~m/^domain:(name|reference|code)$/) { $rinfo->{domain}->{$oname}->{$1}=$c->firstChild->getData(); } elsif ($name=~m/^domain:(crDate)$/) { $rinfo->{domain}->{$oname}->{$1}=DateTime::Format::ISO8601->new()->parse_datetime($c->firstChild->getData()); } } continue { $c=$c->getNextSibling(); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/EURid/Notifications.pm0000644000175000017500000000573611352534377025130 0ustar patrickpatrick## Domain Registry Interface, EURid Registrar EPP extension notifications ## (introduced in release 5.6 october 2008) ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::EURid::Notifications; use strict; use warnings; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::EURid::Notifications - EURid EPP Notifications Handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( notification => [ undef, \&parse ], ); return { 'message' => \%tmp }; } #################################################################################################### sub parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $poll=$mes->get_response('eurid','pollRes'); return unless defined $poll; my $action; foreach my $el (Net::DRI::Util::xml_list_children($poll)) { my ($name,$c)=@$el; if ($name eq 'action') { $action=lc($c->textContent()); } elsif ($name eq 'domainname') { $oname=$c->textContent(); } elsif ($name eq 'returncode') { $rinfo->{domain}->{$oname}->{return_code}=$c->textContent(); } elsif ($name eq 'type') { $action.='_'.lc($c->textContent()); } } $rinfo->{domain}->{$oname}->{action}=$action; $rinfo->{domain}->{$oname}->{exist}=1; $rinfo->{domain}->{$oname}->{result}=($action=~m/^confirm_/)? 1 : 0; ## TODO: is this a good test ? } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/EURid/Registrar.pm0000644000175000017500000001015611352534377024251 0ustar patrickpatrick## Domain Registry Interface, EURid Registrar EPP extension commands ## (introduced in release 5.6 october 2008) ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::EURid::Registrar; use strict; use warnings; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::EURid::Registrar - EURid EPP Registrar extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ \&info, \&info_parse ], ); return { 'registrar' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:eurid="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('eurid'))); } sub info { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); $mes->command(['info','registrar:info',sprintf('xmlns:registrar="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('registrar'))]); my $eid=build_command_extension($mes,$epp,'eurid:ext'); $mes->command_extension($eid,['eurid:info',['eurid:registrar',{version=>'1.0'}]]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('eurid','ext'); return unless defined $infdata; my $ns=$mes->ns('eurid'); $infdata=Net::DRI::Util::xml_traverse($infdata,$ns,'infData','registrar'); return unless defined $infdata; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'hitPoints') { $rinfo->{registrar}->{info}->{hitpoints}={}; foreach my $sel (Net::DRI::Util::xml_list_children($c)) { my ($n,$cc)=@$sel; if ($n eq 'nbrHitPoints') { $rinfo->{registrar}->{info}->{hitpoints}->{current_number}=0+$cc->textContent(); } elsif ($n eq 'maxNbrHitPoints') { $rinfo->{registrar}->{info}->{hitpoints}->{maximum_number}=0+$cc->textContent(); } elsif ($n eq 'blockedUntil') { $rinfo->{registrar}->{info}->{hitpoints}->{blocked_until}=$po->parse_iso8601($cc->textContent()); } } } elsif ($name eq 'amountAvailable') { $rinfo->{registrar}->{info}->{amount_available}=0+$c->textContent(); } elsif ($name eq 'nbrRenewalCreditsAvailable') { $rinfo->{registrar}->{info}->{credits}->{renewal}=($c->textContent() eq '')? undef : 0+$c->textContent(); } elsif ($name eq 'nbrPromoCreditsAvailable') { $rinfo->{registrar}->{info}->{credits}->{promo}=($c->textContent() eq '')? undef : 0+$c->textContent(); } } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/EURid/Message.pm0000644000175000017500000000463111352534377023674 0ustar patrickpatrick## Domain Registry Interface, EPP Message for EURid ## ## Copyright (c) 2005,2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::EURid::Message; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP::Message/; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::EURid::Message - EPP EURid Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub parse { my $self=shift; $self->SUPER::parse(@_); ## Parse eurid:ext my $result=$self->get_extension('eurid','ext'); return unless $result; my $ns=$self->ns('eurid'); $result=$result->getChildrenByTagNameNS($ns,'result'); return unless $result->size(); $result=$result->shift(); ## We add it to the latest status extra_info seen. foreach my $el ($result->getChildrenByTagNameNS($ns,'msg')) { $self->add_to_extra_info({from => 'eurid', type => 'text', message => $el->textContent()}); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/ASIA.pm0000644000175000017500000000471311352534377022056 0ustar patrickpatrick## Domain Registry Interface, ASIA EPP extensions ## ## Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::ASIA; use strict; use Net::DRI::Data::Contact::ASIA; use base qw/Net::DRI::Protocol::EPP/; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::ASIA - ASIA EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({ asia => ['urn:afilias:params:xml:ns:asia-1.0','asia-1.0.xsd'], ipr => ['urn:afilias:params:xml:ns:ipr-1.0','ipr-1.0.xsd'], }); $self->factories('contact',sub { return Net::DRI::Data::Contact::ASIA->new(@_); }); $self->capabilities('domain_update','url',['set']); $self->capabilities('domain_update','contact',['add','set','del']); return; } sub default_extensions { return qw/GracePeriod ASIA::IPR ASIA::CED/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CIRA.pm0000644000175000017500000000477211352534377022064 0ustar patrickpatrick## Domain Registry Interface, CIRA (.CA) EPP extensions ## ## Copyright (c) 2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CIRA; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Util; use Net::DRI::Data::Contact::CIRA; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub setup { my ($self,$rp)=@_; my $version=$self->version(); $self->ns({cira=>['urn:ietf:params:xml:ns:cira-1.0','cira-1.0.xsd'], poll=>['urn:ietf:params:xml:ns:poll-1.0','poll-1.0.xsd']}); $self->factories('contact',sub { return Net::DRI::Data::Contact::CIRA->new(); }); $self->default_parameters({domain_create => { auth => { pw => '' } } }); ## authInfo not used by CIRA return; } sub core_contact_types { return ('admin','tech'); } ## No billing contact in .CA sub default_extensions { return qw/CIRA::Domain CIRA::Contact CIRA::Agreement CIRA::Notifications/; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CIRA - CIRA (.CA) EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AU/0002755000175000017500000000000011352534417021300 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/AU/Domain.pm0000644000175000017500000001371711352534377023061 0ustar patrickpatrick## Domain Registry Interface, .AU Domain EPP extension commands ## ## Copyright (c) 2007,2008 Distribute.IT Pty Ltd, www.distributeit.com.au, Rony Meyer . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::AU::Domain; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::AU::Domain - .AU EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Rony Meyer, Eperl@spot-light.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Distribute.IT Pty Ltd, Ehttp://www.distributeit.com.auE, Rony Meyer . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], info => [ undef, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:auext="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('auext'))); } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_insufficient_parameters('eligibility attribute is mandatory, as ref hash') unless (exists($rd->{eligibility}) && (ref($rd->{eligibility}) eq 'HASH')); Net::DRI::Exception::usererr_insufficient_parameters('eligibility attribute missing key registrantName') unless (exists($rd->{eligibility}->{registrantName}) && $rd->{eligibility}->{registrantName}); Net::DRI::Exception::usererr_insufficient_parameters('eligibility attribute missing key policyReason') unless (exists($rd->{eligibility}->{policyReason}) && $rd->{eligibility}->{policyReason}); Net::DRI::Exception::usererr_insufficient_parameters('eligibility attribute missing key eligibilityType') unless (exists($rd->{eligibility}->{eligibilityType}) && $rd->{eligibility}->{eligibilityType}); my @n; push @n,['auext:registrantName',$rd->{eligibility}->{registrantName}]; if (exists $rd->{eligibility}->{registrantID} && $rd->{eligibility}->{registrantID} && exists $rd->{eligibility}->{registrantIDType} && $rd->{eligibility}->{registrantIDType}) { push @n,['auext:registrantID',$rd->{eligibility}->{registrantID},{'type'=> $rd->{eligibility}->{registrantIDType}}]; } push @n,['auext:eligibilityType',$rd->{eligibility}->{eligibilityType}]; push @n,['auext:eligibilityName',$rd->{eligibility}->{eligibilityName}] if exists $rd->{eligibility}->{eligibilityName} && $rd->{eligibility}->{eligibilityName}; if (exists $rd->{eligibility}->{eligibilityID} && $rd->{eligibility}->{eligibilityID} && exists $rd->{eligibility}->{eligibilityIDType} && $rd->{eligibility}->{eligibilityIDType}) { push @n,['auext:eligibilityID',$rd->{eligibility}->{eligibilityID},{'type'=> $rd->{eligibility}->{eligibilityIDType}}]; } push @n,['auext:policyReason',$rd->{eligibility}->{policyReason}]; my $eid=build_command_extension($mes,$epp,'auext:extensionAU'); my @nn; push @nn, ['auext:create',@n]; $mes->command_extension($eid,\@nn); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('auextnew','infData'); return unless $infdata; my %ens; my $c=$infdata->getFirstChild(); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; # if ($name eq 'info') if ($name eq 'auProperties') { my $cc=$c->getFirstChild(); while($cc) { next unless ($cc->nodeType() == 1); ## only for element nodes my $name2=$cc->localname() || $cc->nodeName(); next unless $name2; if ($name2 eq 'registrantName') { $ens{registrantName}=$cc->getFirstChild()->getData(); } elsif ($name2 eq 'registrantID') { $ens{registrantID}=$cc->getFirstChild()->getData(); $ens{registrantIDType}=$cc->getAttribute('type'); #registrantID } elsif ($name2 eq 'eligibilityType') { $ens{eligibilityType}=$cc->getFirstChild()->getData(); } elsif ($name2 eq 'eligibilityName') { $ens{eligibilityName}=$cc->getFirstChild()->getData(); } elsif ($name2 eq 'eligibilityID') { $ens{eligibilityID}=$cc->getFirstChild()->getData(); $ens{eligibilityIDType}=$cc->getAttribute('type'); #eligibilityID } elsif ($name2 eq 'policyReason') { $ens{policyReason}=$cc->getFirstChild()->getData(); } } continue { $cc=$cc->getNextSibling(); } } } continue { $c=$c->getNextSibling(); } $rinfo->{domain}->{$oname}->{eligibility}=\%ens; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NAME/0002755000175000017500000000000011352534417021513 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/NAME/EmailFwd.pm0000644000175000017500000001751111352534377023551 0ustar patrickpatrick## Domain Registry Interface, EPP Email forwarding extension commands ## (based on .NAME Technical Accreditation Guide v3.03) ## ## Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::NAME::EmailFwd; use strict; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::Contact; use Net::DRI::Data::ContactSet; use DateTime::Format::ISO8601; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::NAME::EmailFwd - EPP EmailFwd extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E or Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp1=( create => [ \&create ], check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], delete => [ \&delete ], update => [ \&update ], renew => [ \&renew ] ); $tmp1{check_multi}=$tmp1{check}; return { 'emailfwd' => \%tmp1 }; } sub ns { my ($mes)=@_; my $ns=$mes->ns('emailFwd'); return defined($ns)? $ns : 'http://www.nic.name/epp/emailFwd-1.0'; } sub build_command { my ($epp,$msg,$command,$info)=@_; my $contacts = $info->{contact}; my $authid = $info->{auth}; my @ret; my @auth; delete $info->{contact}; delete $info->{auth}; Net::DRI::Exception->die(1,'protocol/EPP',2,'emailFwd name needed') unless (defined($info->{name})); my @ns=$msg->nsattrs('emailFwd'); @ns=qw(http://www.nic.name/epp/emailFwd-1.0 http://www.nic.name/epp/emailFwd-1.0 emailFwd-1.0.xsd) unless @ns; $msg->command([$command,'emailFwd:'.$command,sprintf('xmlns:emailFwd="%s" xsi:schemaLocation="%s %s"',@ns)]); # @ret = map { ['emailFwd:' . $_, $info->{$_}] } keys(%{$info}); push(@ret, ['emailFwd:name', $info->{name}]) if (defined($info->{name})); push(@ret, ['emailFwd:fwdTo', $info->{fwdTo}]) if (defined($info->{fwdTo})); push(@ret, ['emailFwd:curExpDate', $info->{curExpDate}]) if (defined($info->{curExpDate})); push(@ret, ['emailFwd:period', { unit => 'y' }, $info->{period}->in_units('years')]) if (defined($info->{period})); push(@ret, ['emailFwd:registrant', $info->{registrant}]) if (defined($info->{registrant})); foreach my $type (keys %{$contacts}) { push(@ret, ['emailFwd:contact', {type => $type}, $contacts->{$type}]); } foreach my $auth (keys %{$authid}) { push(@auth, ['emailFwd:' . $auth, $authid->{$auth}]); } push(@ret, ['emailFwd:authInfo', @auth]) if (@auth); return @ret; } #################################################################################################### ########### Query commands sub check { my $epp=shift; my $info=shift; my $mes=$epp->message(); my @d=build_command($epp,$mes,'check', { name => $info }); $mes->command_body(\@d); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $ns=ns('emailFwd'); my $chkdata=$mes->get_response($ns,'chkData'); return unless $chkdata; foreach my $cd ($chkdata->getElementsByTagNameNS($ns,'cd')) { my $c = $cd->getFirstChild(); my $fwd; while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); if ($n eq 'name') { $fwd = $c->getFirstChild()->getData(); $rinfo->{emailFwd}->{$fwd}->{exist} = 1 - Net::DRI::Util::xml_parse_boolean($c->getAttribute('avail')); $rinfo->{emailFwd}->{$fwd}->{action} = 'check'; } } continue { $c = $c->getNextSibling(); } } } sub info { my ($epp,$mail)=@_; my $mes = $epp->message(); my @d = build_command($epp,$mes,'info',{ name => $mail }); $mes->command_body(\@d); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response(ns($mes),'infData'); return unless $infdata; my $nm; my $cs = new Net::DRI::Data::ContactSet; my $info = {}; my $ginfo = {}; my $c=$infdata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'name') { $info->{name} = $nm = $c->getFirstChild()->getData(); } elsif ($name eq 'fwdTo') { $info->{$name} = $c->getFirstChild()->getData(); } elsif (grep { $_ eq $name } qw/clID crID upID/) { $ginfo->{$name} = $c->getFirstChild()->getData(); } elsif (grep { $_ eq $name } qw/crDate upDate trDate exDate/) { $ginfo->{$name} = (new DateTime::Format::ISO8601())-> parse_datetime($c->getFirstChild()->getData()); } elsif (grep { $_ eq $name } qw/registrant contact/) { my $type = $c->getAttribute('type') || 'registrant'; $cs->add((new Net::DRI::Data::Contact())-> srid($c->getFirstChild()->getData()), $type); } elsif ($name eq 'authInfo') { my $pw = ($c->getElementsByTagNameNS($mes->ns('emailFwd'),'pw'))[0]; $ginfo->{auth} = { pw => (defined($pw) && $pw->hasChildNodes() ? $pw->getFirstChild->getData() : undef) }; } } continue { $c=$c->getNextSibling(); } $info->{contact} = $cs; $ginfo->{exist} = defined($nm); $ginfo->{action} = 'info'; $ginfo->{self} = $info; $rinfo->{emailFwd}->{$nm} = $ginfo; } ############ Transform commands sub create { my ($epp,$mail,$info)=@_; my $mes = $epp->message(); my @d; $info->{name} = $mail; @d = build_command($epp,$mes,'create',$info); $mes->command_body(\@d); } sub delete { my ($epp,$mail)=@_; my $mes=$epp->message(); my @d=build_command($epp,$mes,'delete',{ name => $mail }); $mes->command_body(\@d); } sub update { my ($epp,$hosts,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:ns)$/ } $todo->types()) || (grep { ! /^(?:set)$/ } $todo->types('ns') )) { Net::DRI::Exception->die(0,'protocol/EPP',11,'Only ns set available for nsgroup'); } my $ns=$todo->set('ns'); my @d=build_command($epp,$mes,'update',$hosts); push @d,add_nsname($ns); $mes->command_body(\@d); } sub renew { my ($epp,$mail,$period,$curexp)=@_; my $mes = $epp->message(); Net::DRI::Util::check_isa($curexp,'DateTime'); Net::DRI::Util::check_isa($period,'DateTime::Duration'); my $info = { name => $mail, curExpDate => $curexp->ymd, period => $period }; my @d = build_command($epp,$mes,'renew',$info); $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SIDN/0002755000175000017500000000000011352534417021530 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Host.pm0000644000175000017500000000545011352534377023012 0ustar patrickpatrick## Domain Registry Interface, SIDN EPP Host commands ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SIDN::Host; use strict; use warnings; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], ); return { 'host' => \%tmp }; } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('sidn','ext'); return unless defined $infdata; my $ns=$mes->ns('sidn'); $infdata=Net::DRI::Util::xml_traverse($infdata,$ns,'infData','host'); return unless defined $infdata; my $ho=$rinfo->{host}->{$oname}->{self}; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'limited') { my $v=Net::DRI::Util::xml_parse_boolean($c->textContent()); $rinfo->{host}->{$oname}->{limited}=$v; $rinfo->{host}->{$oname}->{self}->add($oname,undef,undef,{limited => $v}); } } } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SIDN::Host - SIDN EPP Host commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cutNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Contact.pm0000644000175000017500000001027311352534377023467 0ustar patrickpatrick## Domain Registry Interface, SIDN EPP Contact commands ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SIDN::Contact; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], create => [ \&create, undef ], update => [ \&update ], ); return { 'contact' => \%tmp }; } sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:sidn="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('sidn'))); } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('sidn','ext'); return unless defined $infdata; my $ns=$mes->ns('sidn'); $infdata=Net::DRI::Util::xml_traverse($infdata,$ns,'infData','contact'); return unless defined $infdata; my $contact=$rinfo->{contact}->{$oname}->{self}; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'legalForm') { $contact->legal_form($c->textContent()); } elsif ($name eq 'legalFormRegNo') { $contact->legal_id($c->textContent()); } elsif ($name eq 'limited') { $contact->limited(Net::DRI::Util::xml_parse_boolean($c->textContent())); } } } ########### Transform commands sub create { my ($epp,$contact)=@_; my $mes=$epp->message(); ## $contact->validate() has been called my @n; push @n,['sidn:legalForm',$contact->legal_form()]; push @n,['sidn:legalFormRegNo',$contact->legal_id()] if $contact->legal_id(); my $eid=build_command_extension($mes,$epp,'sidn:ext'); $mes->command_extension($eid,['sidn:create',['sidn:contact',@n]]); } sub update { my ($epp,$contact,$todo)=@_; my $mes=$epp->message(); my $newc=$todo->set('info'); return unless defined $newc; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid contact '.$newc) unless Net::DRI::Util::isa_contact($newc,'Net::DRI::Data::Contact::SIDN'); $newc->validate(1); ## will trigger an Exception if needed my @n; push @n,['sidn:legalForm',$newc->legal_form()] if $newc->legal_form(); push @n,['sidn:legalFormRegNo',$newc->legal_id()] if $newc->legal_id(); return unless @n; my $eid=build_command_extension($mes,$epp,'sidn:ext'); $mes->command_extension($eid,['sidn:update',['sidn:contact',@n]]); } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SIDN::Contact - SIDN EPP Contact commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Domain.pm0000644000175000017500000001072011352534377023300 0ustar patrickpatrick## Domain Registry Interface, SIDN EPP Domain extensions ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SIDN::Domain; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse], create => [ \&create, undef ], delete_cancel => [ \&delete_cancel, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:sidn="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('sidn'))); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('sidn','ext'); return unless defined $infdata; my $ns=$mes->ns('sidn'); $infdata=Net::DRI::Util::xml_traverse($infdata,$ns,'infData','domain'); return unless defined $infdata; foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'optOut') { $rinfo->{domain}->{$oname}->{opt_out}=Net::DRI::Util::xml_parse_boolean($c->textContent()); } elsif ($name eq 'limited') { $rinfo->{domain}->{$oname}->{limited}=Net::DRI::Util::xml_parse_boolean($c->textContent()); } } } sub create { my ($epp,$domain,$rd)=@_; Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory in .NL for domain_create') unless Net::DRI::Util::has_contact($rd); my $cs=$rd->{contact}; my @c=$cs->get('registrant'); Net::DRI::Exception::usererr_insufficient_parameters('one registrant is mandatory in .NL for domain_create') unless (@c==1 && Net::DRI::Util::isa_contact($c[0],'Net::DRI::Data::Contact::SIDN')); @c=$cs->get('admin'); Net::DRI::Exception::usererr_insufficient_parameters('one admin contact is mandatory in .NL for domain_create') unless (@c==1 && Net::DRI::Util::isa_contact($c[0],'Net::DRI::Data::Contact::SIDN')); @c=$cs->get('tech'); Net::DRI::Exception::usererr_insufficient_parameters('at least one tech contact is mandatory in .NL for domain_create') unless (@c >= 1 && scalar(@c)==scalar(grep { Net::DRI::Util::isa_contact($_,'Net::DRI::Data::Contact::SIDN') } @c)); } sub delete_cancel { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); my $eid=build_command_extension($mes,$epp,'sidn:command'); $mes->command_extension($eid,[['sidn:domainCancelDelete',['sidn:name',$domain]],['sidn:clTRID',$mes->cltrid()]]); } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SIDN::Domain - SIDN (.NL) EPP Domain extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Notifications.pm0000644000175000017500000001336511352534377024712 0ustar patrickpatrick## Domain Registry Interface, SIDN EPP Notifications ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SIDN::Notifications; use strict; use warnings; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; use Net::DRI::Util; #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( review_sidn => [ undef, \&parse_sidn ], ); return { 'message' => \%tmp }; } #################################################################################################### sub parse_sidn { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $node=$mes->get_response('sidn','pollData'); return unless defined $node; $oname='_unknown'; ## some messages carry back very little useful information ! my $id=$mes->msg_id(); my $nsepp=$mes->ns('_main'); my %h=(action => 'review_sidn'); my $cmd; foreach my $el (Net::DRI::Util::xml_list_children($node)) { my ($name,$n)=@$el; if ($name eq 'command') { $cmd=$n->textContent(); ($otype)=($cmd=~m/^(\S+):/); $h{object_type}=$otype; } elsif ($name eq 'data') { foreach my $subel (Net::DRI::Util::xml_list_children($n)) { my ($subname,$subnode)=@$subel; if ($subname eq 'result') { $h{result_code}=$subnode->getAttribute('code'); $h{result_msg}=Net::DRI::Util::xml_child_content($subnode,$nsepp,'msg'); } elsif ($subname eq 'resData') { if ($cmd eq 'domain:create') { $oname=Net::DRI::Util::xml_child_content($subnode,$nsepp,'name'); $h{crDate}=$po->parse_iso8601(Net::DRI::Util::xml_child_content($subnode,$nsepp,'crDate')); $h{exist}=1; } elsif ($cmd eq 'domain:transfer-token-reminder') { $oname=reminder_parse($po,$subnode,$mes->ns('sidn'),\%h); $h{exist}=1; } elsif ($cmd eq 'domain:transfer-token-supply') { $oname=supply_parse($po,$subnode,$mes->ns('sidn'),\%h); $h{exist}=1; } elsif ($cmd eq 'domain:transfer' || $cmd eq 'domain:transfer-start') { $oname=transfer_parse($po,$subnode,$mes->ns('domain'),\%h); $h{exist}=1; } } elsif ($subname eq 'trID') { $h{trid}=Net::DRI::Util::xml_child_content($subnode,$nsepp,'clTRID'); $h{svtrid}=Net::DRI::Util::xml_child_content($subnode,$nsepp,'svTRID'); } } } } ## Do not know if all of this is the good way to do, as these notifications are very strangely formatted $cmd=~s/:/_/; $cmd=~s/-/_/g; $h{command}=$cmd; while(my ($k,$v)=each(%h)) { $rinfo->{$otype}->{$oname}->{$k}=$v; } return; } sub transfer_parse { my ($po,$trndata,$ns,$rh)=@_; $trndata=Net::DRI::Util::xml_traverse($trndata,$ns,'trnData'); my $oname; ## The following is basically a copy from Core/Domain::transfer_parse ! foreach my $el (Net::DRI::Util::xml_list_children($trndata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); } elsif ($name=~m/^(trStatus|reID|acID)$/) { $rh->{$1}=$c->textContent(); } elsif ($name=~m/^(reDate|acDate|exDate)$/) { $rh->{$1}=$po->parse_iso8601($c->textContent()); } } return $oname; } sub reminder_parse { my ($po,$trndata,$ns,$rh)=@_; $trndata=Net::DRI::Util::xml_traverse($trndata,$ns,'trnData'); my $oname; foreach my $el (Net::DRI::Util::xml_list_children($trndata)) { my ($name,$c)=@$el; if ($name eq 'domainname') { $oname=lc($c->textContent()); } elsif ($name eq 'requestor') { $rh->{requestor}=$c->textContent(); } elsif ($name eq 'requestDate') { $rh->{request_date}=$po->parse_iso8601($c->textContent()); } elsif ($name eq 'supplyDate') { $rh->{supply_date}=$po->parse_iso8601($c->textContent()); } } return $oname; } sub supply_parse { my ($po,$trndata,$ns,$rh)=@_; $trndata=Net::DRI::Util::xml_traverse($trndata,$ns,'trnData'); my $oname; foreach my $el (Net::DRI::Util::xml_list_children($trndata)) { my ($name,$c)=@$el; if ($name eq 'domainname') { $oname=lc($c->textContent()); } elsif ($name eq 'pw') { $rh->{token}=$c->textContent(); } elsif ($name eq 'requestDate') { $rh->{request_date}=$po->parse_iso8601($c->textContent()); } } return $oname; } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SIDN::Notifications - SIDN (.NL) EPP Notifications for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SIDN/Message.pm0000644000175000017500000000500511352534377023455 0ustar patrickpatrick## Domain Registry Interface, EPP Message for SIDN ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SIDN::Message; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP::Message/; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; #################################################################################################### sub parse { my $self=shift; $self->SUPER::parse(@_); ## Parse sidn:ext my $result=$self->get_extension('sidn','ext'); return unless $result; my $ns=$self->ns('sidn'); $result=$result->getChildrenByTagNameNS($ns,'response'); return unless $result->size(); ## We add it to the latest status extra_info seen. foreach my $el ($result->get_node(1)->getChildrenByTagNameNS($ns,'msg')) { ## code is mandatory, as well as text probably, field is optional $self->add_to_extra_info({from => 'sidn', type => 'text', code => $el->getAttribute('code'),field => $el->getAttribute('field'), message => $el->textContent()}); } } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SIDN::Message - EPP SIDN Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PL/0002755000175000017500000000000011352534417021306 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PL/Contact.pm0000644000175000017500000000660711352534377023253 0ustar patrickpatrick## Domain Registry Interface, .PL Contact EPP extension commands ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::EPP::Extensions::PL::Contact; use strict; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::PL::Contact - .PL EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], info => [ \&info, undef ], update => [ \&update, undef ], ); return { 'contact' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:extcon="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('pl_contact'))); } sub add_individual_and_consent { my ($epp,$contact,$op)=@_; my $mes=$epp->message(); ## validate() has already been called my $ind=$contact->individual(); my $cfp=$contact->consent_for_publishing(); return unless (defined($ind) || defined($cfp)); my $eid=build_command_extension($mes,$epp,'extcon:'.$op); my @e; push @e,['extcon:individual',$ind] if defined($ind); push @e,['extcon:consentForPublishing',$cfp] if defined($cfp); $mes->command_extension($eid,\@e); } sub create { my ($epp,$contact)=@_; return add_individual_and_consent($epp,$contact,'create'); } sub update { my ($epp,$contact,$todo)=@_; my $newc=$todo->set('info'); return unless $newc; return add_individual_and_consent($epp,$newc,'update'); } sub info { my ($epp,$contact,$ep)=@_; my $mes=$epp->message(); return unless (Net::DRI::Util::has_auth($ep) && exists($ep->{auth}->{pw})); my $eid=build_command_extension($mes,$epp,'extcon:info'); $mes->command_extension($eid,[['extcon:authInfo',['extcon:pw',$ep->{auth}->{pw}]]]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PL/Domain.pm0000644000175000017500000001445011352534377023062 0ustar patrickpatrick## Domain Registry Interface, .PL Domain EPP extension commands ## ## Copyright (c) 2006,2008,2009,2010 Patrick Mevzek and Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::PL::Domain; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Data::Hosts; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::PL::Domain - .PL EPP Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHORS Patrick Mevzek, Enetdri@dotandco.comE Tonnerre Lombard =head1 COPYRIGHT Copyright (c) 2006,2008,2009,2010 Patrick Mevzek and Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create ], update => [ \&update ], info => [ undef, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub build_command_extension { my ($mes,$epp,$tag)=@_; return $mes->command_extension_register($tag,sprintf('xmlns:extdom="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('pl_domain'))); } sub build_ns { my ($epp,$ns,$domain,$xmlns)=@_; $xmlns='domain' unless defined($xmlns); return map { [$xmlns . ':ns',$_] } $ns->get_names(); } sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'create',$domain); my $def = $epp->default_parameters(); if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) && (ref($def->{domain_create}) eq 'HASH')) { $rd={} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd)); while(my ($k,$v)=each(%{$def->{domain_create}})) { next if exists($rd->{$k}); $rd->{$k}=$v } } ## Period, OPTIONAL push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd); ## Nameservers, OPTIONAL push @d,build_ns($epp,$rd->{ns},$domain) if Net::DRI::Util::has_ns($rd); ## Contacts, all OPTIONAL if (Net::DRI::Util::has_contact($rd)) { my $cs=$rd->{contact}; my @o=$cs->get('registrant'); push @d,['domain:registrant',$o[0]->srid()] if (@o); push @d,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cs); } ## AuthInfo Net::DRI::Exception::usererr_insufficient_parameters("authInfo is mandatory") unless (Net::DRI::Util::has_auth($rd)); push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}); $mes->command_body(\@d); return unless exists($rd->{reason}) || exists($rd->{book}); my $eid=build_command_extension($mes,$epp,'extdom:create'); my @e; push @e,['extdom:reason',$rd->{reason}] if (exists($rd->{reason}) && $rd->{reason}); push @e,['extdom:book'] if (exists($rd->{book}) && $rd->{book}); $mes->command_extension($eid,\@e); } sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'update',$domain); my $nsadd=$todo->add('ns'); my $nsdel=$todo->del('ns'); my $sadd=$todo->add('status'); my $sdel=$todo->del('status'); my $cadd=$todo->add('contact'); my $cdel=$todo->del('contact'); my (@add,@del); push @add,build_ns($epp,$nsadd,$domain) if $nsadd && !$nsadd->is_empty(); push @add,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cadd) if $cadd; push @add,$sadd->build_xml('domain:status','core') if $sadd; push @del,build_ns($epp,$nsdel,$domain,undef,1) if $nsdel && !$nsdel->is_empty(); push @del,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cdel) if $cdel; push @del,$sdel->build_xml('domain:status','core') if $sdel; push @d,['domain:add',@add] if @add; push @d,['domain:rem',@del] if @del; my $chg=$todo->set('registrant'); my @chg; push @chg,['domain:registrant',$chg->srid()] if Net::DRI::Util::isa_contact($chg,'Net::DRI::Data::Contact::PL'); $chg=$todo->set('auth'); push @chg,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($chg) if ($chg && ref($chg)); push @d,['domain:chg',@chg] if @chg; $mes->command_body(\@d); } sub info_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $infdata = $mes->get_response('domain','infData'); return unless $infdata; my $ns = Net::DRI::Data::Hosts->new(); my $c = $infdata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name = $c->localname() || $c->nodeName(); next unless $name; if ($name eq 'name') { $oname = lc($c->getFirstChild()->getData()); } elsif ($name eq 'ns') { $ns->add($c->getFirstChild()->getData()); } } continue { $c = $c->getNextSibling(); } $rinfo->{domain}->{$oname}->{ns} = $ns; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/PL/Message.pm0000644000175000017500000001257211352534377023242 0ustar patrickpatrick## Domain Registry Interface, .PL Message EPP extension commands ## ## Copyright (c) 2008 Tonnerre Lombard . ## Copyright (c) 2008 Thorsten Glaser for Sygroup GmbH ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::PL::Message; use strict; use Net::DRI::Exception; use DateTime::Format::ISO8601; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::PL::Message - .PL EPP Message extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/project/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE Thorsten Glaser =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . Copyright (c) 2008 Thorsten Glaser for Sygroup GmbH All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( plretrieve => [ \&poll, \&parse_poll ] ); return { 'message' => \%tmp }; } #################################################################################################### sub poll { my ($epp,$msgid)=@_; Net::DRI::Exception::usererr_invalid_parameters('In EPP, you can not specify the message id you want to retrieve') if defined($msgid); my $mes=$epp->message(); $mes->command([['poll',{op=>'req'}]]); } sub parse_poll { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my ($epp,$rep,$ext,$ctag,@conds,@tags); my $mes=$po->message(); my $msgid=$mes->msg_id(); my $domname; my $domauth; my $action; return unless $mes->is_success(); return if ($mes->result_code() == 1300); # no messages in queue return unless (defined($msgid) && $msgid); my $mesdata = $mes->node_resdata(); return unless ($mesdata); $rinfo->{message}->{session}->{last_id}=$msgid; foreach my $cnode ($mesdata->childNodes) { my $cmdname = $cnode->localName || $cnode->nodeName; if ($cmdname eq 'pollAuthInfo') { my $ra = $rinfo->{message}->{$msgid}->{extra_info}; push @{$ra}, $cnode->toString(); ### ??? $action = 'pollAuthInfo'; foreach my $cnode ($cnode->childNodes) { my $objname = $cnode->localName || $cnode->nodeName; if ($objname eq 'domain') { $otype = 'domain'; foreach my $cnode ($cnode->childNodes) { my $infname = $cnode->localName || $cnode->nodeName; if ($infname eq 'name') { $domname = $cnode->getFirstChild()->getData(); } elsif ($infname eq 'authInfo') { $domauth = $cnode; } } } } } else { # copied from Net/DRI/Protocol/EPP/Core/Domain.pm:transfer_parse my $trndata=$mes->get_response('domain','trnData'); if ($trndata) { my $pd=DateTime::Format::ISO8601->new(); my $c=$trndata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'name') { $domname = lc($c->getFirstChild()->getData()); $action = 'transfer'; } elsif ($name=~m/^(trStatus|reID|acID)$/) { my $fc = $c->getFirstChild(); $rinfo->{domain}->{$domname}->{$1}=$fc->getData() if (defined($fc)); } elsif ($name=~m/^(reDate|acDate|exDate)$/) { $rinfo->{domain}->{$domname}->{$1}=$pd->parse_datetime($c->getFirstChild()->getData()); } } continue { $c=$c->getNextSibling(); } } } } if (defined ($domname)) { $otype = 'domain'; $oname = $domname; $rinfo->{domain}->{$domname}->{name} = $domname; $rinfo->{domain}->{$domname}->{exist} = 1; $rinfo->{message}->{$msgid}->{object_id} = $domname; if (defined ($domauth)) { my $c = $domauth->getFirstChild(); while ($c) { my $typename; next unless ($c->nodeType == 1); ## only for element nodes $typename = $c->localName || $c->nodeName; $rinfo->{domain}->{$domname}->{auth} = { $typename => $c->getFirstChild()->getData() }; } continue { $c = $c->getNextSibling(); } } } if (defined ($action)) { $rinfo->{message}->{$msgid}->{action} = $action; if (defined ($domname)) { $rinfo->{domain}->{$oname}->{action} = $action; } } $rinfo->{message}->{$msgid}->{object_type} = $otype; $rinfo->{$otype}->{$oname}->{message}=$mesdata; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CZ/0002755000175000017500000000000011352534417021307 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CZ/NSSET.pm0000644000175000017500000002575611352534377022563 0ustar patrickpatrick## Domain Registry Interface, .CZ EPP NSSET extension commands ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CZ::NSSET; use strict; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::Hosts; use Net::DRI::Data::ContactSet; use Net::DRI::Protocol::EPP::Util; use DateTime::Format::ISO8601; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CZ::NSSET - .CZ NSSET extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class, $version) = @_; my %tmp1 = ( create => [ \&create ], check => [ \&check, \&check_parse ], info => [ \&info, \&info_parse ], delete => [ \&delete ], update => [ \&update ], transfer_query => [ \&transfer_query ], transfer_request => [ \&transfer_request ], transfer_cancel => [ \&transfer_cancel ], transfer_answer => [ \&transfer_answer ], ); $tmp1{check_multi} = $tmp1{check}; return { 'nsset' => \%tmp1 }; } sub ns { my ($mes) = @_; my $ns=$mes->ns('nsset'); return defined($ns)? $ns : 'http://www.nic.cz/xml/epp/nsset-1.2'; } sub build_command { my ($epp, $msg, $command, $hosts) = @_; my $tcommand = (ref($command) eq 'ARRAY' ? $command->[0] : $command); my @gn; foreach my $h (grep { defined } (ref($hosts) eq 'ARRAY') ? @$hosts : ($hosts)) { my $gn = Net::DRI::Util::isa_nsgroup($h) ? $h->name() : $h; Net::DRI::Exception->die(1, 'protocol/EPP', 10, 'Invalid NSgroup name: ' . $gn) unless (defined($gn) && $gn && !ref($gn) && Net::DRI::Util::xml_is_normalizedstring( $gn, 1, 100)); push(@gn, $gn); } Net::DRI::Exception->die(1, 'protocol/EPP', 2, 'NSgroup name needed') unless @gn; my @ns=$msg->nsattrs('nsset'); @ns=qw(http://www.nic.cz/xml/epp/nsset-1.2 http://www.nic.cz/xml/epp/nsset-1.2 nsset-1.2.xsd) unless @ns; $msg->command([$command, 'nsset:' . $tcommand, sprintf('xmlns:nsset="%s" xsi:schemaLocation="%s %s"',@ns)]); return map { ['nsset:id', $_] } @gn; } sub add_nsname { my ($ns) = @_; return () unless (defined($ns)); my @a; if (!ref($ns)) { return ['nsset:ns', ['nsset:name', $ns]]; } elsif (ref($ns) eq 'ARRAY') { return ['nsset:ns', map { ['nsset:name', $_] } @$ns]; } elsif (Net::DRI::Util::isa_hosts($ns)) { for (my $i = 1; $i <= $ns->count(); $i++) { my ($name, $v4, $v6) = $ns->get_details($i); my @b; push(@b, ['nsset:name', $name]); foreach my $addr (@{$v4}, @{$v6}) { push(@b, ['nsset:addr', $addr]); } push(@a, ['nsset:ns', @b]); } } return @a; } sub build_contacts { my ($cs) = @_; return () unless (defined($cs)); my @a; foreach my $type ($cs->types()) { push(@a, map { ['nsset:' . $type, $_->srid()] } $cs->get($type)); } return @a; } sub build_authinfo { my $rauth = shift; return unless (defined($rauth) && ref($rauth) eq 'HASH'); return ['nsset:authInfo', $rauth->{pw}]; } sub build_reportlevel { my $level = int(shift); return unless (defined($level) && $level >= 0 && $level <= 10); return ['nsset:reportlevel', $level]; } #################################################################################################### ########### Query commands sub check { my $epp = shift; my @hosts = @_; my $mes = $epp->message(); my @d = build_command($epp, $mes, 'check', \@hosts); $mes->command_body(\@d); } sub check_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $ns = ns($mes); my $chkdata = $mes->get_response($ns,'chkData'); return unless $chkdata; foreach my $cd ($chkdata->getElementsByTagNameNS($ns, 'cd')) { my $c = $cd->getFirstChild(); my $nsset; while ($c) { ## only for element nodes next unless ($c->nodeType() == 1); my $n = $c->localname() || $c->nodeName(); if ($n eq 'id') { $nsset = $c->getFirstChild()->getData(); $rinfo->{nsset}->{$nsset}->{exist} = 1 - Net::DRI::Util::xml_parse_boolean ($c->getAttribute('avail')); $rinfo->{nsset}->{$nsset}->{action} = 'check'; } } continue { $c = $c->getNextSibling(); } } } sub info { my ($epp, $hosts) = @_; my $mes = $epp->message(); my @d = build_command($epp, $mes, 'info', $hosts); $mes->command_body(\@d); } sub info_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $infdata = $mes->get_response(ns($mes),'infData'); return unless $infdata; my $ns = Net::DRI::Data::Hosts->new(); my $pd = DateTime::Format::ISO8601->new(); my $cs = Net::DRI::Data::ContactSet->new(); my @s; my $c = $infdata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name = $c->localname() || $c->nodeName(); next unless $name; if ($name eq 'id') { $oname = $c->getFirstChild()->getData(); $rinfo->{nsset}->{$oname}->{name} = $rinfo->{nsset}->{$oname}->{id} = $oname; $rinfo->{nsset}->{$oname}->{exist} = 1; $rinfo->{nsset}->{$oname}->{action} = 'info'; } elsif ($name eq 'roid') { $rinfo->{nsset}->{$oname}->{roid} = $c->getFirstChild() ->getData(); } elsif ($name eq 'reportlevel') { $rinfo->{nsset}->{$oname}->{reportlevel} = int($c->getFirstChild()->getData()); } elsif ($name eq 'status') { push(@s,Net::DRI::Protocol::EPP::Util::parse_status($c)); } elsif ($name eq 'authInfo') { $rinfo->{nsset}->{$oname}->{auth} = { pw => $c->getFirstChild()->getData() }; } elsif ($name =~ /^((?:c[lr]|tr|up)ID)$/) { $rinfo->{nsset}->{$oname}->{$1} = $c->getFirstChild()->getData(); } elsif ($name =~ /^((?:c[lr]|tr|up)Date)$/) { $rinfo->{nsset}->{$oname}->{$1} = $pd->parse_datetime( $c->getFirstChild()->getData()); } elsif ($name eq 'ns') { my $hostname; my @v4; my @v6; foreach my $xname ($c->getElementsByTagNameNS(ns($mes), 'name')) { $hostname = $xname->getFirstChild()->getData(); } foreach my $xaddr ($c->getElementsByTagNameNS(ns($mes), 'addr')) { my $xa = $xaddr->getFirstChild()->getData(); if ($xa =~ /^\d+\.\d+\.\d+\.\d+$/) { push(@v4, $xa); } else { push(@v6, $xa); } } $ns->add($hostname, \@v4, \@v6); } elsif ($name =~ /^(registrant|billing|admin|tech)$/) { $cs->add($po->create_local_object('contact')->srid($c->getFirstChild()->getData()), $name); } } continue { $c = $c->getNextSibling(); } $rinfo->{nsset}->{$oname}->{self} = $ns; $rinfo->{nsset}->{$oname}->{contact} = $cs; $rinfo->{nsset}->{$oname}->{status} = $po->create_local_object('status')->add(@s); } sub transfer_query { my ($epp, $name, $rd) = @_; my $mes = $epp->message(); my @d = build_command($epp, $mes, ['transfer', {'op' => 'query'}], $name); push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } ############ Transform commands sub create { my ($epp, $name, $rd) = @_; my $mes = $epp->message(); my @d = build_command($epp, $mes, 'create', $name); my $hosts = $rd->{ns}; my $cs = $rd->{contact}; push(@d, add_nsname($hosts)); push(@d, build_contacts($cs)); push(@d, build_authinfo($rd->{auth})); push(@d, build_reportlevel($rd->{reportlevel})); $mes->command_body(\@d); } sub delete { my ($epp, $hosts) = @_; my $mes = $epp->message(); my @d = build_command($epp, $mes, 'delete', $hosts); $mes->command_body(\@d); } sub transfer_request { my ($epp, $name, $rd) = @_; my $mes = $epp->message(); my @d = build_command($epp, $mes, ['transfer', {'op' => 'request'}], $name); push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub transfer_answer { my ($epp, $name, $rd) = @_; my $mes = $epp->message(); my @d = build_command($epp, $mes, ['transfer', {'op' => (Net::DRI::Util::has_key($rd, 'approve') && $rd->{approve} ? 'approve' : 'reject')}], $name); push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub transfer_cancel { my ($epp, $name, $rd) = @_; my $mes = $epp->message(); my @d = build_command($epp, $mes, ['transfer', {'op' => 'cancel'}], $name); push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub update { my ($epp, $hosts, $todo) = @_; my $mes = $epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo . ' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:ns|contact|auth|reportlevel)$/ } $todo->types())) { Net::DRI::Exception->die(0, 'protocol/EPP', 11, 'Only ns/contact add/del and auth/reportlevel set ' . 'available for nsset'); } my @d = build_command($epp, $mes, 'update', $hosts); my $nsadd = $todo->add('ns'); my $nsdel = $todo->del('ns'); my $cadd = $todo->add('contact'); my $cdel = $todo->del('contact'); my $auth = $todo->set('auth'); my $level = $todo->set('reportlevel'); my (@add, @del, @set); push(@add, add_nsname($nsadd)) if ($nsadd && !$nsadd->is_empty()); push(@add, build_contacts($cadd)) if ($cadd); push(@del, map { ['nsset:name', $_] } $nsdel->get_names()) if ($nsdel && !$nsdel->is_empty()); push(@del, build_contacts($cdel)) if ($cdel); push(@set, ['nsset:authInfo', $auth->{pw}]) if (defined($auth) && Net::DRI::Util::has_key($auth, 'pw')); push(@set, build_reportlevel($level)) if (defined($level)); push(@d, ['nsset:add', @add]) if (@add); push(@d, ['nsset:rem', @del]) if (@del); push(@d, ['nsset:chg', @set]) if (@set); $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CZ/Contact.pm0000644000175000017500000001660511352534377023253 0ustar patrickpatrick## Domain Registry Interface, .CZ Contact EPP extension commands ## ## Copyright (c) 2008,2010 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::EPP::Extensions::CZ::Contact; use strict; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CZ::Contact - .CZ EPP Contact extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E or Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2010 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class, $version) = @_; my %tmp = ( info => [ undef, \&info_parse ], create => [ \&create, undef ], update => [ \&update, undef ] ); return { 'contact' => \%tmp }; } #################################################################################################### sub build_command { my ($msg, $command, $contact) = @_; my @contact = (ref($contact) eq 'ARRAY')? @$contact : ($contact); my @c = map { Net::DRI::Util::isa_contact($_) ? $_->srid() : $_ } @contact; Net::DRI::Exception->die(1,'protocol/EPP',2,'Contact id needed') unless @c; foreach my $n (@c) { Net::DRI::Exception->die(1, 'protocol/EPP', 2, 'Contact id needed') unless (defined($n) && $n && !ref($n)); Net::DRI::Exception->die(1, 'protocol/EPP', 10, 'Invalid contact id: ' . $n) unless Net::DRI::Util::xml_is_token($n, 3, 16); } my $tcommand = (ref($command)) ? $command->[0] : $command; $msg->command([$command, 'contact:' . $tcommand, sprintf('xmlns:contact="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('contact'))]); my @d = map { ['contact:id', $_] } @c; if (($tcommand =~ m/^(?:info|transfer)$/) && ref($contact[0]) && Net::DRI::Util::isa_contact($contact[0])) { my $az = $contact[0]->auth(); if ($az && ref($az) && exists($az->{pw})) { push(@d, ['contact:authInfo', $az->{pw}]); } } return @d; } ############ Query commands sub info_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $infdata = $mes->get_response('contact','infData'); return unless $infdata; my $s = $rinfo->{contact}->{$oname}->{self}; my $el = $infdata->getElementsByTagNameNS($mes->ns('contact'), 'authInfo'); while (my $ai = $el->shift()) { $s->auth({pw => $ai->getFirstChild()->getData()}) if (defined($ai) && defined($ai->getFirstChild()) && $ai->getFirstChild()->nodeType() == 3); } } ############ Transform commands sub build_authinfo { my $contact = shift; my $az = $contact->auth(); return () unless ($az && ref($az) && exists($az->{pw})); return ['contact:authInfo', $az->{pw}]; } sub build_disclose { my $contact = shift; my $d=$contact->disclose(); return () unless ($d && ref($d)); my %v=map { $_ => 1 } values(%$d); return () unless (keys(%v)==1); ## 1 or 0 as values, not both at same time my @d; push(@d, ['contact:name']) if (exists($d->{name})); push(@d, ['contact:org']) if (exists($d->{org})); push(@d, ['contact:addr']) if (exists($d->{addr})); push(@d, ['contact:voice']) if (exists($d->{voice})); push(@d, ['contact:fax']) if (exists($d->{fax})); push(@d, ['contact:email']) if (exists($d->{email})); return ['contact:disclose',@d,{flag=>(keys(%v))[0]}]; } sub build_cdata { my ($contact, $v) = @_; my (@post, @addr); my @tmp; my @d; @tmp = $contact->name(); if (defined($tmp[0])) { push(@post, ['contact:name', $tmp[0]]); } @tmp = $contact->org(); if (defined($tmp[0])) { push(@post, ['contact:org', $tmp[0]]); } @tmp = $contact->street(); if (defined($tmp[0])) { foreach (@{$tmp[0]}) { push(@addr, ['contact:street', $_]); } } @tmp = $contact->city(); if (defined($tmp[0])) { push(@addr, ['contact:city', $tmp[0]]); } @tmp = $contact->sp(); if (defined($tmp[0])) { push(@addr, ['contact:sp', $tmp[0]]); } @tmp = $contact->pc(); if (defined($tmp[0])) { push(@addr, ['contact:pc', $tmp[0]]); } @tmp = $contact->cc(); if (defined($tmp[0])) { push(@addr, ['contact:cc', $tmp[0]]); } push(@post, ['contact:addr', @addr]) if (@addr); push(@d, ['contact:postalInfo', @post]); push(@d, Net::DRI::Protocol::EPP::Util::build_tel('contact:voice', $contact->voice())) if (defined($contact->voice())); push(@d, Net::DRI::Protocol::EPP::Util::build_tel('contact:fax', $contact->fax())) if (defined($contact->fax())); push(@d, ['contact:email', $contact->email()]) if (defined($contact->email())); push(@d, build_authinfo($contact)); push(@d, build_disclose($contact)); return @d; } sub create { my ($epp, $contact) = @_; my $mes = $epp->message(); my @d = build_command($mes, 'create', $contact); Net::DRI::Exception->die(1, 'protocol/EPP', 10, 'Invalid contact ' . $contact) unless Net::DRI::Util::isa_contact($contact); $contact->validate(); ## will trigger an Exception if needed push(@d, build_cdata($contact, $epp->{contacti18n})); $mes->command_body(\@d); } sub update { my ($epp, $contact, $todo) = @_; my $mes = $epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo . ' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:add|del)$/ } $todo->types('status')) || (grep { ! /^(?:set)$/ } $todo->types('info'))) { Net::DRI::Exception->die(0, 'protocol/EPP', 11, 'Only status add/del or info set available for ' . 'contact'); } my @d = build_command($mes, 'update', $contact); my $sadd = $todo->add('status'); my $sdel = $todo->del('status'); push(@d, ['contact:add', $sadd->build_xml('contact:status')]) if ($sadd); push(@d, ['contact:rem', $sdel->build_xml('contact:status')]) if ($sdel); my $newc = $todo->set('info'); if ($newc) { Net::DRI::Exception->die(1, 'protocol/EPP', 10, 'Invalid contact ' . $newc) unless Net::DRI::Util::isa_contact($newc); $newc->validate(1); ## will trigger an Exception if needed my @c = build_cdata($newc, $epp->{contacti18n}); push(@d, ['contact:chg', @c]) if (@c); } $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/CZ/Domain.pm0000644000175000017500000002103611352534377023061 0ustar patrickpatrick## Domain Registry Interface, CZ domain transactions extension ## ## Copyright (c) 2008,2009,2010 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::CZ::Domain; use strict; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::ContactSet; use Net::DRI::Data::Hosts; use Net::DRI::Protocol::EPP::Util; use DateTime::Format::ISO8601; our $VERSION = do { my @r = ( q$Revision: 1.4 $ =~ /\d+/g ); sprintf( "%d" . ".%02d" x $#r, @r ); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::CZ::Domain - .CZ Domain extension commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://oss.bsdprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008,2009,2010 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class, $version) = @_; my %tmp = ( info => [ \&info, \&info_parse ], create => [ \&create, undef ], update => [ \&update ], ); return { 'domain' => \%tmp }; } ################################################################################################## sub build_command { my ($msg, $command, $domain, $domainattr) = @_; my @dom = (ref($domain)) ? @$domain : ($domain); Net::DRI::Exception->die(1, 'protocol/EPP', 2, "Domain name needed") unless @dom; foreach my $d (@dom) { Net::DRI::Exception->die(1, 'protocol/EPP', 2, 'Domain name needed') unless (defined($d) && $d && !ref($d)); Net::DRI::Exception->die(1, 'protocol/EPP', 10, 'Invalid domain name: ' . $d) unless (Net::DRI::Util::is_hostname($d)); } my $tcommand = (ref($command)) ? $command->[0] : $command; $msg->command([$command, 'domain:' . $tcommand, sprintf('xmlns:domain="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('domain'))]); my @d = map { ['domain:name', $_, $domainattr] } @dom; return @d; } sub build_authinfo { my $rauth = shift; return ['domain:authInfo', $rauth->{pw}]; } #################################################################################################### ########### Query commands sub info { my ($epp, $domain, $rd) = @_; my $mes = $epp->message(); my @d = build_command($mes, 'info', $domain); push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd); $mes->command_body(\@d); } sub info_parse { my ($po, $otype, $oaction, $oname, $rinfo) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $infdata = $mes->get_response('domain','infData'); return unless $infdata; my (@s, @host, $ns); my $cs = Net::DRI::Data::ContactSet->new(); my $c = $infdata->getFirstChild(); while ($c) { my $name = $c->localname() || $c->nodeName(); next unless $name; if ($name eq 'name') { $oname = lc($c->getFirstChild()->getData()); $rinfo->{domain}->{$oname}->{action} = 'info'; $rinfo->{domain}->{$oname}->{exist} = 1; } elsif ($name eq 'roid') { $rinfo->{domain}->{$oname}->{roid} = $c->getFirstChild()->getData(); } elsif ($name eq 'status') { push(@s, Net::DRI::Protocol::EPP::Util::parse_status($c)); } elsif ($name =~ /^(registrant|admin)$/) { $cs->set($po->create_local_object('contact')->srid($c->getFirstChild()->getData()), $1); } elsif ($name eq 'ns') { $ns = Net::DRI::Data::Hosts->new() if (!$ns); $ns->add($c->getFirstChild()->getData()); } elsif ($name eq 'nsset') { $rinfo->{domain}->{$oname}->{nsset} = $c->getFirstChild()->getData(); } elsif ($name eq 'host') { push(@host, $c->getFirstChild()->getData()); } elsif ($name =~ m/^(clID|crID|upID)$/) { $rinfo->{domain}->{$oname}->{$1} = $c->getFirstChild()->getData(); } elsif ($name =~ m/^(crDate|upDate|trDate|exDate)$/) { $rinfo->{domain}->{$oname}->{$1} = DateTime::Format::ISO8601->new()-> parse_datetime($c->getFirstChild()-> getData()); } elsif ($name eq 'authInfo') { my $pw = $c->getFirstChild()->getData(); $rinfo->{domain}->{$oname}->{auth} = {pw => ($pw ? $pw : undef) }; } $c = $c->getNextSibling(); } $rinfo->{domain}->{$oname}->{contact} = $cs; $rinfo->{domain}->{$oname}->{status} = $po-> create_local_object('status')->add(@s); $rinfo->{domain}->{$oname}->{host} = Net::DRI::Data::Hosts-> new_set(@host) if (@host); $rinfo->{domain}->{$oname}->{ns} = $ns if ($ns); } ############ Transform commands sub create { my ($epp, $domain, $rd) = @_; my $mes = $epp->message(); my @d = build_command($mes, 'create', $domain); my $def = $epp->default_parameters(); if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) && (ref($def->{domain_create}) eq 'HASH')) { $rd = {} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd)); while (my ($k, $v) = each(%{$def->{domain_create}})) { next if exists($rd->{$k}); $rd->{$k} = $v; } } ## Period, OPTIONAL push(@d, Net::DRI::Protocol::EPP::Util::build_period($rd->{duration})) if Net::DRI::Util::has_duration($rd); ## Nameserver sets, OPTIONAL push(@d, ['domain:nsset', $rd->{nsset}]) if (Net::DRI::Util::has_key($rd, 'nsset')); ## Contacts, all OPTIONAL push(@d, build_contacts($rd->{contact})) if (Net::DRI::Util::has_contact($rd)); ## AuthInfo Net::DRI::Exception::usererr_insufficient_parameters('authInfo is ' . 'mandatory') unless (Net::DRI::Util::has_auth($rd)); push(@d, build_authinfo($rd->{auth})); $mes->command_body(\@d); } sub build_contacts { my $cs = shift; my @d; foreach my $t (sort { $b cmp $a } $cs->types()) { my @o = $cs->get($t); push(@d, map { ['domain:' . $t, $_->srid()] } @o); } return @d; } sub update { my ($epp, $domain, $todo) = @_; my $mes = $epp->message(); Net::DRI::Exception::usererr_invalid_parameters($todo . ' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo); if ((grep { ! /^(?:add|del)$/ } $todo->types('ns')) || (grep { ! /^(?:add|del)$/ } $todo->types('status')) || (grep { ! /^(?:add|del)$/ } $todo->types('contact')) || (grep { ! /^set$/ } $todo->types('auth'))) { Net::DRI::Exception->die(0, 'protocol/EPP', 11, 'Only ns/status/contact add/del or registrant/' . 'authinfo set available for domain'); } my @d = build_command($mes, 'update', $domain); my $nsadd = $todo->add('ns'); my $nsdel = $todo->del('ns'); my $sadd = $todo->add('status'); my $sdel = $todo->del('status'); my $cadd = $todo->add('contact'); my $cdel = $todo->del('contact'); my (@add, @del); push(@add, Net::DRI::Protocol::EPP::Util::build_ns($epp, $nsadd, $domain)) if ($nsadd && !$nsadd->is_empty()); push(@add, build_contacts($cadd)) if ($cadd); push(@add, $sadd->build_xml('domain:status', 'core')) if ($sadd); push(@del, Net::DRI::Protocol::EPP::Util::build_ns($epp, $nsdel, $domain)) if ($nsdel && !$nsdel->is_empty()); push(@del, build_contacts($cdel)) if ($cdel); push(@del, $sdel->build_xml('domain:status', 'core')) if ($sdel); push(@d, ['domain:add', @add]) if (@add); push(@d, ['domain:rem', @del]) if (@del); my @chg; my $chg = $todo->set('nsset'); push(@chg, ['domain:nsset', $chg]) if (defined($chg) && length($chg)); $chg = $todo->set('registrant'); push(@chg, ['domain:registrant', $chg->srid()]) if Net::DRI::Util::isa_contact($chg); $chg = $todo->set('auth'); push(@chg, build_authinfo($chg)) if ($chg && ref($chg)); push(@d, ['domain:chg', @chg]) if (@chg); $mes->command_body(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign.pm0000644000175000017500000000520511352534377023064 0ustar patrickpatrick## Domain Registry Interface, VeriSign EPP extensions ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::VeriSign; use strict; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Data::Contact::JOBS; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::VeriSign - VeriSign EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->default_parameters()->{subproductid}=$rp->{default_product} || '_auto_'; $self->default_parameters()->{whois_info}=0; $self->default_parameters()->{breaks_rfc3915}=1; $self->factories('contact',sub { return Net::DRI::Data::Contact::JOBS->new(@_); }) if $self->has_module('Net::DRI::Protocol::EPP::Extensions::VeriSign::JobsContact'); return; } sub default_extensions { my ($self,$rp)=@_; my @c=qw/VeriSign::Sync VeriSign::PollLowBalance VeriSign::PollRGP VeriSign::IDNLanguage VeriSign::WhoisInfo GracePeriod/; push @c,'VeriSign::JobsContact' if exists $rp->{default_product} && defined $rp->{default_product} && $rp->{default_product} eq 'dotJOBS'; push @c,'VeriSign::NameStore'; return @c; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/GracePeriod.pm0000644000175000017500000001141211352534377023517 0ustar patrickpatrick## Domain Registry Interface, EPP Grace Period commands (RFC3915) ## ## Copyright (c) 2005,2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::GracePeriod; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='urn:ietf:params:xml:ns:rgp-1.0'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::GracePeriod - EPP Grace Period commands (RFC3915) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ undef, \&info_parse ], update => [ \&update, \&update_parse ], ); return { 'domain' => \%tmp }; } sub capabilities_add { return ('domain_update','rgp',['set']); } #################################################################################################### ########### Query commands sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension($NS,'infData'); return unless defined $infdata; my $cs=$rinfo->{domain}->{$oname}->{status}; ## a Net::DRI::Protocol::EPP::Core::Status object foreach my $el ($infdata->getChildrenByTagNameNS($NS,'rgpStatus')) { $cs->add($el->getAttribute('s')); } } ############ Transform commands sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $rgp=$todo->set('rgp'); return unless (defined $rgp && $rgp && ref $rgp eq 'HASH'); my $op=$rgp->{op} || ''; Net::DRI::Exception::usererr_invalid_parameters('RGP op must be request or report') unless ($op=~m/^(?:request|report)$/); Net::DRI::Exception::usererr_invalid_parameters('Report data must be included if the operation is a report') unless (($op eq 'request') xor exists $rgp->{report}); my $eid=$mes->command_extension_register('rgp:update',sprintf('xmlns:rgp="%s" xsi:schemaLocation="%s rgp-1.0.xsd"',$NS,$NS)); if ($op eq 'request') { $mes->command_extension($eid,['rgp:restore',{ op => $op }]); } else { my %r=%{$rgp->{report}}; my $def=$epp->default_parameters(); my $data=(Net::DRI::Util::has_key($def,'breaks_rfc3915') && $def->{breaks_rfc3915})? 'Whois' : 'Data'; ## VeriSign does not respect its own RFC my @d; push @d,['rgp:pre'.$data,$r{predata}]; ## XML data is possible in the RFC, but not here ?! push @d,['rgp:post'.$data,$r{postdata}]; ## ditto Net::DRI::Util::check_isa($r{deltime},'DateTime'); push @d,['rgp:delTime',$r{deltime}->strftime('%Y-%m-%dT%T.%1NZ')]; Net::DRI::Util::check_isa($r{restime},'DateTime'); push @d,['rgp:resTime',$r{restime}->strftime('%Y-%m-%dT%T.%1NZ')]; push @d,['rgp:resReason',$r{reason}]; push @d,['rgp:statement',$r{statement1},exists $r{statement1_lang} ? {lang => $r{statement1_lang}} : ()]; push @d,['rgp:statement',$r{statement2},exists $r{statement2_lang} ? {lang => $r{statement2_lang}} : ()]; push @d,['rgp:other',$r{other}] if exists $r{other}; $mes->command_extension($eid,['rgp:restore',['rgp:report',@d],{ op => $op }]); } } sub update_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $updata=$mes->get_extension($NS,'upData'); return unless defined $updata; ## We do nothing, since the rgpStatus alone is useless ## (we do not have the other status) } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/0002755000175000017500000000000011352534417022521 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/PollRGP.pm0000644000175000017500000000570111352534377024344 0ustar patrickpatrick## Domain Registry Interface, EPP RGP Poll (EPP-RGP-Poll-Mapping.pdf) ## ## Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::VeriSign::PollRGP; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::VeriSign::PollRGP - EPP RGP Poll Mapping (EPP-RGP-Poll-Mapping.pdf) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( rgpnotification => [ undef, \&parse ], ); return { 'message' => \%tmp }; } #################################################################################################### sub parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('http://www.verisign.com/epp/rgp-poll-1.0','pollData'); return unless defined $infdata; my %w=(action => 'rgp_notification'); foreach my $el (Net::DRI::Util::xml_list_children($infdata)) { my ($name,$c)=@$el; if ($name eq 'name') { $oname=lc($c->textContent()); } elsif ($name eq 'rgpStatus') { $w{status}=$po->create_local_object('status')->add(Net::DRI::Protocol::EPP::Util::parse_status($c)); } elsif ($name=~m/^(reqDate|reportDueDate)$/) { $w{Net::DRI::Util::remcam($name)}=$po->parse_iso8601($c->textContent()); } } $rinfo->{domain}->{$oname}=\%w; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/NameStore.pm0000644000175000017500000001374611352534377024772 0ustar patrickpatrick## Domain Registry Interface, EPP NameStore Extension for Verisign ## ## Copyright (c) 2006,2008,2009 Rony Meyer . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::VeriSign::NameStore; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $NS='http://www.verisign-grs.com/epp/namestoreExt-1.1'; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::VeriSign::NameStore - VeriSign EPP NameStore Extension for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@spot-light.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHORS Rony Meyer, Eperl@spot-light.chE Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Rony Meyer . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; # domain functions my %tmpDomain = ( check => [ \&add_namestore_ext, \&parse ], check_multi => [ \&add_namestore_ext, \&parse ], info => [ \&add_namestore_ext, \&parse_error ], transfer_query => [ \&add_namestore_ext, \&parse_error ], create => [ \&add_namestore_ext, \&parse_error ], delete => [ \&add_namestore_ext, \&parse_error ], renew => [ \&add_namestore_ext, \&parse_error ], transfer_request => [ \&add_namestore_ext, \&parse_error ], transfer_cancel => [ \&add_namestore_ext, \&parse_error ], transfer_answer => [ \&add_namestore_ext, \&parse_error ], update => [ \&add_namestore_ext, \&parse_error ], ); # host functions my %tmpHost = ( create => [ \&add_namestore_ext, \&parse_error ], check => [ \&add_namestore_ext, \&parse ], check_multi => [ \&add_namestore_ext, \&parse ], info => [ \&add_namestore_ext, \&parse_error ], delete => [ \&add_namestore_ext, \&parse_error ], update => [ \&add_namestore_ext, \&parse_error ], ); # contact functions my %tmpContact = ( create => [ \&add_namestore_ext, \&parse_error ], check => [ \&add_namestore_ext, \&parse ], check_multi => [ \&add_namestore_ext, \&parse ], info => [ \&add_namestore_ext, \&parse_error ], delete => [ \&add_namestore_ext, \&parse_error ], update => [ \&add_namestore_ext, \&parse_error ], ); return { 'domain' => \%tmpDomain, 'host' => \%tmpHost, 'contact'=> \%tmpContact, }; } #################################################################################################### ########### Add the NameStore Extenstion to all domain & host commands sub add_namestore_ext { my $epp=shift(@_); my $domain=shift(@_); my $rd=pop(@_); my $mes=$epp->message(); my $defprod=$epp->default_parameters()->{subproductid}; my $eid=$mes->command_extension_register('namestoreExt:namestoreExt',sprintf('xmlns:namestoreExt="%s" xsi:schemaLocation="%s namestoreExt-1.1.xsd"',$NS,$NS)); if (Net::DRI::Util::has_key($rd,'subproductid') && $rd->{subproductid}) { $mes->command_extension($eid,['namestoreExt:subProduct',$rd->{subproductid}]); return; } unless ($defprod eq '_auto_') { $mes->command_extension($eid,['namestoreExt:subProduct',$defprod]); return; } ## We do not know what will happen in case of check_multi with multiple TLDs my $ext='dotCOM'; $domain=$domain->[0] if (ref($domain) eq 'ARRAY'); $ext='dotNET' if ($domain=~m/\.net$/i); $ext='dotCC' if ($domain=~m/\.cc$/i); $ext='dotTV' if ($domain=~m/\.tv$/i); $ext='dotBZ' if ($domain=~m/\.bz$/i); $ext='dotJOBS' if ($domain=~m/\.jobs$/i); $mes->command_extension($eid,['namestoreExt:subProduct',$ext]); } sub parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); parse_error($po,$otype,$oaction,$oname,$rinfo); return unless $mes->is_success(); my $infdata=$mes->get_extension($NS,'namestoreExt'); return unless $infdata; my $c=$infdata->getChildrenByTagNameNS($NS,'subProduct'); return unless $c; $rinfo->{$otype}->{$oname}->{subproductid}=$c->shift()->getFirstChild()->getData(); } sub parse_error { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); ## Parse namestoreExt in case of errors return unless $mes->result_code() == 2306; my $data=$mes->get_extension($NS,'nsExtErrData'); return unless $data; $data=$data->shift()->getChildrenByTagNameNS($NS,'msg'); return unless $data; $data=$data->shift(); ## We add it to the latest status extra_info seen. $mes->add_to_extra_info({from => 'verisign:namestoreExt', type => 'text', message => $data->textContent(), code => $data->getAttribute('code')}); } ######################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/PollLowBalance.pm0000644000175000017500000000601711352534377025724 0ustar patrickpatrick## Domain Registry Interface, EPP Low Balance (EPP-LowBalance-Mapping.pdf) ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::VeriSign::PollLowBalance; use strict; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::VeriSign::PollLowBalance - EPP Low Balance Mapping (EPP-LowBalance-Mapping.pdf) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( lowbalance => [ undef, \&parse ], ); return { 'message' => \%tmp }; } #################################################################################################### sub parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_response('http://www.verisign.com/epp/lowbalance-poll-1.0','pollData'); return unless $infdata; my %w=(action => 'lowbalance_notification'); my $c=$infdata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name=~m/^(registrarName|creditLimit|availableCredit)$/) { $w{Net::DRI::Util::remcam($name)}=$c->getFirstChild()->getData(); } elsif ($name eq 'creditThreshold') { $w{Net::DRI::Util::remcam($name)}=$c->getFirstChild()->getData(); $w{'credit_threshold_type'}=$c->getAttribute('type'); } } continue { $c=$c->getNextSibling(); } $rinfo->{session}->{lowbalance}=\%w; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/IDNLanguage.pm0000644000175000017500000000554211352534377025146 0ustar patrickpatrick## Domain Registry Interface, EPP IDN Language (EPP-IDN-Lang-Mapping.pdf) ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::VeriSign::IDNLanguage; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::VeriSign::IDNLanguage - EPP IDN Language commands (EPP-IDN-Lang-Mapping.pdf) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( create => [ \&create, undef ], ); return { 'domain' => \%tmp }; } #################################################################################################### ############ Transform commands sub create { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); return unless ($domain=~/^xn--/); Net::DRI::Exception::usererr_insufficient_parameters('Language tag must be provided') unless Net::DRI::Util::has_key($rd,'language'); Net::DRI::Exception::usererr_invalid_parameters('IDN language tag must be of type XML schema language') unless Net::DRI::Util::xml_is_language($rd->{language}); my $eid=$mes->command_extension_register('idnLang:tag','xmlns:idnLang="http://www.verisign.com/epp/idnLang-1.0" xsi:schemaLocation="http://www.verisign.com/epp/idnLang-1.0 idnLang-1.0.xsd"'); $mes->command_extension($eid,$rd->{language}); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/JobsContact.pm0000644000175000017500000001134611352534377025300 0ustar patrickpatrick## Domain Registry Interface, .JOBS contact extension ## ## Copyright (c) 2008 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::VeriSign::JobsContact; use strict; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::VeriSign::JobsContact - .JOBS EPP contact extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E and Ehttp://oss.bdsprojects.net/projects/netdri/E =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %contacttmp=( create => [ \&create, undef ], update => [ \&update, undef ], info => [ undef, \&info_parse ] ); return { 'contact' => \%contacttmp }; } our @NS=('http://www.verisign.com/epp/jobsContact-1.0','http://www.verisign.com/epp/jobsContact-1.0 jobsContact-1.0.xsd'); #################################################################################################### ############ Transform commands sub add_job { my ($cmd, $epp, $contact, $rd) = @_; my $mes = $epp->message(); my $info; my @jobdata; return unless Net::DRI::Util::isa_contact($contact, 'Net::DRI::Data::Contact::JOBS'); $info = $contact->jobinfo(); return unless (defined($info) && (ref($info) eq 'HASH') && keys(%$info)); push(@jobdata, ['jobsContact:title', $info->{title}]) if (defined($info->{title}) && length($info->{title})); push(@jobdata, ['jobsContact:website', $info->{website}]) if (defined($info->{website}) && length($info->{website})); push(@jobdata, ['jobsContact:industryType', $info->{industry}]) if (defined($info->{industry}) && length($info->{industry})); push(@jobdata, ['jobsContact:isAdminContact', (defined($info->{admin}) && $info->{admin} ? 'Yes' : 'No')]) if (defined($info->{admin}) && length($info->{admin})); push(@jobdata, ['jobsContact:isAssociationMember', (defined($info->{member}) && $info->{member} ? 'Yes' : 'No')]) if (defined($info->{member}) && length($info->{member})); return unless (@jobdata); my $eid = $mes->command_extension_register('jobsContact:' . $cmd,sprintf('xmlns:jobsContact="%s" xsi:schemaLocation="%s"',@NS)); $mes->command_extension($eid, \@jobdata); } sub create { return add_job('create', @_); } sub update { return add_job('update', @_); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes = $po->message(); my $infdata = $mes->get_extension($NS[0],'infData'); return unless (defined($infdata)); my $jobinfo = {}; my $c; $c = $infdata->getChildrenByTagNameNS($NS[0], 'title'); $jobinfo->{title} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getChildrenByTagNameNS($NS[0], 'website'); $jobinfo->{website} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getChildrenByTagNameNS($NS[0], 'industryType'); $jobinfo->{industry} = $c->shift()->getFirstChild()->getData() if ($c); $c = $infdata->getChildrenByTagNameNS($NS[0], 'isAdminContact'); $jobinfo->{admin} = (lc($c->shift()->getFirstChild()->getData()) eq 'yes')? 1 : 0 if ($c); $c = $infdata->getChildrenByTagNameNS($NS[0], 'isAssociationMember'); $jobinfo->{member} = (lc($c->shift()->getFirstChild()->getData()) eq 'yes')? 1 : 0 if ($c); my $contact = $rinfo->{$otype}->{$oname}->{self}; $contact->jobinfo($jobinfo); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/Sync.pm0000644000175000017500000000620211352534377023776 0ustar patrickpatrick## Domain Registry Interface, EPP Sync aka ConsoliDate (draft-hollenbeck-epp-sync-01) ## ## Copyright (c) 2006,2007 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::VeriSign::Sync; use strict; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Core::Domain; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::VeriSign::Sync - EPP Sync commands (draft-hollenbeck-epp-sync-01) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( update => [ \&update, undef ], ); return { 'domain' => \%tmp }; } sub capabilities_add { return ('domain_update','sync',['set']); } #################################################################################################### ############ Transform commands sub update { my ($epp,$domain,$todo)=@_; my $mes=$epp->message(); my $sync=$todo->set('sync'); return unless (defined($sync) && $sync); my $date; if (ref($sync)) { Net::DRI::Util::check_isa($sync,'DateTime'); $date=$sync->strftime('--%m-%d'); } else { Net::DRI::Exception::usererr_invalid_parameters('Sync date must be of type XML Schema gMonthDay') unless ($sync=~m/^(?:--)?(\d{2}-\d{2})$/); $date='--'.$1; } Net::DRI::Exception::usererr_invalid_parameters('Sync operation can not be mixed with other domain changes') if (grep { $_ ne 'sync' } $todo->types()); my $eid=$mes->command_extension_register('sync:update','xmlns:sync="http://www.verisign.com/epp/sync-1.0" xsi:schemaLocation="http://www.verisign.com/epp/sync-1.0 sync-1.0.xsd"'); $mes->command_extension($eid,['sync:expMonthDay',$date]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/VeriSign/WhoisInfo.pm0000644000175000017500000000743211352534377024775 0ustar patrickpatrick## Domain Registry Interface, EPP Whois Info (EPP-Whois-Info-Ext.pdf) ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::VeriSign::WhoisInfo; use strict; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::VeriSign::WhoisInfo - EPP Whois Info (EPP-Whois-Info-Ext.pdf) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ \&info, \&info_parse ], ); return { 'domain' => \%tmp }; } #################################################################################################### sub info { my ($epp,$domain,$rd)=@_; my $mes=$epp->message(); my $wi; if (Net::DRI::Util::has_key($rd,'whois_info')) { $wi=$rd->{whois_info}; } else { my $def=$epp->default_parameters(); if (Net::DRI::Util::has_key($def,'whois_info')) { $wi=$def->{whois_info}; } else { Net::DRI::Exception::usererr_insufficient_parameters('Whois Info must be provided'); } } Net::DRI::Exception::usererr_invalid_parameters('Whois Info must be true/false/1/0') unless Net::DRI::Util::xml_is_boolean($wi); my $eid=$mes->command_extension_register('whoisInf:whoisInf','xmlns:whoisInf="http://www.verisign.com/epp/whoisInf-1.0" xsi:schemaLocation="http://www.verisign.com/epp/whoisInf-1.0 whoisInf-1.0.xsd"'); $mes->command_extension($eid,['whoisInf:flag',$wi]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $infdata=$mes->get_extension('http://www.verisign.com/epp/whoisInf-1.0','whoisInfData'); return unless $infdata; my %w; my $c=$infdata->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname() || $c->nodeName(); next unless $name; if ($name eq 'registrar') { $w{registrar}=$c->getFirstChild()->getData(); } elsif ($name eq 'whoisServer') { $w{whois_server}=$c->getFirstChild()->getData(); } elsif ($name eq 'url') { $w{url}=$c->getFirstChild()->getData(); } elsif ($name eq 'irisServer') { $w{iris_server}=$c->getFirstChild()->getData(); } } continue { $c=$c->getNextSibling(); } $rinfo->{domain}->{$oname}->{whois_info}=\%w; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/LU.pm0000644000175000017500000000527311352534377021663 0ustar patrickpatrick## Domain Registry Interface, DNSLU EPP extensions ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::LU; use strict; use warnings; use base qw/Net::DRI::Protocol::EPP/; use Net::DRI::Protocol::EPP::Extensions::LU::Status; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::LU - DNSLU EPP extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub setup { my ($self,$rp)=@_; $self->ns({dnslu => ['http://www.dns.lu/xml/epp/dnslu-1.0','dnslu-1.0.xsd']}); $self->capabilities('contact_update','status',undef); ## No changes in status possible for .LU contacts $self->capabilities('contact_update','disclose',['add','del']); $self->capabilities('host_update','status',undef); $self->capabilities('domain_update','registrant',undef); ## a trade is needed $self->capabilities('domain_update','auth',undef); ## not used $self->factories('status',sub { return Net::DRI::Protocol::EPP::Extensions::LU::Status->new(); }); $self->default_parameters({domain_create => { auth => { pw => '' }, duration => undef } }); ## authInfo and period not used return; } sub default_extensions { return qw/LU::Domain LU::Contact LU::Poll/; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SE/0002755000175000017500000000000011352534417021302 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SE/Extensions.pm0000644000175000017500000003223311352534377024005 0ustar patrickpatrick## Domain Registry Interface, .SE EPP Domain/Contact Extensions for Net::DRI ## Contributed by Elias Sidenbladh and Ulrich Wisser from NIC SE ## ## Copyright (c) 2006,2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SE::Extensions; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::EPP::Util; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SE::Extensions - .SE EPP Domain/Contact Extensions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ################################################################################################### sub register_commands { my ( $class, $version ) = @_; my $domain = { info => [ undef, \&domain_parse ], create => [ undef, \&domain_parse ], update => [ \&domain_update, \&domain_parse ], transfer_request => [ \&domain_transfer, undef ], notifyDelete => [ undef, \&delete_parse ], }; my $contact = { info => [ undef, \&contact_parse ], create => [ \&contact_create, undef ], update => [ \&contact_update, undef ], transfer_request => [ undef, \&contact_transfer_parse ], }; my $host = { info => [ undef, \&host_parse ], transfer_request => [ undef, \&host_transfer_parse ], }; return { 'domain' => $domain, 'contact' => $contact, 'host' => $host, }; } sub capabilities_add { return ( [ 'domain_update', 'client_delete', [ 'set', ] ], ); } ################################################################################################### sub get_notify { my $mes = shift; my $ns=$mes->ns('iis'); # only one of these will be given, but we can't know which in advance return 'create' if defined $mes->get_response($ns, 'createNotify' ); return 'update' if defined $mes->get_response($ns, 'updateNotify' ); return 'delete' if defined $mes->get_response($ns, 'deleteNotify' ); return 'transfer' if defined $mes->get_response($ns, 'transferNotify' ); # done, no notify found return; } ################################################################################################## ########### Query commands # parse domain info sub domain_parse { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); return unless $mes->is_success(); # only domain info should be parsed return if ( ( !defined $otype ) || ( $otype ne 'domain' ) ); # check for notify my $notify = get_notify($mes); $rinfo->{domain}->{$oname}->{notify} = $notify if defined $notify; # get from my $infData = $mes->get_extension( $mes->ns('iis'), 'infData' ); return unless defined $infData; # parse deleteDate (optional) foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'delDate' ) ) { $rinfo->{domain}->{$oname}->{delDate} = $po->parse_iso8601( $el->textContent() ); } # parse deactDate (optional) foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'deactDate' ) ) { $rinfo->{domain}->{$oname}->{deactDate} = $po->parse_iso8601( $el->textContent() ); } # parse relDate (optional) foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'relDate' ) ) { $rinfo->{domain}->{$oname}->{relDate} = $po->parse_iso8601( $el->textContent() ); } # parse state foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'state' ) ) { $rinfo->{domain}->{$oname}->{state} = $el->textContent(); } # done return; } # parse contact info sub contact_parse { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); return unless $mes->is_success(); # only contact info should be parsed return if ( ( !defined $otype ) || ( $otype ne 'contact' ) ); # check for notify my $notify = get_notify($mes); $rinfo->{contact}->{$oname}->{notify} = $notify if defined $notify; # get from my $result = $mes->get_extension( $mes->ns('iis'), 'infData' ); return unless defined $result; # parse orgno (mandatory) foreach my $el ( $result->getElementsByTagNameNS( $mes->ns('iis'), 'orgno' ) ) { $rinfo->{contact}->{$oname}->{self}->orgno( $el->textContent() ); } # parse vatno (optional) foreach my $el ( $result->getElementsByTagNameNS( $mes->ns('iis'), 'vatno' ) ) { $rinfo->{contact}->{$oname}->{self}->vatno( $el->textContent() ); } # done return; } sub host_parse { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); return unless $mes->is_success(); # only contact info should be parsed return if ( ( !defined $otype ) || ( $otype ne 'host' ) ); # check for notify my $notify = get_notify($mes); $rinfo->{host}->{$oname}->{notify} = $notify if defined $notify; # done return; } # parse # copied from Net::DRI::Protocol::EPP::Core::Domain sub host_transfer_parse { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $trndata = $mes->get_response( $mes->ns('host'), 'trnData' ); return unless defined $trndata; foreach my $el (Net::DRI::Util::xml_list_children($trndata)) { my ($name,$c)=@$el; if ( $name eq 'name' ) { $oname = $c->textContent(); $rinfo->{host}->{$oname}->{action} = 'transfer'; $rinfo->{host}->{$oname}->{exist} = 1; } elsif ( $name =~ m/^(trStatus|reID|acID)$/ ) { $rinfo->{host}->{$oname}->{$1} = $c->textContent(); } elsif ( $name =~ m/^(reDate|acDate|exDate)$/ ) { $rinfo->{host}->{$oname}->{$1} = $po->parse_iso8601( $c->textContent() ); } } # check for notify my $notify = get_notify($mes); $rinfo->{host}->{$oname}->{notify} = $notify if defined $notify; # done return; } sub contact_transfer_parse { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $mes = $po->message(); return unless $mes->is_success(); my $trndata = $mes->get_response( $mes->ns('contact'), 'trnData' ); return unless defined $trndata; foreach my $el (Net::DRI::Util::xml_list_children($trndata)) { my ($name,$c)=@$el; if ( $name eq 'id' ) { $oname = $c->textContent(); $rinfo->{contact}->{$oname}->{action} = 'transfer'; $rinfo->{contact}->{$oname}->{exist} = 1; } elsif ( $name =~ m/^(trStatus|reID|acID)$/ ) { $rinfo->{contact}->{$oname}->{$1} = $c->textContent(); } elsif ( $name =~ m/^(reDate|acDate|exDate)$/ ) { $rinfo->{contact}->{$oname}->{$1} = $po->parse_iso8601( $c->textContent() ); } } # check for notify my $notify = get_notify($mes); $rinfo->{contact}->{$oname}->{notify} = $notify if defined $notify; # done return; } # parse delete message sub delete_parse { my ( $po, $otype, $oaction, $oname, $rinfo ) = @_; my $nametag; my $mes = $po->message(); return unless $mes->is_success(); # check for notify my $notify = get_notify($mes); return if ( ( !defined $notify ) || ( $notify ne 'delete' ) ); # check for host my $host = $mes->get_response( $mes->ns('host'), 'name' ); if ( defined $host ) { $oname = $host->textContent(); $otype = 'host'; } # check for contact my $contact = $mes->get_response( $mes->ns('contact'), 'id' ); if ( defined $contact ) { $oname = $contact->textContent(); $otype = 'contact'; } # check for domain my $domain = $mes->get_response( $mes->ns('domain'), 'name' ); if ( defined $domain ) { $oname = $domain->textContent(); $otype = 'domain'; } $rinfo->{$otype}->{$oname}->{notify} = $notify; $rinfo->{$otype}->{$oname}->{action} = 'delete'; $rinfo->{$otype}->{$oname}->{exist} = 0; # done return; } # domain update command extension sub domain_update { my ( $epp, $domain, $rd ) = @_; my @data = (); my $mes = $epp->message(); # iis:clientDelete if ( exists $rd->{client_delete} ) { Net::DRI::Exception::usererr_invalid_parameters("client_delete can only be '1' or '0'") if ( $rd->{client_delete}[2] !~ /^(0|1)$/ ); push @data, [ 'iis:clientDelete', $rd->{client_delete}[2] ]; } # only add extension if any data gets added return unless @data; # create my $iis_extension = $mes->command_extension_register( 'iis:update', 'xmlns:iis="' . $mes->ns('iis') . '" xsi:schemaLocation="' . $mes->ns('iis') . ' iis-1.1.xsd"' ); # now add extension to message $mes->command_extension( $iis_extension, \@data ); # done return; } sub domain_transfer { my ( $epp, $domain, $rd ) = @_; my @data = (); my $mes = $epp->message(); # new nameservers (optional) push @data, [ 'iis:ns', map { [ 'iis:hostObj', $_ ] } $rd->{ns}->get_names() ] if Net::DRI::Util::has_ns($rd); # only add body if any data gets added return unless @data; # create my $iis_extension = $mes->command_extension_register( 'iis:transfer', 'xmlns:iis="' . $mes->ns('iis') . '" xsi:schemaLocation="' . $mes->ns('iis') . ' iis-1.1.xsd" xmlns:domain="urn:ietf:params:xml:ns:domain-1.0"' ); # now add extension to message $mes->command_extension( $iis_extension, \@data ); # done return; } # contact create command extension sub contact_create { my ( $epp, $contact, $rd ) = @_; my @data = (); my $mes = $epp->message(); # iis:orgno (mandatory) my $orgno; $orgno = $rd->{orgno} if exists( $rd->{orgno} ); $orgno = $contact->{orgno} if exists( $contact->{orgno} ); $orgno = $contact->orgno if $contact->can('orgno'); Net::DRI::Exception::usererr_insufficient_parameters('Attribute orgno must exist') unless defined $orgno; push @data, [ 'iis:orgno', $orgno ]; # iis:vatno (optional) my $vatno; $vatno = $rd->{orgno} if exists( $rd->{vatno} ); $vatno = $contact->{vatno} if exists( $contact->{vatno} ); $vatno = $contact->vatno if $contact->can('vatno'); if ( exists( $rd->{vatno} ) && $vatno ) { push @data, [ 'iis:vatno', $vatno ]; } # only add extension if any data gets added return unless @data; # create my $iis_extension = $mes->command_extension_register( 'iis:create', 'xmlns:iis="' . $mes->ns('iis') . '" xsi:schemaLocation="' . $mes->ns('iis') . ' iis-1.1.xsd"' ); # now add extension to message $mes->command_extension( $iis_extension, \@data ); # done return; } # contact update command extension sub contact_update { my ( $epp, $contact, $rd ) = @_; my @data = (); my $mes = $epp->message(); # get the new contact information my $newc = $rd->set('info'); return unless defined $newc && ref $newc; # iis:orgno (mandatory) Net::DRI::Exception::usererr_insufficient_parameters('Attribute orgno can not be updated') if exists( $newc->{orgno} ); # iis:vatno (optional) if ( exists( $newc->{vatno} ) && defined $newc->{vatno} ) { push @data, [ 'iis:vatno', $newc->{vatno} ]; } # only add extension if any data gets added return unless @data; # create my $iis_extension = $mes->command_extension_register( 'iis:update', 'xmlns:iis="' . $mes->ns('iis') . '" xsi:schemaLocation="' . $mes->ns('iis') . ' iis-1.1.xsd"' ); # now add extension to message $mes->command_extension( $iis_extension, \@data ); # done return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Extensions/SE/Message.pm0000644000175000017500000000475011352534377023235 0ustar patrickpatrick## Domain Registry Interface, EPP Message class for .SE ## Contributed by Ulrich Wisser from NIC SE ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Extensions::SE::Message; use strict; use warnings; use base 'Net::DRI::Protocol::EPP::Message'; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Extensions::SE::Message - .SE EPP Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### # # This is an exact copy of Net::DRI::Protocol::EPP::Message::_get_content # Only getChildrenByTagNameNS has been replaced with getElementsByTagNameNS # to enable parsing of inside elements. # sub _get_content { my ( $self, $node, $nstag, $nodename ) = @_; return unless ( defined($node) && defined($nstag) && $nstag && defined($nodename) && $nodename ); my $ns = $self->ns($nstag); $ns = $nstag unless defined($ns) && $ns; my @tmp = $node->getElementsByTagNameNS( $ns, $nodename ); return unless @tmp; return $tmp[0]; } #################################################################################################### 1;Net-DRI-0.96/lib/Net/DRI/Protocol/EPP/Message.pm0000644000175000017500000002477511352534377020600 0ustar patrickpatrick## Domain Registry Interface, EPP Message ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP::Message; use strict; use warnings; use DateTime::Format::ISO8601 (); use DateTime (); use XML::LibXML (); use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Util; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version command command_body cltrid svtrid msg_id node_resdata node_extension node_msg result_greeting)); our $VERSION=do { my @r=(q$Revision: 1.25 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP::Message - EPP Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $proto=shift; my $class=ref($proto) || $proto; my $trid=shift; my $self={ results => [], ns => {} }; bless($self,$class); $self->cltrid($trid) if (defined($trid) && $trid); return $self; } sub _get_result { my ($self,$what,$pos)=@_; $pos=0 unless defined($pos); my $rh=$self->{results}->[$pos]; return unless (defined($rh) && (ref($rh) eq 'HASH') && keys(%$rh)==4); return $rh->{$what}; } ## TODO : these are not very useful here, they should be done in ResultStatus ## (they are only used from t/241epp_message.t) sub results { return @{shift->{results}}; } sub results_code { return map { $_->{code} } shift->results(); } sub results_message { return map { $_->{message} } shift->results(); } sub results_lang { return map { $_->{lang} } shift->results(); } sub results_extra_info { return map { $_->{extra_info} } shift->results(); } sub result_code { return shift->_get_result('code',@_); } sub result_message { return shift->_get_result('message',@_); } sub result_lang { return shift->_get_result('lang',@_); } sub result_extra_info { return shift->_get_result('extra_info',@_); } sub ns { my ($self,$what)=@_; return $self->{ns} unless defined($what); if (ref($what) eq 'HASH') { $self->{ns}=$what; return $what; } return unless exists($self->{ns}->{$what}); return $self->{ns}->{$what}->[0]; } sub nsattrs { my ($self,$what)=@_; return unless (defined($what) && exists($self->{ns}->{$what})); my @n=@{$self->{ns}->{$what}}; return ($n[0],$n[0],$n[1]); } sub is_success { return _is_success(shift->result_code()); } sub _is_success { return (shift=~m/^1/)? 1 : 0; } ## 1XXX is for success, 2XXX for failures sub result_status { my $self=shift; my $prev; foreach my $rs (reverse(@{$self->{results}})) { my $rso=Net::DRI::Protocol::ResultStatus->new('epp',$rs->{code},undef,_is_success($rs->{code}),$rs->{message},$rs->{lang},$rs->{extra_info}); $rso->_set_trid([ $self->cltrid(),$self->svtrid() ]); $rso->_add_next($prev) if defined($prev); $prev=$rso; } return $prev; } sub command_extension_register { my ($self,$ocmd,$ons)=@_; $self->{extension}=[] unless exists($self->{extension}); my $eid=1+$#{$self->{extension}}; $self->{extension}->[$eid]=[$ocmd,$ons,[]]; return $eid; } sub command_extension { my ($self,$eid,$rdata)=@_; if (defined($eid) && ($eid >= 0) && ($eid <= $#{$self->{extension}}) && defined($rdata) && (((ref($rdata) eq 'ARRAY') && @$rdata) || ($rdata ne ''))) { $self->{extension}->[$eid]->[2]=(ref($rdata) eq 'ARRAY')? [ @{$self->{extension}->[$eid]->[2]}, @$rdata ] : $rdata; } else { return $self->{extension}; } } sub as_string { my ($self)=@_; my $ens=sprintf('xmlns="%s" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="%s %s"',$self->nsattrs('_main')); my @d; push @d,''; push @d,''; my ($cmd,$ocmd,$ons); my $rc=$self->command(); ($cmd,$ocmd,$ons)=@$rc if (defined($rc) && ref($rc)); my $attr=''; ($cmd,$attr)=($cmd->[0],' '.join(' ',map { $_.'="'.$cmd->[1]->{$_}.'"' } keys(%{$cmd->[1]}))) if (defined($cmd) && ref($cmd)); if (defined($cmd)) { push @d,'' if ($cmd ne 'hello'); my $body=$self->command_body(); if (!defined $ocmd && !defined $body) { push @d,'<'.$cmd.$attr.'/>'; } else { push @d,'<'.$cmd.$attr.'>'; if (defined $body && length $body) { push @d,(defined $ocmd && length $ocmd)? ('<'.$ocmd.' '.$ons.'>',Net::DRI::Util::xml_write($body),'') : Net::DRI::Util::xml_write($body); } else { push @d,'<'.$ocmd.' '.$ons.'/>'; } push @d,''; } } ## OPTIONAL extension my $ext=$self->{extension}; if (defined($ext) && (ref($ext) eq 'ARRAY') && @$ext) { push @d,''; foreach my $e (@$ext) { my ($ecmd,$ens,$rdata)=@$e; if ($ecmd && $ens) { push @d,'<'.$ecmd.' '.$ens.'>'; push @d,ref($rdata)? Net::DRI::Util::xml_write($rdata) : Net::DRI::Util::xml_escape($rdata); push @d,''; } else { push @d,Net::DRI::Util::xml_escape(@$rdata); } } push @d,''; } ## OPTIONAL clTRID my $cltrid=$self->cltrid(); if (defined($cmd) && ($cmd ne 'hello')) { push @d,''.$cltrid.'' if (defined($cltrid) && $cltrid && Net::DRI::Util::xml_is_token($cltrid,3,64)); push @d,''; } push @d,''; return join('',@d); } sub get_response { my $self=shift; return $self->_get_content($self->node_resdata(),@_); } sub get_extension { my $self=shift; return $self->_get_content($self->node_extension(),@_); } sub _get_content { my ($self,$node,$nstag,$nodename)=@_; return unless (defined($node) && defined($nstag) && $nstag && defined($nodename) && $nodename); my $ns=$self->ns($nstag); $ns=$nstag unless defined($ns) && $ns; my @tmp=$node->getChildrenByTagNameNS($ns,$nodename); return unless @tmp; return $tmp[0]; } sub parse { my ($self,$dc,$rinfo)=@_; my $NS=$self->ns('_main'); my $parser=XML::LibXML->new(); my $doc=$parser->parse_string($dc->as_string()); my $root=$doc->getDocumentElement(); Net::DRI::Exception->die(0,'protocol/EPP',1,'Unsuccessfull parse, root element is not epp') unless ($root->getName() eq 'epp'); if (my $g=$root->getChildrenByTagNameNS($NS,'greeting')) { push @{$self->{results}},{ code => 1000, message => undef, lang => undef, extra_info => []}; ## fake an OK $self->result_greeting($self->parse_greeting($g->get_node(1))); return; } my $c=$root->getChildrenByTagNameNS($NS,'response'); Net::DRI::Exception->die(0,'protocol/EPP',1,'Unsuccessfull parse, no response block') unless ($c->size()==1); my $res=$c->get_node(1); ## result block(s) foreach my $result ($res->getChildrenByTagNameNS($NS,'result')) ## one element if success, multiple elements if failure RFC4930 §2.6 { push @{$self->{results}},Net::DRI::Protocol::EPP::Util::parse_result($result,$NS); } $c=$res->getChildrenByTagNameNS($NS,'msgQ'); $rinfo->{message}->{info}={ count => 0, checked_on => DateTime->now() }; if ($c->size()) ## OPTIONAL { my $msgq=$c->get_node(1); my $id=$msgq->getAttribute('id'); ## id of the message that has just been retrieved and dequeued (RFC4930) OR id of *next* available message (RFC3730) $rinfo->{message}->{info}->{id}=$id; $rinfo->{message}->{info}->{count}=$msgq->getAttribute('count'); if ($msgq->hasChildNodes()) ## We will have childs only as a result of a poll request { my %d=( id => $id ); $self->msg_id($id); $d{qdate}=DateTime::Format::ISO8601->new()->parse_datetime(Net::DRI::Util::xml_child_content($msgq,$NS,'qDate')); my $msgc=$msgq->getChildrenByTagNameNS($NS,'msg')->get_node(1); $d{lang}=$msgc->getAttribute('lang') || 'en'; if (grep { $_->nodeType() == 1 } $msgc->childNodes()) { $d{content}=$msgc->toString(); $self->node_msg($msgc); } else { $d{content}=$msgc->textContent(); } $rinfo->{message}->{$id}=\%d; } } $c=$res->getChildrenByTagNameNS($NS,'resData'); $self->node_resdata($c->get_node(1)) if ($c->size()); ## OPTIONAL $c=$res->getChildrenByTagNameNS($NS,'extension'); $self->node_extension($c->get_node(1)) if ($c->size()); ## OPTIONAL ## trID my $trid=$res->getChildrenByTagNameNS($NS,'trID')->get_node(1); ## we search only for as direct child of , hence getChildren and not getElements ! my $tmp=Net::DRI::Util::xml_child_content($trid,$NS,'clTRID'); $self->cltrid($tmp) if defined($tmp); $tmp=Net::DRI::Util::xml_child_content($trid,$NS,'svTRID'); $self->svtrid($tmp) if defined($tmp); } sub add_to_extra_info { my ($self,$data)=@_; push @{$self->{results}->[-1]->{extra_info}},$data; } ## Move to Core/Session ? sub parse_greeting { my ($self,$g)=@_; my %tmp; foreach my $el (Net::DRI::Util::xml_list_children($g)) { my ($n,$c)=@$el; if ($n=~m/^(svID|svDate)$/) { $tmp{$1}=$c->textContent(); } elsif ($n eq 'svcMenu') { foreach my $sel (Net::DRI::Util::xml_list_children($c)) { my ($nn,$cc)=@$sel; if ($nn=~m/^(version|lang)$/) { push @{$tmp{$1}},$cc->textContent(); } elsif ($nn eq 'objURI') { push @{$tmp{svcs}},$cc->textContent(); } elsif ($nn eq 'svcExtension') { push @{$tmp{svcext}},map { $_->textContent() } grep { $_->getName() eq 'extURI' } $cc->getChildNodes(); } } } elsif ($n eq 'dcp') { $tmp{dcp}=$c->toString(); ## does someone really need this data ?? } } return \%tmp; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OpenSRS/0002755000175000017500000000000011352534417017501 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/OpenSRS/XCP.pm0000644000175000017500000000541611352534377020502 0ustar patrickpatrick## Domain Registry Interface, OpenSRS XCP Protocol ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::OpenSRS::XCP; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Protocol::OpenSRS::XCP::Message; use Net::DRI::Data::Contact::OpenSRS; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OpenSRS::XCP - OpenSRS XCP Protocol for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('opensrs_xcp'); $self->version('3.0'); ## Specification March 17, 2008 $self->factories('message',sub { my $m=Net::DRI::Protocol::OpenSRS::XCP::Message->new(); return $m; }); ## $self->factories('message',sub { my $m=Net::DRI::Protocol::OpenSRS::XCP::Message->new(@_); $m->client_auth({id => $drd->{client_login}, pw => $drd->{client_password}}); return $m; }); $self->factories('contact',sub { return Net::DRI::Data::Contact::OpenSRS->new(); }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; my @class=map { 'Net::DRI::Protocol::OpenSRS::XCP::'.$_ } (qw/Account Domain Session/); $self->SUPER::_load(@class); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::OpenSRS::XCP::Connection', protocol_version => '3.0'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OpenSRS/XCP/0002755000175000017500000000000011352534417020133 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/OpenSRS/XCP/Connection.pm0000644000175000017500000000643211352534377022600 0ustar patrickpatrick## Domain Registry Interface, OpenSRS XCP Connection handling ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::OpenSRS::XCP::Connection; use strict; use Digest::MD5 (); use HTTP::Request (); use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OpenSRS::XCP::Connection - OpenSRS XCP Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub init { my ($class,$to)=@_; my $t=$to->transport_data(); foreach my $p (qw/client_login client_password remote_url/) { Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p}); } } ## From Protocol Message object to something suitable for transport (various types) sub write_message { my ($class,$to,$msg)=@_; my $t=$to->transport_data(); my $req=HTTP::Request->new('POST',$t->{remote_url}); $req->header('Content-Type','text/xml'); $req->header('X-Username',$t->{client_login}); my $body=$msg->get_body(); $req->header('X-Signature',Digest::MD5::md5_hex(Digest::MD5::md5_hex($body,$t->{client_password}),$t->{client_password})); ## client_password is in fact the reseller key $req->content(Net::DRI::Util::encode_utf8($body)); ## Content-Length will be automatically computed during Transport by LWP::UserAgent return $req; } ## From transport (various types) to Net::DRI::Data::Raw object (which will be parsed inside Protocol::reaction) sub read_data { my ($class,$to,$res)=@_; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING',sprintf('Got unsuccessfull HTTP response: %d %s',$res->code(),$res->message()),'en')) unless $res->is_success(); return Net::DRI::Data::Raw->new_from_xmlstring($res->decoded_content()); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OpenSRS/XCP/Account.pm0000644000175000017500000000541711352534377022077 0ustar patrickpatrick## Domain Registry Interface, OpenSRS XCP Account commands ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::OpenSRS::XCP::Account; use strict; use Net::DRI::Exception; use DateTime; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OpenSRS::XCP::Account - OpenSRS XCP Account commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( list_domains => [\&list_domains, \&list_domains_parse ], ); return { 'account' => \%tmp }; } sub list_domains { my ($xcp)=@_; my $msg=$xcp->message(); $msg->command({action=>'get_domains_by_expiredate',object=>'domain'}); $msg->command_attributes({exp_from=>DateTime->from_epoch(epoch => time()-60*60*24)->strftime('%F'),exp_to=>'2030-01-01',limit=>1000000}); ## We have to provide a limit ! } sub list_domains_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); my $ra=$mes->response_attributes(); my $rd=$ra->{'exp_domains'}; Net::DRI::Exception->die(1,'protocol/opensrs/xcp',1,'Unexpected reply for get_domains_by_expiredate: '.$rd) unless (defined($rd) && ref($rd) eq 'ARRAY'); my @r=map { $_->{name} } @$rd; $rinfo->{account}->{domains}->{action}='list'; $rinfo->{account}->{domains}->{list}=\@r; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OpenSRS/XCP/Session.pm0000644000175000017500000000570011352534377022121 0ustar patrickpatrick## Domain Registry Interface, OpenSRS XCP Session commands ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::OpenSRS::XCP::Session; use strict; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OpenSRS::XCP::Session - OpenSRS XCP Session commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( set_cookie => [\&set_cookie, \&set_cookie_parse ], ); return { 'session' => \%tmp }; } sub set_cookie { my ($xcp,$ep)=@_; my $msg=$xcp->message(); Net::DRI::Exception::usererr_insufficient_parameters('Domain+Username+Password are required for session_set_cookie') if grep { ! Net::DRI::Util::has_key($ep,$_) } qw/domain username password/; my %r=(action=>'set',object=>'cookie'); $r{registrant_ip}=$ep->{registrant_ip} if Net::DRI::Util::has_key($ep,'registrant_ip'); $msg->command(\%r); $msg->command_attributes({domain => $ep->{domain}, reg_username=> $ep->{username}, reg_password => $ep->{password}}); } sub set_cookie_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); my $ra=$mes->response_attributes(); ## We do not parse all other attributes: f_owner, domain_count, permission, last_access_time, expiredate, last_ip, waiting_requests_no, redirect_url my $rd=$ra->{'cookie'}; $rinfo->{session}->{cookie}->{action}='set'; $rinfo->{session}->{cookie}->{value}=$rd; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OpenSRS/XCP/Domain.pm0000644000175000017500000003634611352534377021717 0ustar patrickpatrick## Domain Registry Interface, OpenSRS XCP Domain commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::OpenSRS::XCP::Domain; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OpenSRS::XCP::Domain - OpenSRS XCP Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [\&info, \&info_parse ], check => [\&check, \&check_parse ], create => [ \&create, \&create_parse ], ## TODO : parsing of return messages delete => [ \&delete, \&delete_parse ], renew => [ \&renew, \&renew_parse ], transfer_request => [ \&transfer_request, \&transfer_request_parse ], transfer_query => [ \&transfer_query, \&transfer_query_parse ], transfer_cancel => [ \&transfer_cancel, \&transfer_cancel_parse ], ); return { 'domain' => \%tmp }; } sub build_msg_cookie { my ($msg,$action,$cookie,$regip)=@_; my %r=(action=>$action,object=>'domain',cookie=>$cookie); $r{registrant_ip}=$regip if defined($regip); $msg->command(\%r); } sub info { my ($xcp,$domain,$rd)=@_; my $msg=$xcp->message(); Net::DRI::Exception::usererr_insufficient_parameters('A cookie is needed for domain_info') unless Net::DRI::Util::has_key($rd,'cookie'); build_msg_cookie($msg,'get',$rd->{cookie},$rd->{registrant_ip}); $msg->command_attributes({type => 'all_info'}); } sub info_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='info'; $rinfo->{domain}->{$oname}->{exist}=1; my $ra=$mes->response_attributes(); ## Not parsed: dns_errors, descr my %d=(registry_createdate => 'crDate', registry_expiredate => 'exDate', registry_updatedate => 'upDate', registry_transferdate => 'trDate', expiredate => 'exDateLocal'); while (my ($k,$v)=each(%d)) { next unless exists($ra->{$k}); $ra->{$k}=~s/\s+/T/; ## with a little effort we become ISO8601 $rinfo->{domain}->{$oname}->{$v}=$xcp->parse_iso8601($ra->{$k}); } my $ns=$ra->{nameserver_list}; if (defined($ns) && ref($ns) && @$ns) { my $nso=$xcp->create_local_object('hosts'); foreach my $h (@$ns) { $nso->add($h->{name},[$h->{ipaddress}]); } $rinfo->{domain}->{$oname}->{ns}=$nso; } foreach my $bool (qw/sponsoring_rsp auto_renew let_expire/) { next unless exists($ra->{$bool}); $rinfo->{domain}->{$oname}->{$bool}=$ra->{$bool}; } my $c=$ra->{contact_set}; if (defined($c) && ref($c) && keys(%$c)) { my $cs=$xcp->create_local_object('contactset'); while (my ($type,$v)=each(%$c)) { my $c=parse_contact($xcp,$v); $cs->add($c,$type eq 'owner'? 'registrant' : $type); } $rinfo->{domain}->{$oname}->{contact}=$cs; } ## No data about status ? } sub parse_contact { my ($xcp,$rh)=@_; my $c=$xcp->create_local_object('contact'); ## No ID given back ! Waouh that is great... not ! $c->firstname($rh->{first_name}); $c->name($rh->{last_name}); $c->org($rh->{org_name}) if exists($rh->{org_name}); $c->street([map { $rh->{'address'.$_} } grep {exists($rh->{'address'.$_}) && defined($rh->{'address'.$_}) } (1,2,3)]); $c->city($rh->{city}) if exists($rh->{city}); $c->sp($rh->{state}) if exists($rh->{state}); $c->pc($rh->{postal_code}) if exists($rh->{postal_code}); $c->cc($rh->{country}) if exists($rh->{country}); $c->voice($rh->{phone}) if exists($rh->{voice}); $c->fax($rh->{fax}) if exists($rh->{fax}); $c->email($rh->{email}) if exists($rh->{email}); $c->url($rh->{url}) if exists($rh->{url}); return $c; } sub check { my ($xcp,$domain,$rd)=@_; my $msg=$xcp->message(); my %r=(action=>'lookup',object=>'domain'); $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; $msg->command(\%r); $msg->command_attributes({domain => $domain}); } sub check_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='check'; my $ra=$mes->response_attributes(); $rinfo->{domain}->{$oname}->{exist}=(exists $ra->{status} && defined($ra->{status}) && $ra->{status} eq 'available' && $mes->response_code()==210)? 0 : 1; $rinfo->{domain}->{$oname}->{exist_reason}=$mes->response_text(); } sub create { my ($xcp,$domain,$rd)=@_; sw_register($xcp, $domain, $rd, 'new'); # TBD: premium, sunrise, whois_privacy } sub create_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='create'; my $ra=$mes->response_attributes(); foreach (qw/admin_email cancelled_orders error id queue_request_id forced_pending whois_privacy/) { $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; } } sub sw_register { my ($xcp,$domain,$rd,$reg_type)=@_; my $msg=$xcp->message(); my %r=(action => 'sw_register', object => 'domain'); $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; $msg->command(\%r); Net::DRI::Exception::usererr_insufficient_parameters('Username+Password are required for sw_register') if grep { ! Net::DRI::Util::has_key($rd,$_) } qw/username password/; Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory') unless Net::DRI::Util::has_contact($rd); my $cs=$rd->{contact}; foreach my $t (qw/registrant admin billing/) { my @t=$cs->get($t); Net::DRI::Exception::usererr_invalid_parameters('one ' . $t . ' contact is mandatory') unless @t==1; my $co=$cs->get($t); Net::DRI::Exception::usererr_insufficient_parameters($t . 'contact is mandatory') unless Net::DRI::Util::isa_contact($co); $co->validate(); } my %contact_set = (); my $attr = {reg_type => $reg_type, domain => $domain, contact_set => \%contact_set}; $contact_set{owner} = add_owner_contact($msg,$cs); $contact_set{admin} = add_admin_contact($msg,$cs); $contact_set{billing} = add_billing_contact($msg,$cs); if ($cs->get('tech')) { $contact_set{tech} = add_tech_contact($msg,$cs); ## optional $attr->{custom_tech_contact} = 1; } else { $attr->{custom_tech_contact} = 0; # Use default tech contact } # These are all the OpenSRS names for optional parameters. Might need to map generic names to OpenSRS namespace later. foreach (qw/auto_renew affiliate_id f_lock_domain f_parkp f_whois_privacy/) { $attr->{$_} = ($rd->{$_} ? 1 : 0 ) if Net::DRI::Util::has_key($rd, $_); } foreach (qw/affiliate_id reg_domain/) { $attr->{$_} = ($rd->{$_}) if Net::DRI::Util::has_key($rd, $_); } # TBD: ccTLD-specific flags including domain encoding. # TBD: handle, link_domains, etc. if ($reg_type eq 'new') { Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); $attr->{period} = $rd->{duration}->years(); } $attr->{reg_username} = $rd->{username}; $attr->{reg_password} = $rd->{password}; $msg->command_attributes($attr); add_all_ns($domain,$msg,$rd->{ns}); } sub add_contact_info { my ($msg,$co)=@_; my %contact = (); $contact{first_name} = $co->firstname(); $contact{last_name} = $co->name(); $contact{org_name} = $co->org() if $co->org(); my $s=$co->street(); Net::DRI::Exception::usererr_insufficient_parameters('1 line of address at least needed') unless ($s && (ref($s) eq 'ARRAY') && @$s && $s->[0]); $contact{address1} = $s->[0]; $contact{address2} = $s->[1] if $s->[1]; $contact{address3} = $s->[2] if $s->[2]; Net::DRI::Exception::usererr_insufficient_parameters('city, sp, pc & cc mandatory') unless ($co->city() && $co->sp() && $co->pc() && $co->cc()); $contact{city} = $co->city(); $contact{state} = $co->sp(); $contact{postal_code} = $co->pc(); $contact{country} = uc($co->cc()); Net::DRI::Exception::usererr_insufficient_parameters('voice & email mandatory') unless ($co->voice() && $co->email()); $contact{phone} = $co->voice(); $contact{fax} = $co->fax() if $co->fax(); $contact{email} = $co->email(); $contact{url} = $co->url() if $co->url(); return \%contact; } sub add_owner_contact { my ($msg,$cs)=@_; my $co=$cs->get('registrant'); return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); } sub add_admin_contact { my ($msg,$cs)=@_; my $co=$cs->get('admin'); return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); } sub add_billing_contact { my ($msg,$cs)=@_; my $co=$cs->get('billing'); return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); } sub add_tech_contact { my ($msg,$cs)=@_; my $co=$cs->get('tech'); return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); } sub add_all_ns { my ($domain,$msg,$ns)=@_; my @nslist = (); my $attr = $msg->command_attributes(); $attr->{custom_nameservers} = 0; if (defined($ns)) { Net::DRI::Exception::usererr_insufficient_parameters('at least 2 nameservers are mandatory') unless (Net::DRI::Util::isa_hosts($ns) && $ns->count()>=2); # Name servers are optional; if present must be >=2 for (my $i = 1; $i <= $ns->count(); $i++) { # Net:DRI name server list starts at 1. my $name = $ns->get_details($i); # get_details in scalar returns name push @nslist, { sortorder => $i, name => $name }; } $attr->{custom_nameservers} = 1; $attr->{nameserver_list} = \@nslist; } $msg->command_attributes($attr); } sub delete { my ($xcp,$domain,$rd)=@_; my $msg=$xcp->message(); Net::DRI::Exception::usererr_insufficient_parameters('Reseller ID is mandatory') unless (Net::DRI::Util::has_key($rd, 'reseller_id')); my %r=(action => 'revoke', object => 'domain'); $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; $msg->command(\%r); my $attr = {domain => $domain, reseller => $rd->{reseller_id}}; $attr->{notes} = $rd->{notes} if Net::DRI::Util::has_key($rd, 'notes'); $msg->command_attributes({domain => $domain, reseller => $rd->{reseller_id}}); } sub delete_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='delete'; my $ra=$mes->response_attributes(); foreach (qw/charge price/) { $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; } } sub renew { my ($xcp,$domain,$rd)=@_; my $msg=$xcp->message(); my %r=(action => 'renew', object => 'domain'); $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; Net::DRI::Exception::usererr_insufficient_parameters('auto_renew setting is mandatory') unless (Net::DRI::Util::has_key($rd, 'auto_renew')); Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); Net::DRI::Exception::usererr_insufficient_parameters('current expiration is mandatory') unless (Net::DRI::Util::has_key($rd, 'current_expiration') && Net::DRI::Util::check_isa($rd->{current_expiration}, 'DateTime')); # Can get this from set_cookie response. my $attr = {domain => $domain, period => $rd->{duration}->years(), currentexpirationyear => $rd->{current_expiration}->year()}; # These are all the OpenSRS names for optional parameters. Might need to map generic names to OpenSRS namespace later. foreach (qw/auto_renew f_parkp/) { $attr->{$_} = ($rd->{$_} ? 1 : 0 ) if Net::DRI::Util::has_key($rd, $_); } foreach (qw/affiliate_id notes/) { $attr->{$_} = ($rd->{$_}) if Net::DRI::Util::has_key($rd, $_); } # TBD: handle, etc. $msg->command(\%r); $msg->command_attributes($attr); } sub renew_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='renew'; my $ra=$mes->response_attributes(); foreach (qw/auto_renew admin_email order_id id queue_request_id/) { $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; } my ($k,$v)=('registration expiration date', 'exDate'); $ra->{$k}=~s/\s+/T/; ## with a little effort we become ISO8601 $rinfo->{domain}->{$oname}->{$v}=$xcp->parse_iso8601($ra->{$k}); } sub transfer_request { my ($xcp,$domain,$rd)=@_; sw_register($xcp, $domain, $rd, 'transfer'); } sub transfer_request_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='transfer_start'; my $ra=$mes->response_attributes(); foreach (qw/admin_email cancelled_orders error id queue_request_id forced_pending whois_privacy/) { $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; } } sub transfer_query { my ($xcp,$domain,$rd)=@_; my $msg=$xcp->message(); my %r=(action => 'check_transfer', object => 'domain'); $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; $msg->command(\%r); $msg->command_attributes({domain => $domain, check_status => 1, get_request_address => 1}); # TBD: usable for checking transferability } sub transfer_query_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='check_transfer'; my $ra=$mes->response_attributes(); foreach (qw/transferrable status request_address timestamp unixtime reason type noservice/) { $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; } } sub transfer_cancel { my ($xcp,$domain,$rd)=@_; my $msg=$xcp->message(); Net::DRI::Exception::usererr_insufficient_parameters('Reseller ID is mandatory') unless (Net::DRI::Util::has_key($rd, 'reseller_id')); my %r=(action => 'cancel_transfer', object => 'transfer'); $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; $msg->command(\%r); $msg->command_attributes({domain => $domain, reseller => $rd->{reseller_id}}); # TBD: optional order ID } sub transfer_cancel_parse { my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$xcp->message(); return unless $mes->is_success(); $rinfo->{domain}->{$oname}->{action}='cancel_transfer'; # This response has no attributes to capture } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OpenSRS/XCP/Message.pm0000644000175000017500000002023611352534377022063 0ustar patrickpatrick## Domain Registry Interface, OpenSRS XCP Message ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::OpenSRS::XCP::Message; use strict; use warnings; use XML::LibXML (); use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use Net::DRI::Util; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version client_auth command command_attributes response_attributes response_code response_text response_is_success)); our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OpenSRS::XCP::Message - OpenSRS XCP Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$trid)=@_; my $self={ results => [], _body => '', command => {}}; bless($self,$class); $self->version('0.9'); return $self; } our %CODES=( 200 => 1000, 210 => 2303, 211 => 2302, 221 => 2302, 250 => 1001, 300 => 1001, 310 => 2502, 350 => 2502, ## A maximum of 100 commands can be sent through one connection/session. After 100 commands have been submitted, the connection is closed and a new connection must be opened to submit outstanding requests. 400 => 2400, 404 => 2400, 405 => 2400, 410 => 2200, 415 => 2200, 430 => 2000, 435 => 2201, 436 => 2400, 437 => 2304, 440 => 2201, 445 => 2201, 447 => 2201, 460 => 2003, 465 => 2005, 480 => 2306, 485 => 2302, 486 => 2304, 487 => 2106, 541 => 2004, 552 => 2304, 555 => 2306, 557 => 2305, 705 => 2400, ); sub result_status { my $self=shift; return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL',$self->response_text()) if ($self->response_is_success()); my $code=$self->response_code(); my $eppcode=(!defined($code) || !exists($CODES{$code}))? 'GENERIC_ERROR' : $CODES{$code}; return Net::DRI::Protocol::ResultStatus->new('opensrs_xcp',$code,$eppcode,$self->response_is_success(),$self->response_text(),'en'); } sub is_success { return shift->response_is_success(); } sub as_string { return shift->get_body(); } sub get_body { my ($self)=@_; return $self->{_body} if length($self->{_body}); my @d; push @d,q{}; push @d,q{}; push @d,''; push @d,'
',$self->version(),'
'; push @d,''; push @d,''; push @d,''; my $d=$self->command(); ## ref hash with at least action & object keys, maybe more (such as cookie) $d->{protocol}='XCP'; foreach my $k (sort(keys(%$d))) { push @d,'',$d->{$k},''; } push @d,'',_obj2dt($self->command_attributes()),'' if defined($self->command_attributes()); push @d,''; push @d,''; push @d,''; push @d,'
'; $self->{_body}=join('',@d); return $self->{_body}; } sub _obj2dt { my ($in)=@_; my @r; foreach my $el ($in) { my $ref=ref($el); if (!$ref) { push @r,sprintf('%s',Net::DRI::Util::xml_escape($el)); } elsif ($ref eq 'HASH') { my @c; foreach my $k (sort(keys(%$el))) { $k=~s/"/"/g; my $v=$el->{$k}; if (!defined($v)) { push @c,sprintf('',$k); } else { push @c,sprintf('%s',$k,ref($v)? _obj2dt($v) : Net::DRI::Util::xml_escape($v)); } } push @r,sprintf('%s',join('',@c)); } elsif ($ref eq 'ARRAY') { my @c; foreach my $i (0..$#$el) { push @c,sprintf('%s',$i,ref($el->[$i])? _obj2dt($el->[$i]) : Net::DRI::Util::xml_escape($el->[$i])); } push @r,sprintf('%s',join('',@c)); } elsif ($ref eq 'SCALAR') { push @r,sprintf('%s',Net::DRI::Util::xml_escape($$el)); ## defined in specifications, but not really used ? } else { Net::DRI::Exception::err_assert('_obj2dt cannot deal with data '.$el); } } return @r; } sub _dt2obj { my ($doc)=@_; my $c=$doc->getFirstChild(); return unless defined($c); while (defined($c) && $c->nodeType()!=1) { $c=$c->getNextSibling(); } return $doc->textContent() unless (defined($c) && $c->nodeType()==1); my $n=$c->nodeName(); if ($n eq 'dt_scalar') { return $c->textContent(); } elsif ($n eq 'dt_assoc') { my %r; foreach my $item ($c->getChildrenByTagName('item')) { $r{$item->getAttribute('key')}=_dt2obj($item); } return \%r; } elsif ($n eq 'dt_array') { my @r; foreach my $item ($c->getChildrenByTagName('item')) { $r[$item->getAttribute('key')]=_dt2obj($item); } return \@r; } Net::DRI::Exception::err_assert('_dt2obj ca not deal with node name '.$n); } sub parse { my ($self,$dr,$rinfo,$otype,$oaction,$msgsent)=@_; $self->command($msgsent->command()); ## Copy over for reference from message sent my $parser=XML::LibXML->new(); my $doc=$parser->parse_string($dr->as_string()); my $root=$doc->getDocumentElement(); Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, root element is not OPS_envelope but '.$root->getName()) unless ($root->getName() eq 'OPS_envelope'); my $db=$root->getElementsByTagName('data_block'); Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, expected only one data_block node below root, found '.$db->size()) unless ($db->size()==1); $db=$db->get_node(1)->getChildrenByTagName('dt_assoc'); Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, expected one dt_assoc node directly below data_block, found '.$db->size()) unless ($db->size()==1); foreach my $item ($db->get_node(1)->getChildrenByTagName('item')) { my $key=$item->getAttribute('key'); next if ($key eq 'protocol' || $key eq 'action' || $key eq 'object'); ## protocol is XCP, action is always REPLY, and we already have object in command() if ($key eq 'attributes') ## specific data about requested action, should always be an hash based on documentation { $self->response_attributes(_dt2obj($item)); next; } if ($key eq 'response_code') ## meaning is action-specific { $self->response_code($item->textContent()); next; } if ($key eq 'response_text') ## meaning is action-specific { $self->response_text($item->textContent()); next; } if ($key eq 'is_success') ## 0 if not successful, 1 if action was successful { $self->response_is_success($item->textContent()); next; } } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/IRIS/0002755000175000017500000000000011352534417016756 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/IRIS/XCP.pm0000644000175000017500000002054211352534377017754 0ustar patrickpatrick## Domain Registry Interface, IRIS XCP Connection handling ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::IRIS::XCP; use strict; use XML::LibXML (); use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Protocol::IRIS::Core; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::IRIS::XCP - IRIS XCP Connection Handling (RFC4992) for Net::DRI =head1 DESCRIPTION Please see the README file for details. This is only a preliminary basic implementation, with only SASL PLAIN support. There is currently no known public server speaking this protocol. =head1 CURRENT LIMITATIONS =over =item * Nothing is parsed from server greeting message =item * Only SASL PLAIN is handled =item * Blocks splitted over multiple chunks are not handled, except for application data =item * Nothing is parsed in authentication success result from server =item * Only chunk types "application data", "authentication success" and "authentication failure" are recognized and parsed. =back =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub parse_greeting ## §4.2 { my $dr=shift; ## TODO: really parse something ? return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL','Greeting OK','en'); } sub read_data # §4 { my ($class,$to,$sock)=@_; my $data; $sock->sysread($data,1) or die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read registry reply (block header): '.$!,'en')); my $hdr=substr($data,0,1); my $keepopen=parse_block_header($hdr); $to->send_logout() unless ($keepopen); ## will not truly send anything, as there is no logout, but will properly close the socket and prepare everything as needed for next connection ## We do not handle blocks splitted over multiple chunks, except for application data my $m=''; my ($lastchunk,$datacomplete,$chunktype); while(($lastchunk,$datacomplete,$chunktype,$data)=parse_chunk($sock)) { if ($chunktype==4+2+1) ## ad=application data { $m.=$data; } elsif ($chunktype==4+0+0) { die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Extra SASL data returned by server, currently not handled','en')); } elsif ($chunktype==4+0+1) ## as=authentication success { ## We do not parse anything. If so needed, see §6 of RFC4991, and Core::parse_authentication next; } elsif ($chunktype==4+2+0) ## af=authentication failure { my $doc=XML::LibXML->new()->parse_string(Net::DRI::Util::decode_utf8($data)); my $root=$doc->getDocumentElement(); my ($msg,$lang,$ri)=Net::DRI::Protocol::IRIS::Core::parse_authentication($root); if (!defined $msg || !defined $lang) { die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Authentication failure without any data','en')); } die(Net::DRI::Protocol::ResultStatus->new_error('AUTHENTICATION_ERROR',$msg,$lang,$ri)); } else { die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Chunk type not handled: '.$chunktype,'en')); } last if $lastchunk==1; } die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED','Last chunk has not DC=1','en')) unless $datacomplete==1; ## TODO: does that happen IRL ? $m=Net::DRI::Util::decode_utf8($m); ## do it only once at end, when all chunks of application data were joined together again die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR',$m? 'Got unexpected reply message: '.$m : '','en')) unless ($m=~m!\s*$!s); ## we do not handle other things than plain responses (see Message) return Net::DRI::Data::Raw->new_from_xmlstring($m); } sub write_message ## §5 { my ($self,$to,$msg)=@_; my $hdr='00100000'; ## V=0, KO=1 (Keep Open please) my $auth=Net::DRI::Util::encode_utf8($msg->authority()); return pack('B8',$hdr).pack('C',length($auth)).$auth.write_chunk('sasl',$to).write_chunk('data',$msg->as_string()); } sub keepalive { my ($class,$cm)=@_; my $mes=$cm->(); ## TODO: update IRIS/Message to handle this kind of messages return $mes; ## TODO: update write_message to handle various types (should be infered from content of message probably) } #################################################################################################### sub parse_block_header ## §5 { my $d=shift; ## one-octet die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read 1 byte block header','en')) unless $d; my $hdr=unpack('C',$d); my $ver=($hdr & (128+64)) >> 6; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Version unknown in block header: '.$ver,'en')) unless $ver==0; my $keepopen=($hdr & 32) >> 5; my $res=($hdr & (16+8+4+2+1)); die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Reserved part unknown in block header: '.$res,'en')) unless $res==0; return $keepopen; } sub parse_chunk_header ## §6 { my $d=shift; ## one-octet die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read 1 byte chunk header','en')) unless $d; my $hdr=unpack('C',$d); my $lc=($hdr & 128) >> 7; ## is last chunk in reply ? my $dc=($hdr & 64) >> 6; ## is data complete with this chunk ? my $res=($hdr & (32+16+8)) >> 3; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Reserved part unknown in chunk header: '.$res,'en')) unless $res==0; my $ct=($hdr & (4+2+1)); ## chunk type return ($lc,$dc,$ct); } sub parse_chunk ## §6 { my $sock=shift; my $data; $sock->sysread($data,3) or die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read registry reply (chunk header of 3 bytes): '.$!,'en')); my $hdr=substr($data,0,1); my @hdr=parse_chunk_header($hdr); my $length=unpack('n',substr($data,1,2)); $data=undef; $sock->sysread($data,$length) or die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read registry reply (chunk data of '.$length.' bytes): '.$!,'en')); return (@hdr,$data); } ## We handle only 'application data' type and sasl plain sub write_chunk { my ($type,$data)=@_; my $hdr; if ($type eq 'data') { $hdr='11000111'; ## LC=yes, DC=yes, CT=ad $data=Net::DRI::Util::encode_utf8($data); } elsif ($type eq 'nodata') { $hdr='11000000'; $data=''; } elsif ($type eq 'sasl') { my $t=$data->transport_data(); ## $data=$to here unless (exists $t->{client_login} && $t->{client_login} && exists $t->{client_password} && $t->{client_password}) { return ''; } $hdr='01000100'; ## LC=no, DC=yes, CT=sd ## Only SASL PLAIN is supported for now my $sasltype='PLAIN'; $data=pack('C',length($sasltype)).$sasltype; my $sasldata=Net::DRI::Util::encode_utf8(sprintf('%s %s %s',$t->{client_login},chr(0),$t->{client_password})); ## authcid=LOGIN, authzid=NULL, password=PASSWORD $data.=pack('n',length($sasldata)).$sasldata; } return pack('B8',$hdr).pack('n',length($data)).$data; } sub transport_default { my ($self,$tname)=@_; return (has_state => 1, type => 'tcp'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/IRIS/LWZ.pm0000644000175000017500000001540611352534377020001 0ustar patrickpatrick## Domain Registry Interface, IRIS LWZ Connection handling ## ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::IRIS::LWZ; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; use Net::DNS (); use IO::Uncompress::RawInflate (); ## RFC1951 per the LWZ RFC our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::IRIS::LWZ - IRIS LWZ connection handling (RFC4993) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub read_data # §3.1.2 { my ($class,$to,$sock)=@_; my $data; $sock->recv($data,4000) or die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read registry reply: '.$!,'en')); my $hdr=substr($data,0,1); die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read 1 byte header','en')) unless $hdr; # §3.1.3 $hdr=unpack('C',$hdr); my $ver=($hdr & (128+64)) >> 6; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Version unknown in header: '.$ver,'en')) unless $ver==0; my $rr=($hdr & 32) >> 5; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','RR Flag is not response in header: '.$rr,'en')) unless $rr==1; my $deflate=($hdr & 16) >> 4; ## if 1, the payload is compressed with the deflate algorithm (RFC1951) my $type=($hdr & 3); ## §3.1.4 die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR','Unexpected response type in header: '.$type,'en')) unless $type==0; ## TODO : handle size info, version, etc. my $tid=substr($data,1,2); $tid=unpack('n',$tid); my $load=substr($data,3); if ($deflate) { my $load2; IO::Uncompress::RawInflate::rawinflate(\$load,\$load2) or die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED','Unable to uncompress payload: '.$IO::Uncompress::RawInflate::RawInflateError,'en')); $load=$load2; } my $m=Net::DRI::Util::decode_utf8($load); die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR',$m? 'Got unexpected reply message: '.$m : '','en')) unless ($m=~m!\s*$!s); ## we do not handle other things than plain responses (see Message) return Net::DRI::Data::Raw->new_from_xmlstring($m); } sub write_message { my ($self,$to,$msg)=@_; my $m=Net::DRI::Util::encode_utf8($msg); my $hdr='00001000'; ## §3.1.3 : V=0 RR=Request PD=no DS=yes Reserved PT=xml ## TODO : handle message payload deflation, as needed (the RFC says when over 1500 bytes ## However, pay attention to the fact that some server do not accept such messages, see §3.1.7 "no-inflation-support-error", this is the case of DENIC server ! ## So either code that information per DRD, or try anyway & fallback based on reply (this will need multiple exchanges, so probably some changes in Net::DRI::Registry::process) # use IO::Compress::RawDeflate; # my $mm; # IO::Compress::RawDeflate::rawdeflate(\$m,\$mm); # $m=$mm; # $hdr='00011000'; my ($tid)=($msg->tid()=~m/(\d{6})$/); ## 16 digits, we need to convert to a 16-bit value, we take the microsecond part modulo 65535 (since 0xFFFF is reserved) $tid%=65535; my $auth=$msg->authority(); return pack('B8',$hdr).pack('n',$tid).pack('n',4000).pack('C',length($auth)).$auth.$m; ## §3.1.1 } ## TODO: move that someway into IRIS/Core probably (as needed for all transports) sub find_remote_server { my ($class,$to,$rd)=@_; my ($authority,$service)=@$rd; my $res=Net::DNS::Resolver->new(domain=>'', search=>''); ## make sure to start from clean state (otherwise we inherit the system defaults !) my $query=$res->send($authority,'NAPTR'); Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to perform NAPTR DNS query for '.$authority.': '.$res->errorstring()) unless $query; my @r=sort { $a->order() <=> $b->order() || $a->preference() <=> $b->preference() } grep { $_->type() eq 'NAPTR' } $query->answer(); ## RFC3958 §2.2.1 @r=grep { $_->service() eq $service } @r; ## RFC3958 §2.2.2 @r=grep { $_->flags() eq 's' } @r; ## RFC3958 §2.2.3 Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to retrieve NAPTR records with service='.$service.' and flags=s for authority='.$authority) unless @r; my $srv=$r[0]->replacement(); $query=$res->query($srv,'SRV'); Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to perform SRV DNS query for '.$srv.': '.$res->errorstring()) unless $query; @r=$query->answer(); Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to retrieve SRV records for '.$srv) unless @r; ## TODO: provide load balancing/fail over when not using only one SRV record / This would probably need changes in Transport or Transport::Socket @r=Net::DRI::Util::dns_srv_order(@r) if @r > 1; Net::DRI::Exception->die(1,'transport/socket',8,'No remote endpoint given, and unable to find valid SRV record for '.$srv) if ($r[0]->target() eq '.'); return ($r[0]->target(),$r[0]->port()); } sub transport_default { my ($self,$tname)=@_; ## RFC4993 Section 4 gives recommandation for timeouts and retry algorithm ## retry=5 is computed so that the whole sequence stops after 60 seconds: t,p+2t,3/2(p+2)-2+4t,3/2*3/2*(p+2)-2+8t,... return (defer => 1, close_after => 1, socktype=>'udp', timeout => 1, pause => 2, retry => 5); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/IRIS/DCHK/0002755000175000017500000000000011352534417017467 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/IRIS/DCHK/Status.pm0000644000175000017500000000444511352534377021322 0ustar patrickpatrick## Domain Registry Interface, IRIS DCHK Status ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::IRIS::DCHK::Status; use base qw!Net::DRI::Data::StatusList!; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::IRIS::DCHK::Status - IRIS DCHK Domain Status for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self=$class->SUPER::new('iris-dchk','1.0'); my $msg=shift; return $self unless defined($msg); Net::DRI::Exception::err_invalid_parameters() unless (ref($msg) eq 'ARRAY'); $self->add(@$msg); return $self; } sub is_active { my $s; return $s->has_any('active') && $s->has_not('inactive'); } sub is_published { return shift->has_not('inactive'); } sub is_pending { return shift->has_any('dispute'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/IRIS/DCHK/Domain.pm0000644000175000017500000001567311352534377021253 0ustar patrickpatrick## Domain Registry Interface, IRIS DCHK (RFC5144) ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::IRIS::DCHK::Domain; use strict; use Carp; use Net::DRI::Util; use Net::DRI::Exception; use Net::DRI::Protocol::IRIS::Core; use DateTime::Format::ISO8601; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::IRIS::DCHK::Domain - IRIS DCHK (RFC5144) Domain Commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [ \&info, \&info_parse ] ); ## $tmp{info_multi}=$tmp{info}; return { 'domain' => \%tmp }; } sub build_command { my ($ns,$domain)=@_; my @dom=(ref($domain))? @$domain : ($domain); Net::DRI::Exception->die(1,'protocol/IRIS',2,'Domain name needed') unless @dom; foreach my $d (@dom) { Net::DRI::Exception->die(1,'protocol/IRIS',2,'Domain name needed') unless defined($d) && $d; Net::DRI::Exception->die(1,'protocol/IRIS',10,'Invalid domain name: '.$d) unless Net::DRI::Util::is_hostname($d); } ## TODO: entityClass may also be IDN for Unicode domain names ## §3.1.2 ##return [ map { { registryType => $ns, entityClass => 'domain-name', entityName => $_ } } @dom ] ; return [ map { { registryType => 'dchk1', entityClass => 'domain-name', entityName => $_ } } @dom ] ; ## Both registryType forms should work, but currently only this one works } sub info { my ($p,$domain)=@_; my $mes=$p->message(); $mes->search(build_command($mes->ns('dchk1'),$domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); ## ? return unless $mes->results(); ## a nodeList of resultSet nodes foreach my $cd ($mes->results()->get_nodelist()) { carp('For domain '.$oname.' got a node , please report') if $cd->getChildrenByTagNameNS($mes->ns('iris1'),'additional')->size(); ## TODO $rinfo->{domain}->{$oname}->{result_status}=Net::DRI::Protocol::IRIS::Core::parse_error($cd); ## a ResultStatus instance, either a generic success, or a specific error $rinfo->{domain}->{$oname}->{action}='info'; $rinfo->{domain}->{$oname}->{exist}=0; my $c=$cd->getChildrenByTagNameNS($mes->ns('iris1'),'answer'); next unless $c->size(); $c=$c->get_node(1)->getChildrenByTagNameNS($mes->ns('dchk1'),'domain'); next unless $c->size(); ## We do not use attributes authority/entityClass/entityName/registryType, they should be the same as what we sent $c=$c->get_node(1); my $temp=$c->hasAttribute('temporaryReference')? Net::DRI::Util::xml_parse_boolean($c->getAttribute('temporaryReference')) : 0; $c=$c->getFirstChild(); my $pd=DateTime::Format::ISO8601->new(); my ($domain,@s); while($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $n=$c->localname() || $c->nodeName(); if ($n eq 'domainName') ## we do not use for now { $domain=lc($c->textContent()); $rinfo->{domain}->{$domain}->{action}='info'; $rinfo->{domain}->{$domain}->{exist}=1; } elsif ($n eq 'status') { ## We take everything below as a status node, which allows us to handle all non RFC5144 defined statuses my $cc=$c->getFirstChild(); while($cc) { next unless ($cc->nodeType() == 1); ## only for element nodes push @s,parse_status($cc,$pd); } continue { $cc=$cc->getNextSibling(); } } elsif ($n eq 'registrationReference') { carp('For domain '.$domain.' got a node , please report'); } elsif ($n eq 'createdDateTime') { $rinfo->{domain}->{$domain}->{crDate}=$pd->parse_datetime($c->textContent()); } elsif ($n eq 'initialDelegationDateTime') { $rinfo->{domain}->{$domain}->{idDate}=$pd->parse_datetime($c->textContent()); } elsif ($n eq 'expirationDateTime') { $rinfo->{domain}->{$domain}->{exDate}=$pd->parse_datetime($c->textContent()); } elsif ($n eq 'lastDatabaseUpdateDateTime') { $rinfo->{domain}->{$domain}->{duDate}=$pd->parse_datetime($c->textContent()); } elsif ($n eq 'seeAlso' || $n eq 'iris:seeAlso') { carp('For domain '.$domain.' got a node <'.$n.'>, please report'); } } continue { $c=$c->getNextSibling(); } $rinfo->{domain}->{$domain}->{temporary}=$temp; my $s=$po->create_local_object('status')->add(@s); $rinfo->{domain}->{$domain}->{exist}=0 if $s->has_any(qw/nameNotFound invalidName/); $rinfo->{domain}->{$domain}->{status}=$s; } ## end of foreach on each resultSet } sub parse_status ## §3.1.1.1 { my ($node,$pd)=@_; my %tmp=(name => $node->localname() ); my $ns=$node->namespaceURI(); my $c=$node->getChildrenByTagNameNS($ns,'appliedDate'); ## 0..1 $tmp{applied_date}=$pd->parse_datetime($c->get_node(1)->textContent()) if $c->size(); $c=$node->getChildrenByTagNameNS($ns,'ticket'); ## 0..unbounded $tmp{tickets}=[ map { $_->textContent() } $c->get_nodelist() ] if $c->size(); $c=$node->getChildrenByTagNameNS($ns,'description'); ## 0..unbounded if ($c->size()) { my @t=map { { lang => $_->getAttribute('language'), msg => $_->textContent() } } $c->get_nodelist(); $tmp{description}=\@t; ## Useful fallback to mimick EPP ? $tmp{lang}=$t[0]->{lang}; $tmp{msg}=$t[0]->{msg}; } $c=$node->getChildrenByTagNameNS($ns,'description'); ## 0..unbounded ; not defined by RFC5144 $tmp{substatus}=[ map { { authority => $_->getAttribute('authority'), content => $_->toString(0) } } $c->get_nodelist() ] if $c->size(); foreach my $a (qw/actor disposition scope/) { next unless $node->hasAttribute($a); $tmp{$a}=$node->getAttribute($a); } return \%tmp; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/IRIS/Core.pm0000644000175000017500000001000511352534377020203 0ustar patrickpatrick## Domain Registry Interface, IRIS Core functions ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::IRIS::Core; use strict; use warnings; use Carp; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::IRIS::Core - IRIS Core (RFC3981) functions for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### our %ERRORS=(insufficientResources => 2400, invalidName => 2005, invalidSearch => 2306, queryNotSupported => 2101, limitExceeded => 2201, nameNotFound => 2303, permissionDenied => 2200, bagUnrecognized => 2005, bagUnacceptable => 2005, bagRefused => 2306, ); sub parse_error { my ($node)=@_; ## $node should be a topmost to be able to catch all errors type my $c=$node->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname(); next unless (defined $name && $name); next if ($name eq 'answer' || $name eq 'additional'); carp('Got unknown error <'.$name.'>, please report') unless exists($ERRORS{$name}); my (@i,$msg,$lang); foreach my $expl ($c->getChildrenByTagNameNS($c->namespaceURI(),'explanation')) { if (! defined $msg) { ($lang,$msg)=($expl->getAttribute('language'),$expl->textContent()); } push @i,sprintf('[%s] %s',$expl->getAttribute('language'),$expl->textContent()); } ## We have only one error element at most, so break here if we found one return Net::DRI::Protocol::ResultStatus->new('iris',$name,exists($ERRORS{$name})? $ERRORS{$name} : 'GENERIC_ERROR',0,$msg,$lang,\@i); } continue { $c=$c->getNextSibling(); } return Net::DRI::Protocol::ResultStatus->new_generic_success(); } ## RFC4991 §6 §7 sub parse_authentication { my ($node)=@_; ## $node should be a topmost to be able to catch all errors type my (@i,$msg,$lang); my $c=$node->getFirstChild(); while ($c) { next unless ($c->nodeType() == 1); ## only for element nodes my $name=$c->localname(); next unless (defined $name && $name); next unless ($name eq 'authenticationSuccess' || $name eq 'authenticationFailure'); foreach my $expl ($c->getChildrenByTagNameNS($c->namespaceURI(),'description')) { if (! defined $msg) { ($lang,$msg)=($expl->getAttribute('language'),$expl->textContent()); } push @i,sprintf('[%s] %s',$expl->getAttribute('language'),$expl->textContent()); } last; } continue { $c=$c->getNextSibling(); } return ($msg,$lang,\@i); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/IRIS/Message.pm0000644000175000017500000001027611352534377020711 0ustar patrickpatrick## Domain Registry Interface, IRIS Message ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::IRIS::Message; use strict; use warnings; use XML::LibXML (); use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use Net::DRI::Util; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw/version tid authority search results/); our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::IRIS::Message - IRIS Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $trid=shift; my $self={ ns => {} }; bless($self,$class); $self->tid($trid) if (defined($trid) && $trid); return $self; } sub ns { my ($self,$what)=@_; return $self->{ns} unless defined($what); if (ref($what) eq 'HASH') { $self->{ns}=$what; return $what; } return unless exists($self->{ns}->{$what}); return $self->{ns}->{$what}->[0]; } sub nsattrs { my ($self,$what)=@_; return unless (defined($what) && exists($self->{ns}->{$what})); my @n=@{$self->{ns}->{$what}}; return ($n[0],$n[0],$n[1]); } sub is_success { return 1; } ## TODO sub result_status { return Net::DRI::Protocol::ResultStatus->new_generic_success(); }; ## There is no message-level result_status, only at resultSet level, hence sub as_string { my ($self)=@_; ## TODO : handle other top nodes, see RFC4991, + control node in Net::DRI::Exception::err_assert('Net::DRI::Protocol::IRIS::Message can only handle operations for now') unless defined($self->search()); my @d; push @d,''; push @d,sprintf('',$self->nsattrs('iris1')); foreach my $search (@{$self->search()}) ## $search is a refhash comme il faut { push @d,''; ## We do not handle bags for now ## Only lookupEntity is supported for now push @d,Net::DRI::Util::xml_write(['lookupEntity',$search]); push @d,''; } push @d,''; return join('',@d); } # RFC3981 §4.2 sub parse { my ($self,$dc,$rinfo)=@_; my $parser=XML::LibXML->new(); my $doc=$parser->parse_string($dc->as_string()); my $root=$doc->getDocumentElement(); ## TODO: handle RFC4991 other types of responses Net::DRI::Exception->die(0,'protocol/IRIS',1,'Unsuccessfull parse, root element is not response') unless ($root->localname() eq 'response'); ## We currently do not parse the node (in reply to a which we do never send for now, see §4.3.8) and (see §4.4) ## We take care only of the nodes $self->results(scalar($root->getChildrenByTagNameNS($self->ns('iris1'),'resultSet'))); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/DAS.pm0000644000175000017500000000517311352534377017166 0ustar patrickpatrick## Domain Registry Interface, DAS Protocol (.BE & .EU) ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::DAS; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Util; use Net::DRI::Protocol::DAS::Message; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::DAS - DAS Protocol (.BE & .EU Domain Availability Service) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('DAS'); my $version=Net::DRI::Util::check_equal($rp->{version},['1.0'],'1.0'); $self->version($version); $self->default_parameters({ tld => (exists $rp->{no_tld} && $rp->{no_tld})? ($drd->tlds())[0] : undef }); $self->factories('message',sub { return Net::DRI::Protocol::DAS::Message->new(@_)->version($version); }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; $self->SUPER::_load('Net::DRI::Protocol::DAS::Domain'); } sub tld { return shift->{default_parameters}->{tld}; } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::DAS::Connection', protocol_version => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OVH/0002755000175000017500000000000011352534417016644 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/OVH/WS.pm0000644000175000017500000000502611352534377017541 0ustar patrickpatrick## Domain Registry Interface, OVH Web Services Protocol ## As seen on http://www.ovh.com/soapi/fr/ and http://www.verot.org/ovhapi/ and http://wikikillers.eu/ ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::OVH::WS; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Protocol::OVH::WS::Message; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OVH::WS - OVH Web Services Protocol for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('ovh_ws'); $self->version('1.4.1'); $self->factories('message',sub { my $m=Net::DRI::Protocol::OVH::WS::Message->new(); $m->version('1.4.1'); return $m; }); $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; my @class=map { 'Net::DRI::Protocol::OVH::WS::'.$_ } (qw/Account Domain/); $self->SUPER::_load(@class); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::OVH::WS::Connection', protocol_version => '1.4.1'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OVH/WS/0002755000175000017500000000000011352534417017175 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/OVH/WS/Connection.pm0000644000175000017500000000531611352534377021642 0ustar patrickpatrick## Domain Registry Interface, OVH Web Services Connection handling ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::OVH::WS::Connection; use strict; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OVH::WS::Connection - OVH Web Services Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub login { my ($class,$cm,$id,$pass,$cltrid)=@_; my $mes=$cm->(); $mes->method('login'); $mes->params([$id,$pass,'fr',0]); return $mes; } sub parse_login { my ($class,$mes)=@_; $mes->errmsg($mes->is_success()? 'Login OK' : 'Login failed') unless $mes->errmsg(); return $mes->result_status(); } sub extract_session { my ($class,$mes)=@_; return { id => $mes->result() }; } #################################################################################################### sub logout { my ($class,$cm,$cltrid,$sd)=@_; my $mes=$cm->(); $mes->method('logout'); $mes->params([$sd->{id}]); return $mes; } sub parse_logout { my ($class,$mes)=@_; $mes->errmsg($mes->is_success()? 'Logout OK' : 'Logout failed') unless $mes->errmsg(); return $mes->result_status(); } sub transport_default { my ($self,$tname)=@_; return (defer => 1, has_login => 1, has_logout => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OVH/WS/Account.pm0000644000175000017500000000474511352534377021144 0ustar patrickpatrick## Domain Registry Interface, OVH Web Services Account commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::OVH::WS::Account; use strict; use warnings; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OVH::WS::Account - OVH Web Services Account commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( list_domains => [\&list_domains, \&list_domains_parse ], ); return { 'account' => \%tmp }; } sub list_domains { my ($po)=@_; my $msg=$po->message(); $msg->method('domainList'); } sub list_domains_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/ovh/ws',1,'Unexpected reply for domainList: '.$r) unless (ref($r) eq 'MyArrayOfStringType'); my @r=@$r; $rinfo->{account}->{domains}->{action}='list'; $rinfo->{account}->{domains}->{list}=\@r; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OVH/WS/Domain.pm0000644000175000017500000001207511352534377020752 0ustar patrickpatrick## Domain Registry Interface, OVH Web Services Domain commands ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::OVH::WS::Domain; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OVH::WS::Domain - OVH Web Services Domain commands for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; my %tmp=( info => [\&info, \&info_parse ], check => [\&check, \&check_parse ], ); return { 'domain' => \%tmp }; } sub parse_ArrayOfNsStruct { my ($po,$r)=@_; Net::DRI::Exception->die(1,'protocol/ovh/ws',1,'Unexpected content for dns: '.$r) unless (ref($r) eq 'MyArrayOfNsStructType'); my $h=$po->create_local_object('hosts'); foreach my $ns (@$r) { Net::DRI::Exception->die(1,'protocol/ovh/ws',1,'Unexpected content for ArrayOfNsStruct member: '.$ns) unless (ref($ns) eq 'nsStruct'); my $name=$ns->{name}; my $ip=$ns->{ip}; ## how are multiple IPs handled ? $h->add($name,defined($ip)? [$ip] : undef); } return $h; } sub build_msg { my ($msg,$command,$domain)=@_; Net::DRI::Exception->die(1,'protocol/ovh/ws',2,'Domain name needed') unless defined($domain) && $domain; Net::DRI::Exception->die(1,'protocol/ovh/ws',10,'Invalid domain name') unless Net::DRI::Util::is_hostname($domain); $msg->method($command) if defined($command); } sub info { my ($po,$domain)=@_; my $msg=$po->message(); build_msg($msg,'domainInfo',$domain); $msg->params([$domain]); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/ovh/ws',1,'Unexpected reply for domain_info: '.$r) unless (ref($r) eq 'domainInfoReturn'); my %r=%$r; $oname=lc($r->{domain}); $rinfo->{domain}->{$oname}->{action}='info'; $rinfo->{domain}->{$oname}->{exist}=1; my %d=(creation => 'crDate', modification => 'upDate', expiration => 'exDate'); while (my ($k,$v)=each(%d)) { next unless exists($r{$k}); $rinfo->{domain}->{$oname}->{$v}=$po->parse_iso8601($r{$k}); } my %c=(nicowner => 'registrant', nicadmin => 'admin', nictech => 'tech', nicbilling => 'billing'); my $cs=$po->create_local_object('contactset'); while (my ($k,$v)=each(%c)) { next unless exists($r{$k}); my $c=$po->create_local_object('contact')->srid($r{$k}); $cs->add($c,$v); } $rinfo->{domain}->{$oname}->{contact}=$cs; ## From WSDL file: the authinfo if the domain is unlocked if (exists($r{authinfo})) { $rinfo->{domain}->{$oname}->{auth}={pw => $r{authinfo}}; $rinfo->{domain}->{$oname}->{status}=$po->create_local_object('status')->add('ok'); } else { $rinfo->{domain}->{$oname}->{status}=$po->create_local_object('status')->add('clientLock'); ## ? ## } $rinfo->{domain}->{$oname}->{ns}=parse_ArrayOfNsStruct($po,$r{dns}) if exists($r{dns}); } sub check { my ($po,$domain)=@_; my $msg=$po->message(); build_msg($msg,'domainCheck',$domain); $msg->params([$domain]); } sub check_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $r=$mes->result(); Net::DRI::Exception->die(1,'protocol/ovh/ws',1,'Unexpected reply for domain_check: '.$r) unless (ref($r) eq 'MyArrayOfDomainCheckStructType'); my @r=grep { exists $_->{predicate} && $_->{predicate} eq 'is_available' } @$r; ## also: is_transferable, is_renewable $rinfo->{domain}->{$oname}->{action}='check'; $rinfo->{domain}->{$oname}->{exist}=(@r==1 && $r[0]->{value}==1)? 0 : 1; $rinfo->{domain}->{$oname}->{exist_reason}=$r[0]->{reason} if @r==1; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/OVH/WS/Message.pm0000644000175000017500000001325511352534377021130 0ustar patrickpatrick## Domain Registry Interface, OVH Web Services Message ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::OVH::WS::Message; use strict; use warnings; use Carp; use Net::DRI::Protocol::ResultStatus; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version method params result errcode errmsg)); our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::OVH::WS::Message - OVH Web Services Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self={errcode => undef, errmsg => undef}; bless($self,$class); my ($trid,$otype,$oaction)=@_; $self->params([]); ## default return $self; } sub as_string { my ($self)=@_; my @p=@{$self->params()}; my @pr; foreach my $i (0..$#p) { push @pr,sprintf 'PARAM%d=%s',$i+1,$p[$i]; } return sprintf "METHOD=%s\n%s\n",$self->method(),join("\n",@pr); } sub add_session { my ($self,$sd)=@_; my $rp=$self->params(); unshift @$rp,$sd->{id}; } sub parse { my ($self,$dr,$rinfo,$otype,$oaction,$sent)=@_; ## $sent is the original message, we could copy its method/params value into this new message my ($res)=@{$dr->data()}; ## $dr is a Data::Raw object, type=1 if (ref($res) eq 'HASH') { $self->result($res->{value}); $self->errcode($res->{status}); $self->errmsg($res->{msg}); } else { $self->result($res); $self->errcode(100); ## probably success $self->errmsg('No status/msg given'); } } ## See http://guides.ovh.com/ManagerV3Status and http://wikikillers.eu/index.php?title=Codes_d%27erreurs my %CODES=( 201 => 2003,# parametre(s) manquant(s) 202 => 2005,# parametre(s) invalide(s) 203 => 2306,# parametres incompatibles 210 => 2306,# donnée inconnue 211 => 2306,# donnée deja existante 212 => 2308,# l'action n'a affectée aucune donnée 213 => 2306,# donnée en doublon 214 => 2308,# l'action a affectée trop de données 220 => 2304,# donnée en cours de traitement 230 => 2101,# fonction inactive 240 => 2304,# action en cours de traitement 241 => 2308,# action impossible 250 => 2101,# fonction non implémenté 251 => 2000,# fonction obsolète 252 => 2308,# fonction innaccessible 260 => 2400,# erreur, pas d'info supplementaire 266 => 2400,# toutes les fonctions du merge ont échoué: pas de resultat 267 => 2400,# certaines fonctions ont échoués: l'action devra etre entreprise de nouveau plus tard 280 => 2400,# erreur interne 281 => 2400,# traitement échoué 299 => 2005,# parametres excedentaires 301 => 2200,# session expirée ## should trigger a new login 302 => 2200,# session inexistante ## should trigger a new login 303 => 2200,# session corrompue ## should trigger a new login 304 => 2502,# trop de sessions actives ## should trigger a call to ClearNicSessions and a retry 310 => 2200,# erreur login 320 => 2200,# burst 401 => 2201,# pas de droit d'acces 402 => 2201,# droits insuffisants 403 => 2200,# session en lecture seule 451 => 2400,# quota dépassé 461 => 2400,# hacké 501 => 2400,# probleme connexion base de données 502 => 2400,# donnée erronée au sein du serveur 503 => 2400,# probleme connexion 504 => 2400,# probleme connexion dns 505 => 2400,# probleme interne au serveur 506 => 2400,# parametre interne invalide 510 => 2308,# données introuvable 601 => 2400,# parametres mysql corrompus 701 => 2304,# domaine dans un etat incompatible 702 => 2307,# fonction non supportée par le domaine (ex:multidomain sur un gp) 703 => 2304,# objet dans un état incompatible 704 => 2305,# un processus bloquant interdit la création de l'objet 705 => 2002,# plus de données a traité. 706 => 2400,# impossible d'obtenir le lock 777 => 2400,# pas de numero d'erreur donne ); sub is_success { return (shift->errcode()==100)? 1 : 0; } sub result_status { my $self=shift; my $code=$self->errcode(); my $msg=$self->errmsg() || ''; my $ok=$self->is_success(); if ($code >= 101 && $code <=199) { carp('Got a "warning" error code, please report: '.$code.' '.$msg); $ok=1; } my $eppcode=(defined($code) && exists($CODES{$code}))? $CODES{$code} : 'GENERIC_ERROR'; return Net::DRI::Protocol::ResultStatus->new('ovh_ws',$code,$ok? 'COMMAND_SUCCESSFUL' : $eppcode,$ok,$msg,'en'); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/0002755000175000017500000000000011352534417017301 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/Whois/Connection.pm0000644000175000017500000000501111352534377021736 0ustar patrickpatrick## Domain Registry Interface, Whois Connection handling ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Connection; use strict; use warnings; use Net::DRI::Util; use Net::DRI::Data::Raw; use Net::DRI::Protocol::ResultStatus; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Connection - Whois Connection handling for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub read_data { my ($class,$to,$sock)=@_; my @a; while(my $l=$sock->getline()) { chomp($l); push @a,$l; } @a=map { Net::DRI::Util::decode_latin1($_); } @a; die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','Unable to read answer (connection closed by registry ?)','en')) unless (@a > 5); return Net::DRI::Data::Raw->new_from_array(\@a); } sub write_message { my ($class,$to,$msg)=@_; return Net::DRI::Util::encode_ascii($msg->as_string()); } sub transport_default { my ($self,$tname)=@_; return (defer => 1, close_after => 1, socktype => 'tcp', remote_port => 43); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/0002755000175000017500000000000011352534417020510 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/AT.pm0000644000175000017500000001164011352534377021357 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .AT (RFC3912) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::AT; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::AT - .AT Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command(lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_ns($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); parse_contacts($po,$domain,$rr,$rd,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'domain'})) { $e=1; $dom=lc($rr->{'domain'}->[0]); } else { $e=0; } return ($dom,$e); } sub parse_ns { my ($po,$domain,$rr,$rinfo)=@_; return unless exists($rr->{'nserver'}); ## I do not know how multiple IPs for one host are handled, we do the very crude way for now my $h=$po->create_local_object('hosts'); my @n=grep { defined($_) && $_ } @{$rr->{'nserver'}}; my @i=grep { defined($_) && $_ } @{$rr->{'remarks'}}; while(@n) { $h->add(shift(@n),[shift(@i)]); } $rinfo->{domain}->{$domain}->{ns}=$h unless $h->is_empty(); } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%Y%m%d %T', time_zone => 'Europe/Vienna'); $rinfo->{domain}->{$domain}->{upDate}=$strp->parse_datetime($rr->{'changed'}->[0]); } sub parse_contacts { my ($po,$domain,$rr,$rd,$rinfo)=@_; my $cs=$po->create_local_object('contactset'); my %t=('registrant' => 'registrant', 'admin-c' => 'admin', 'tech-c' => 'tech'); my %tmp; ## First pass, only the IDs foreach my $t (keys(%t)) { my $c=$po->create_local_object('contact'); my $id=$rr->{$t}->[0]; $tmp{$id}=$c; $c->srid($id); $cs->add($c,$t{$t}); } ## Now all details my ($id,@s); foreach my $l (reverse grep { (($_=~m/^personname:/)..($_=~m/^\s*$/)) } @$rd) { next if ($l=~m/^(?:source|changed):/); $id=$1 if ($l=~m/^nic-hdl:\s+(\S+)\s*$/); if ($l=~m/^e-mail:\s+(\S+)\s*$/) { $tmp{$id}->email($1); } elsif ($l=~m/^fax-no:\s+(\S.+\S)\s*$/) { $tmp{$id}->fax($1); } elsif ($l=~m/^phone:\s+(\S.+\S)\s*$/) { $tmp{$id}->voice($1); } elsif ($l=~m/^country:\s+(\S.+\S)\s*$/) { $tmp{$id}->cc($1); } elsif ($l=~m/^city:\s+(\S.+\S)\s*$/) { $tmp{$id}->city($1); } elsif ($l=~m/^postal code:\s+(\S.+\S)\s*$/) { $tmp{$id}->pc($1); } elsif ($l=~m/^street address:\s+(\S.+\S)\s*$/) { push @s,$1; } elsif ($l=~m/^organization:\s+(\S.+\S)\s*$/) { $tmp{$id}->org($1); $tmp{$id}->street([reverse(@s)]) if @s; @s=(); } elsif ($l=~m/^personname:\s+(\S.+\S)\s*$/) { $tmp{$id}->name($1); $tmp{$id}->street([reverse(@s)]) if @s; @s=(); } } $rinfo->{domain}->{$domain}->{contact}=$cs; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/US.pm0000644000175000017500000001022111352534377021374 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .US (RFC3912) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::US; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::US - .US Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_registrars($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_contacts($po,$domain,$rr,$rinfo,{registrant => 'Registrant',admin => 'Administrative Contact', billing => 'Billing Contact', tech => 'Technical Contact'}); Net::DRI::Protocol::Whois::Domain::common::epp_parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain ID'}->[0]; } else { $e=0; ($dom)=grep { m/^Not found: domain (\S+)\s*$/ } @$rd; $dom=~s/domain (\S+)\s*$/$1/; $dom=lc($dom); } return ($dom,$e); } sub parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{clName}=$rr->{'Sponsoring Registrar'}->[0]; $rinfo->{domain}->{$domain}->{crName}=$rr->{'Created by Registrar'}->[0]; $rinfo->{domain}->{$domain}->{upName}=$rr->{'Last Updated by Registrar'}->[0]; } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%a %b %d %T GMT %Y', locale => 'en_US', time_zone => 'UTC'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'Domain Registration Date'}->[0]); $rinfo->{domain}->{$domain}->{exDate}=$strp->parse_datetime($rr->{'Domain Expiration Date'}->[0]); $rinfo->{domain}->{$domain}->{upDate}=$strp->parse_datetime($rr->{'Domain Last Updated Date'}->[0]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/ORG.pm0000644000175000017500000000660511352534377021507 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .ORG (RFC3912) ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::ORG; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::ORG - .ORG Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; Net::DRI::Protocol::Whois::Domain::common::epp_parse_registrars($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_dates($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_contacts($po,$domain,$rr,$rinfo,{registrant => 'Registrant',admin => 'Admin', tech => 'Tech'}); Net::DRI::Protocol::Whois::Domain::common::epp_parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain ID'}->[0]; } else { $e=0; } return ($dom,$e); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/COM.pm0000644000175000017500000001046511352534377021475 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .COM/.NET (RFC3912) ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::COM; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Core::Status; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::COM - .COM/.NET Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_registrars($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); parse_status($po,$domain,$rr,$rinfo); parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=$rr->{'Domain Name'}->[0]; } else { $e=0; ($dom)=grep { m/^No match for domain "\S+"\./ } @$rd; $dom=~s/^.+"(\S+)".+$/$1/; } return (lc($dom),$e); } sub parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{clName}=$rr->{'Registrar'}->[0]; $rinfo->{domain}->{$domain}->{clWhois}=$rr->{'Whois Server'}->[0]; $rinfo->{domain}->{$domain}->{clWebsite}=$rr->{'Referral URL'}->[0]; } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%d-%b-%Y', locale => 'en_US', time_zone => 'America/New_York'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'Creation Date'}->[0]); $rinfo->{domain}->{$domain}->{upDate}=$strp->parse_datetime($rr->{'Updated Date'}->[0]); $rinfo->{domain}->{$domain}->{exDate}=$strp->parse_datetime($rr->{'Expiration Date'}->[0]); my ($l)=($rr->{'>>> Last update of whois database'}->[0]=~m/^(.+) <<<$/); $strp=$po->build_strptime_parser(pattern => '%a, %d %b %Y %T UTC', locale => 'en_US', time_zone => 'UTC'); $rinfo->{domain}->{$domain}->{wuDate}=$strp->parse_datetime($l); } sub parse_status { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{status}=Net::DRI::Protocol::EPP::Core::Status->new($rr->{'Status'}); ##### } sub parse_ns { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{ns}=$po->create_local_object('hosts')->set(@{$rr->{'Name Server'}}) if exists($rr->{'Name Server'}); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/common.pm0000644000175000017500000001324411352534377022345 0ustar patrickpatrick## Domain Registry Interface, Whois common parse subroutines ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::common; use strict; use warnings; use Net::DRI::Protocol::EPP::Core::Status; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::common - Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub epp_parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; my %t=('Sponsoring Registrar' => 'cl', 'Created By' => 'cr', 'Created by Registrar' => 'cr', 'Updated By' => 'up', 'Last Updated by Registrar' => 'up', ); while(my ($whois,$epp)=each(%t)) { next unless exists($rr->{$whois}); my $s=$rr->{$whois}->[0]; if ($s=~m/^\s*(\S.+\S)\s+\((\S+)\)\s*$/) { $rinfo->{domain}->{$domain}->{$epp.'ID'}=$2; $rinfo->{domain}->{$domain}->{$epp.'Name'}=$1; } else { $rinfo->{domain}->{$domain}->{$epp.'ID'}=$s; } } } sub epp_parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%d-%b-%Y %T UTC', locale => 'en_US', time_zone => 'UTC'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'Created On'}->[0]); foreach my $k ('Updated On','Last Updated On') { next unless exists($rr->{$k}); $rinfo->{domain}->{$domain}->{upDate}=$strp->parse_datetime($rr->{$k}->[0]); last; } foreach my $k ('Expires On','Expiration Date') { next unless exists($rr->{$k}); $rinfo->{domain}->{$domain}->{exDate}=$strp->parse_datetime($rr->{$k}->[0]); last; } } sub epp_parse_status { my ($po,$domain,$rr,$rinfo)=@_; my @s; if (exists($rr->{'Domain Status'})) { @s=map { my $s=$_; $s=~s/OK/ok/; $s; } @{$rr->{'Domain Status'}}; } elsif (exists($rr->{'Status'})) ## .ORG/.INFO/.MOBI/.CAT variation { @s=map { my $t=lc($_); $t=~s/ (.)/uc($1)/eg; $t; } @{$rr->{'Status'}}; } $rinfo->{domain}->{$domain}->{status}=Net::DRI::Protocol::EPP::Core::Status->new(\@s) if @s; } sub epp_parse_contacts { my ($po,$domain,$rr,$rinfo,$rh)=@_; my $cs=$po->create_local_object('contactset'); while(my ($type,$whois)=each(%$rh)) { my $c=$po->create_local_object('contact'); $c->roid($rr->{$whois.' ID'}->[0]) if (exists($rr->{$whois.' ID'}) && $rr->{$whois.' ID'}->[0]); $c->name($rr->{$whois.' Name'}->[0]) if (exists($rr->{$whois.' Name'}) && $rr->{$whois.' Name'}->[0]); $c->org($rr->{$whois.' Organization'}->[0]) if (exists($rr->{$whois.' Organization'}) && $rr->{$whois.' Organization'}->[0]); my @s; foreach my $st (qw/Street Address/) ## 2nd form needed for .BIZ { my $k=$whois.' '.$st; @s=map { $rr->{$k.$_}->[0] } grep { exists($rr->{$k.$_}) && $rr->{$k.$_}->[0] } (1..3); next unless @s; $c->street(\@s); last; } $c->city($rr->{$whois.' City'}->[0]) if (exists($rr->{$whois.' City'}) && $rr->{$whois.' City'}->[0]); $c->sp($rr->{$whois.' State/Province'}->[0]) if (exists($rr->{$whois.' State/Province'}) && $rr->{$whois.' State/Province'}->[0]); $c->pc($rr->{$whois.' Postal Code'}->[0]) if (exists($rr->{$whois.' Postal Code'}) && $rr->{$whois.' Postal Code'}->[0]); $c->cc($rr->{$whois.' Country'}->[0]) if (exists($rr->{$whois.' Country'}) && $rr->{$whois.' Country'}->[0]); my $t; foreach my $st ('Phone','Phone Number') ## 2nd form needed for .BIZ { $t=epp_parse_tel($po,$rr,$whois.' '.$st); next unless $t; $c->voice($t); last; } foreach my $st ('FAX','Facsimile Number') ## 2nd form needed for .BIZ { $t=epp_parse_tel($po,$rr,$whois.' '.$st); next unless $t; $c->fax($t); last; } $c->email($rr->{$whois.' Email'}->[0]) if (exists($rr->{$whois.' Email'}) && $rr->{$whois.' Email'}->[0]); $cs->add($c,$type); } $rinfo->{domain}->{$domain}->{contact}=$cs; } sub epp_parse_tel { my ($po,$rr,$key)=@_; return '' unless (exists($rr->{$key}) && $rr->{$key}->[0]); my $r=$rr->{$key}->[0]; $r.='x'.$rr->{$key.' Ext.'}->[0] if (exists($rr->{$key.' Ext.'}) && $rr->{$key.' Ext.'}->[0]); return $r; } sub epp_parse_ns { my ($po,$domain,$rr,$rinfo)=@_; return unless (exists($rr->{'Name Server'})); my @ns=grep { defined($_) && $_ } @{$rr->{'Name Server'}}; $rinfo->{domain}->{$domain}->{ns}=$po->create_local_object('hosts')->set(@ns) if @ns; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/AERO.pm0000644000175000017500000000721011352534377021577 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .AERO (RFC3912) ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::AERO; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; use Net::DRI::Data::Contact::AERO; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::AERO - .AERO Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; Net::DRI::Protocol::Whois::Domain::common::epp_parse_registrars($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_dates($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_contacts($po,$domain,$rr,$rinfo,{registrant => 'Registrant',admin => 'Admin', billing => 'Billing', tech => 'Tech'}); Net::DRI::Protocol::Whois::Domain::common::epp_parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{ens}={auth_id => $rr->{'ENS_AuthId'}->[0] }; $rinfo->{domain}->{$dom}->{clWebsite}=$rr->{'Maintainer'}->[0] ; $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain ID'}->[0]; } else { $e=0; ($dom)=grep { m/^No match for domain "\S+"\./ } @$rd; $dom=~s/^.+"(\S+)".+$/$1/; $dom=lc($dom); } return ($dom,$e); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/WS.pm0000644000175000017500000001233511352534377021406 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .WS (RFC3912) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::WS; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::WS - .WS Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_registrar($po,$domain,$rr,$rinfo); parse_contacts($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rd,$rinfo); parse_ns($po,$domain,$rd,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); } else ## may also be invalid domain name or reserved domain name { $e=0; } return ($dom,$e); } ## Does not seem to be always there ! (present for whatever.ws, not present for website.ws) sub parse_registrar { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{clName}=$rr->{'Registrar Name'}->[0] if (exists($rr->{'Registrar Name'}) && $rr->{'Registrar Name'}->[0]) ; $rinfo->{domain}->{$domain}->{clEmail}=$rr->{'Registrar Email'}->[0] if (exists($rr->{'Registrar Email'}) && $rr->{'Registrar Email'}->[0]); $rinfo->{domain}->{$domain}->{clVoice}=$rr->{'Registrar Telephone'}->[0] if (exists($rr->{'Registrar Telephone'}) && $rr->{'Registrar Telephone'}->[0]); $rinfo->{domain}->{$domain}->{clWhois}=$rr->{'Registrar Whois'}->[0] if (exists($rr->{'Registrar Whois'}) &&$rr->{'Registrar Whois'}->[0]) ; } ## Does not seem to be always there (see previous example, opposite case) sub parse_contacts { my ($po,$domain,$rr,$rinfo)=@_; my $cs=$po->create_local_object('contactset'); if (exists($rr->{'Registrant Name'}) && $rr->{'Registrant Name'}->[0]) { my $c=$po->create_local_object('contact'); $c->name($rr->{'Registrant Name'}->[0]); $c->email($rr->{'Registrant Email'}->[0]); $cs->add($c,'registrant'); } if (exists($rr->{'Administrative Contact Email'}) && $rr->{'Administrative Contact Email'}->[0]) { my $c=$po->create_local_object('contact'); $c->email($rr->{'Administrative Contact Email'}->[0]); $c->voice($rr->{'Administrative Contact Telephone'}->[0]); $cs->add($c,'admin'); } $rinfo->{domain}->{$domain}->{contact}=$cs; } sub parse_dates { my ($po,$domain,$rd,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%Y-%m-%d %T', time_zone => 'America/Los_Angeles'); my @tmp; @tmp=grep { m/Domain created on/ } @$rd; $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime(($tmp[0]=~m/^\s+Domain created on (\S+ \S+)\s*$/)[0]) if @tmp; @tmp=grep { m/Domain last updated on/ } @$rd; $rinfo->{domain}->{$domain}->{upDate}=$strp->parse_datetime(($tmp[0]=~m/^\s+Domain last updated on (\S+ \S+)\s*$/)[0]) if @tmp; } sub parse_ns { my ($po,$domain,$rd,$rinfo)=@_; my @ns; foreach my $l (@$rd) { next unless (($l=~m/^\s+ Current Nameservers:/)..1); push @ns,$1 if ($l=~m/^\s*(\S+[^\.])\.?\s*$/); } $rinfo->{domain}->{$domain}->{ns}=$po->create_local_object('hosts')->set(@ns) if @ns; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/MOBI.pm0000644000175000017500000000753511352534377021611 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .MOBI (RFC3912) ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::MOBI; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::MOBI - .MOBI Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; Net::DRI::Protocol::Whois::Domain::common::epp_parse_registrars($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_dates($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_contacts($po,$domain,$rr,$rinfo,{registrant => 'Registrant',admin => 'Admin', tech => 'Tech'}); Net::DRI::Protocol::Whois::Domain::common::epp_parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain ID'}->[0]; if (exists($rr->{'Trademark Name'})) { $rinfo->{domain}->{$dom}->{trademark}={ map { $_ => $rr->{'Trademark '.ucfirst($_)}->[0] } grep { exists($rr->{'Trademark '.ucfirst($_)}) } qw/name country number/ }; foreach my $f ('applied for','registered') { next unless exists($rr->{'Date Trademark '.ucfirst($f)}); my $mf='date_'.$f; $mf=~s/ /_/g; $rinfo->{domain}->{$dom}->{trademark}->{$mf}=$rr->{'Date Trademark '.ucfirst($f)}->[0]; } } } else { $e=0; } return ($dom,$e); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/CAT.pm0000644000175000017500000001013411352534377021457 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .CAT (RFC3912) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::CAT; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::CAT - .CAT Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command(' -C US-ASCII ace '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_registrars($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_contacts($po,$domain,$rr,$rinfo,{registrant => 'Registrant',admin => 'Admin', billing => 'Billing', tech => 'Tech'}); Net::DRI::Protocol::Whois::Domain::common::epp_parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain ID'}->[0]; $rinfo->{domain}->{$dom}->{maintainer}=$rr->{'Maintainer'}->[0] if exists($rr->{'Maintainer'}); ## Domain Name ACE / Domain Language } else { $e=0; } return ($dom,$e); } sub parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; return unless exists($rr->{'Registrar ID'}); ($rinfo->{domain}->{$domain}->{clID},$rinfo->{domain}->{$domain}->{clName})=($rr->{'Registrar ID'}->[0]=~m/^(\S+) \((.+)\)\s*$/); } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%Y-%m-%d %T GMT', time_zone => 'GMT'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'Created On'}->[0]); $rinfo->{domain}->{$domain}->{upDate}=$strp->parse_datetime($rr->{'Last Updated On'}->[0]); $rinfo->{domain}->{$domain}->{exDate}=$strp->parse_datetime($rr->{'Expiration Date'}->[0]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/SE.pm0000644000175000017500000001141211352534377021357 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .SE (RFC3912) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::SE; use strict; use warnings; use Carp; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Core::Status; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::SE - .SE Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command(lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_contacts($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); parse_ns($po,$domain,$rr,$rinfo); parse_status($po,$domain,$rr,$rinfo); parse_registrars($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'domain'})) { $e=1; $dom=lc($rr->{'domain'}->[0]); ## what is state ? } else { $e=0; } return ($dom,$e); } sub parse_contacts { my ($po,$domain,$rr,$rinfo)=@_; my $cs=$po->create_local_object('contactset'); my %t=qw/holder registrant admin-c admin tech-c tech billing-c billing/; while (my ($s,$type)=each(%t)) { next unless (exists($rr->{$s}) && $rr->{$s}->[0] && ($rr->{$s}->[0] ne '-')); my $c=$po->create_local_object('contact'); $c->srid($rr->{$s}->[0]); $cs->add($c,$type); } $rinfo->{domain}->{$domain}->{contact}=$cs; } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%Y-%m-%d', time_zone => 'Europe/Stockholm'); my %t=qw/created crDate modified upDate expires exDate/; while (my ($s,$type)=each(%t)) { next unless (exists($rr->{$s}) && $rr->{$s}->[0] && ($rr->{$s}->[0] ne '-')); $rinfo->{domain}->{$domain}->{$type}=$strp->parse_datetime($rr->{$s}->[0]); } } sub parse_ns { my ($po,$domain,$rr,$rinfo)=@_; return unless (exists($rr->{nserver})); my $h=$po->create_local_object('hosts'); foreach my $ns (grep { defined($_) && $_ } @{$rr->{nserver}}) { my @w=split(/ /,$ns); my $name=shift(@w); if (@w) { $h->add($name,\@w); } else { $h->add($name); } } $rinfo->{domain}->{$domain}->{ns}=$h unless $h->is_empty(); } sub parse_status { my ($po,$domain,$rr,$rinfo)=@_; return unless (exists($rr->{'status'})); my @s=@{$rr->{'status'}}; carp('For '.$domain.' new status found, please report: '.join(' ',@s)) if (grep { $_ ne 'ok' } @s); $rinfo->{domain}->{$domain}->{status}=Net::DRI::Protocol::EPP::Core::Status->new(\@s) if @s; $rinfo->{domain}->{$domain}->{dnssec}=$rr->{'dnssec'}->[0]; } sub parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; return unless (exists($rr->{'registrar'})); $rinfo->{domain}->{$domain}->{clName}=$rr->{registrar}->[0]; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/TRAVEL.pm0000644000175000017500000001044311352534377022050 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .TRAVEL (RFC3912) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::TRAVEL; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::TRAVEL - .TRAVEL Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_registrars($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_contacts($po,$domain,$rr,$rinfo,{registrant => 'Registrant',admin => 'Administrative Contact', billing => 'Billing Contact', tech => 'Technical Contact'}); Net::DRI::Protocol::Whois::Domain::common::epp_parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain ID'}->[0]; } else { $e=0; ($dom)=grep { m/^Not found: domain (\S+)\s*$/ } @$rd; $dom=~s/domain (\S+)\s*$/$1/; $dom=lc($dom); } return ($dom,$e); } sub parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{clName}=$rr->{'Sponsoring Registrar'}->[0]; $rinfo->{domain}->{$domain}->{clID}=$rr->{'Sponsoring Registrar IANA ID'}->[0] if exists($rr->{'Sponsoring Registrar IANA ID'}); $rinfo->{domain}->{$domain}->{crName}=$rr->{'Created by Registrar'}->[0]; $rinfo->{domain}->{$domain}->{upName}=$rr->{'Last Updated by Registrar'}->[0]; } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%a %b %d %T GMT %Y', locale => 'en_US', time_zone => 'UTC'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'Domain Registration Date'}->[0]); $rinfo->{domain}->{$domain}->{exDate}=$strp->parse_datetime($rr->{'Domain Expiration Date'}->[0]); $rinfo->{domain}->{$domain}->{upDate}=$strp->parse_datetime($rr->{'Domain Last Updated Date'}->[0]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/BIZ.pm0000644000175000017500000001042711352534377021501 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .BIZ (RFC3912) ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::BIZ; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::BIZ - .BIZ Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_registrars($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_contacts($po,$domain,$rr,$rinfo,{registrant => 'Registrant',admin => 'Administrative Contact', billing => 'Billing Contact', tech => 'Technical Contact'}); Net::DRI::Protocol::Whois::Domain::common::epp_parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain ID'}->[0]; } else { $e=0; ($dom)=grep { m/^Not found: domain (\S+)\s*$/ } @$rd; $dom=~s/domain (\S+)\s*$/$1/; $dom=lc($dom); } return ($dom,$e); } sub parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{clName}=$rr->{'Sponsoring Registrar'}->[0]; $rinfo->{domain}->{$domain}->{clID}=$rr->{'Sponsoring Registrar IANA ID'}->[0] if exists($rr->{'Sponsoring Registrar IANA ID'}); $rinfo->{domain}->{$domain}->{crName}=$rr->{'Created by Registrar'}->[0]; $rinfo->{domain}->{$domain}->{upName}=$rr->{'Last Updated by Registrar'}->[0]; } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%a %b %d %T GMT %Y', locale => 'en_US', time_zone => 'UTC'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'Domain Registration Date'}->[0]); $rinfo->{domain}->{$domain}->{exDate}=$strp->parse_datetime($rr->{'Domain Expiration Date'}->[0]); $rinfo->{domain}->{$domain}->{upDate}=$strp->parse_datetime($rr->{'Domain Last Updated Date'}->[0]); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/NAME.pm0000644000175000017500000000577211352534377021604 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .NAME (RFC3912) ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::NAME; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::NAME - .NAME Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name ID'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain Name ID'}->[0]; } else { $e=0; } return ($dom,$e); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/PT.pm0000644000175000017500000001077611352534377021407 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .SE (RFC3912) ## ## Copyright (c) 2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::PT; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::PT - .PT Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command(lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_dates($po,$domain,$rr,$rinfo); parse_contacts($po,$domain,$rr,$rd,$rinfo); parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{"Nome de dom\x{ED}nio / Domain Name"})) { $e=1; $dom=lc($rr->{"Nome de dom\x{ED}nio / Domain Name"}->[0]); } else { $e=0; } return ($dom,$e); } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%d/%m/%Y', time_zone => 'Europe/Lisbon'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'Data de registo / Creation Date (dd/mm/yyyy)'}->[0]); } sub parse_contacts { my ($po,$domain,$rr,$rd,$rinfo)=@_; my $cs=$po->create_local_object('contactset'); my @m=qw/name street city pc cc email/; my @t=qw/billing admin tech/; my $c; foreach my $l (@$rd) { $l=~s/^\s+//; $l=~s/\s+$//; if (($l=~m!Titular / Registrant!)..($l=~m/^\s*$/)) { next if ($l eq 'Titular / Registrant'); if ($l=~m/^\s*$/) { $cs->add($c,'registrant'); $c=undef; next; } $l=~s/^Email:\s+//; $c=$po->create_local_object('contact') unless defined $c; my $m=shift(@m); $c->$m($m eq 'street'? [$l] : $l); } if (($l=~m!^(Entidade Gestora / Billing Contact|Respons\x{E1}vel Administrativo / Admin Contact|Respons\x{E1}vel T\x{E9}cnico / Tech Contact)$!)..($l=~m/^\s*$/)) { next if $l=~m! / \S+ Contact$!; if ($l=~m/^\s*$/) { $cs->add($c,shift(@t)); $c=undef; next; } if ($l=~s/^Email:\s+//) { $c->email($l); } else { $c=$po->create_local_object('contact'); $c->name($l); } } } $rinfo->{domain}->{$domain}->{contact}=$cs; } sub parse_ns { my ($po,$domain,$rr,$rinfo)=@_; return unless (exists($rr->{Nameserver})); my $h=$po->create_local_object('hosts'); foreach my $ns (grep { defined($_) && $_ } @{$rr->{Nameserver}}) { $h->add($ns); } $rinfo->{domain}->{$domain}->{ns}=$h unless $h->is_empty(); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/EU.pm0000644000175000017500000001011311352534377021356 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .EU (RFC3912) ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::EU; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Protocol::EPP::Core::Status; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::EU - .EU Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command(lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); die(Net::DRI::Protocol::ResultStatus->new_error('SESSION_LIMIT_EXCEEDED_CLOSING','Registry rate limiting','en')) if $rd=~m/Still in grace period, wait/; my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_registrars($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); parse_status($po,$domain,$rr,$rinfo); parse_ns($po,$domain,$rr,$rd,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my $dom=lc($rr->{'Domain'}->[0]).'.eu'; my $e=(exists($rr->{'Status'}) && ($rr->{'Status'}->[0] eq 'AVAILABLE'))? 0 : 1; return ($dom,$e); } sub parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{clName}=$rr->{'Name'}->[-1]; $rinfo->{domain}->{$domain}->{clWebsite}=$rr->{'Website'}->[-1] if exists $rr->{'Website'}; } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; return unless exists $rr->{'Registered'}; my $strp=$po->build_strptime_parser(pattern => '%a %b%n%d %Y', locale => 'en_US', time_zone => 'Europe/Brussels'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'Registered'}->[0]); } sub parse_status { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{status}=Net::DRI::Protocol::EPP::Core::Status->new(['ok']); } sub parse_ns { my ($po,$domain,$rr,$rd,$rinfo)=@_; my $ns=$po->create_local_object('hosts'); foreach my $l (@$rd) { next unless (($l=~m/^Nameservers:/)..($l=~m/^\s*$/)); $l=~s/^\s+//; $l=~s/[)\s]+$//; next unless length($l); $ns->add(split(/ \(?/,$l)); } $rinfo->{domain}->{$domain}->{ns}=$ns; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/INFO.pm0000644000175000017500000000717511352534377021616 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .INFO (RFC3912) ## ## Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::INFO; use strict; use warnings; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::Whois::Domain::common; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::INFO - .INFO Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command('domain '.lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; Net::DRI::Protocol::Whois::Domain::common::epp_parse_registrars($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_dates($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_status($po,$domain,$rr,$rinfo); Net::DRI::Protocol::Whois::Domain::common::epp_parse_contacts($po,$domain,$rr,$rinfo,{registrant => 'Registrant',admin => 'Admin', billing => 'Billing', tech => 'Tech'}); Net::DRI::Protocol::Whois::Domain::common::epp_parse_ns($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if (exists($rr->{'Domain Name'})) { $e=1; $dom=lc($rr->{'Domain Name'}->[0]); $rinfo->{domain}->{$dom}->{roid}=$rr->{'Domain ID'}->[0]; if (exists($rr->{'Trademark Name'})) { $rinfo->{domain}->{$dom}->{trademark}={ map { $_ => $rr->{'Trademark '.ucfirst($_)}->[0] } grep { exists($rr->{'Trademark '.ucfirst($_)}) } qw/name date country number/ }; } } else { $e=0; } return ($dom,$e); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Domain/LU.pm0000644000175000017500000001272711352534377021402 0ustar patrickpatrick## Domain Registry Interface, Whois commands for .LU (RFC3912) ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Domain::LU; use strict; use warnings; use Carp; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::EPP::Core::Status; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Domain::LU - .LU Whois commands (RFC3912) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub register_commands { my ($class,$version)=@_; return { 'domain' => { info => [ \&info, \&info_parse ] } }; } sub info { my ($po,$domain,$rd)=@_; my $mes=$po->message(); Net::DRI::Exception->die(1,'protocol/whois',10,'Invalid domain name: '.$domain) unless Net::DRI::Util::is_hostname($domain); $mes->command(lc($domain)); } sub info_parse { my ($po,$otype,$oaction,$oname,$rinfo)=@_; my $mes=$po->message(); return unless $mes->is_success(); my $rr=$mes->response(); my $rd=$mes->response_raw(); my ($domain,$exist)=parse_domain($po,$rr,$rd,$rinfo); $domain=lc($oname) unless defined($domain); $rinfo->{domain}->{$domain}->{exist}=$exist; $rinfo->{domain}->{$domain}->{action}='info'; return unless $exist; parse_status($po,$domain,$rr,$rinfo); parse_ns($po,$domain,$rr,$rinfo); parse_dates($po,$domain,$rr,$rinfo); parse_contacts($po,$domain,$rr,$rinfo); parse_registrars($po,$domain,$rr,$rinfo); } sub parse_domain { my ($po,$rr,$rd,$rinfo)=@_; my ($dom,$e); if ($rd=~m/\n% WHOIS (\S+)\n% No such domain$/s) { $dom=$1.'.lu'; $e=0; } else { $e=1; $dom=lc($rr->{'domainname'}->[0]); } return ($dom,$e); } sub parse_status { my ($po,$domain,$rr,$rinfo)=@_; my @s=map { my $s=$_; $s=~s/ACTIVE/ok/; $s; } @{$rr->{'domaintype'}}; carp('For '.$domain.' new status found, please report: '.join(' ',@s)) if (grep { $_ ne 'ok' } @s); $rinfo->{domain}->{$domain}->{status}=Net::DRI::Protocol::EPP::Core::Status->new(\@s) if @s; } sub parse_ns { my ($po,$domain,$rr,$rinfo)=@_; my $h=$po->create_local_object('hosts'); foreach my $ns (grep { defined($_) && $_ } @{$rr->{'nserver'}}) { if (my ($name,$ips)=($ns=~m/^(\S+) \[(\S+)\]$/)) { my @ips=split(/,/,$ips); $h->add($name,\@ips); } else { $h->add($ns); } } $rinfo->{domain}->{$domain}->{ns}=$h unless $h->is_empty(); } sub parse_dates { my ($po,$domain,$rr,$rinfo)=@_; my $strp=$po->build_strptime_parser(pattern => '%d/%m/%Y', time_zone => 'Europe/Luxembourg'); $rinfo->{domain}->{$domain}->{crDate}=$strp->parse_datetime($rr->{'registered'}->[0]); } sub parse_contacts { my ($po,$domain,$rr,$rinfo)=@_; my $cs=$po->create_local_object('contactset'); my %t=('org' => 'registrant', 'adm' => 'admin', 'tec' => 'tech'); foreach my $t (keys(%t)) { my $c=$po->create_local_object('contact'); $c->type('contact'); $c->name($rr->{$t.'-name'}->[0]) if (exists($rr->{$t.'-name'}) && $rr->{$t.'-name'}->[0]); $c->street($rr->{$t.'-address'}) if (exists($rr->{$t.'-address'}) && @{$rr->{$t.'-address'}}); $c->pc($rr->{$t.'-zipcode'}->[0]) if (exists($rr->{$t.'-zipcode'}) && $rr->{$t.'-zipcode'}->[0]); $c->city($rr->{$t.'-city'}->[0]) if (exists($rr->{$t.'-city'}) && $rr->{$t.'-city'}->[0]); $c->cc($rr->{$t.'-country'}->[0]) if (exists($rr->{$t.'-country'}) && $rr->{$t.'-country'}->[0]); $c->email($rr->{$t.'-email'}->[0]) if (exists($rr->{$t.'-email'}) && $rr->{$t.'-email'}->[0]); $cs->add($c,$t{$t}); } my %ot=('ORGANISATION' => 'holder_org', 'PRIVATE' => 'holder_pers'); my $type=$rr->{'ownertype'}->[0]; carp('For '.$domain.' new ownertype found, please report: '.$type) if ($type ne 'ORGANISATION' && $type ne 'PRIVATE'); $cs->get('registrant')->type($ot{$type}); $rinfo->{domain}->{$domain}->{contact}=$cs; } sub parse_registrars { my ($po,$domain,$rr,$rinfo)=@_; $rinfo->{domain}->{$domain}->{clName}=$rr->{'registrar-name'}->[0]; $rinfo->{domain}->{$domain}->{clEmail}=$rr->{'registrar-email'}->[0]; $rinfo->{domain}->{$domain}->{clWebsite}=$rr->{'registrar-url'}->[0]; $rinfo->{domain}->{$domain}->{clCountry}=$rr->{'registrar-country'}->[0]; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Whois/Message.pm0000644000175000017500000000621611352534377021233 0ustar patrickpatrick## Domain Registry Interface, Whois Message ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::Whois::Message; use strict; use warnings; use Net::DRI::Protocol::ResultStatus; use Net::DRI::Exception; use Net::DRI::Util; use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message); __PACKAGE__->mk_accessors(qw(version errcode errmsg errlang command cltrid response response_raw)); our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Whois::Message - Whois Message for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$trid)=@_; my $self={ errcode => -1000, response => {}, }; bless($self,$class); $self->cltrid($trid) if (defined($trid) && $trid); return $self; } sub is_success { return (shift->errcode()==0)? 1 : 0; } sub result_status { my $self=shift; my %C=( 0 => 1500, ## Command successful + connection closed ); my $c=$self->errcode(); my $rs=Net::DRI::Protocol::ResultStatus->new('whois',$c,exists($C{$c})? $C{$c} : $Net::DRI::Protocol::ResultStatus::EPP_CODES{GENERIC_ERROR},$self->is_success(),$self->errmsg(),$self->errlang(),undef); $rs->_set_trid([ $self->cltrid(),undef ]); return $rs; } sub as_string { my ($self)=@_; my $s=sprintf("%s\x0d\x0a",$self->command()); return $s; } sub parse { my ($self,$dc,$rinfo)=@_; my @d=$dc->as_array(); my %info; foreach my $l (grep { /:/ } @d) { my ($k,$v)=($l=~m/^\s*(\S[^:]*\S)\s*:\s*(\S.*\S)\s*$/); next unless ($k && $v); if (exists($info{$k})) { push @{$info{$k}},$v; } else { $info{$k}=[$v]; } } $self->errcode(0); $self->response(\%info); $self->response_raw(\@d); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/Message.pm0000644000175000017500000000355111352534377020141 0ustar patrickpatrick## Domain Registry Interface, Protocol messages (pure virtual superclass) ## ## Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::Message; use strict; use base qw/Net::DRI::BaseClass/; __PACKAGE__->make_exception_if_not_implemented(qw/new is_success result_status parse version as_string/); our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::Message - Superclass of all protocol messages in Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/ResultStatus.pm0000644000175000017500000003141611352534377021240 0ustar patrickpatrick## Domain Registry Interface, Encapsulating result status, standardized on EPP codes ## ## Copyright (c) 2005,2006,2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::ResultStatus; use strict; use warnings; use base qw(Class::Accessor::Chained::Fast); __PACKAGE__->mk_ro_accessors(qw(is_success native_code code message lang next)); use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.25 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::ResultStatus - Encapsulate Details of an Operation Result (with Standardization on EPP) for Net::DRI =head1 DESCRIPTION An object of this class represents all details of an operation result as given back from the registry, with standardization on EPP as much as possible, for error codes and list of fields available. When an operation is done, data retrieved from the registry is also stored inside the ResultStatus object (besides being available through C<$dri->get_info()>). It can be queried using the C and C methods as explained below. The data is stored as a ref hash with 3 levels: the first keys have as values a reference to another hash where keys are again associated with values being a reference to another hash where the content (keys and values) depends on the registry, the operation attempted, and the result. Some data will always be there: a "session" first key, with a "exchange" subkey, will have a reference to an hash with the following keys: =over =item duration_seconds the duration of the exchange with registry, in a floating point number of seconds =item raw_command the message sent to the registry, as string =item raw_reply the message received from the registry, as string =item result_from_cache either 0 or 1 if these results were retrieved from L Cache object or not =item object_action name of the action that has been done to achieve these results (ex: "info") =item object_name name (or ID) of the object on which the action has been performed (not necessarily always defined) =item object_type type of object on which this operation has been done (ex: "domain") =item registry, profile, transport, protocol registry name, profile name, transport name+version, protocol name+version used for this exchange =item trid transaction ID of this exchange =back =head1 METHODS =head2 is_success() returns 1 if the operation was a success =head2 code() returns the EPP code corresponding to the native code (which depends on the registry) for this operation (see RFC for full list and source of this file for local extensions) =head2 native_code() gives the true status code we got back from registry (this breaks the encapsulation provided by Net::DRI, you should not use it if possible) =head2 message() gives the message attached to the the status code we got back from registry =head2 lang() gives the language in which the message above is written =head2 get_extended_results() gives back an array with additionnal result information from registry, especially in case of errors. If no data, an empty array is returned. This method was previously called info(), before C version 0.92_01 =head2 get_data() See explanation of data stored in L. Can be called with one or three parameters and always returns a single value (or undef if failure). With three parameters, it returns the value associated to the three keys/subkeys passed. Example: C will return 0 or 1 depending if the domain exists or not, after a domain check or domain info operation. With only one parameter, it will verify there is only one branch (besides session/exchange and message/info), and if so returns the data associated to the parameter passed used as the third key. Otherwise will return undef. Please note that the input API is I the same as the one used for C<$dri->get_info()>. =head2 get_data_collection() See explanation of data stored in L. Can be called with either zero, one or two parameters and may return a list or a single value depending on calling context (and respectively an empty list or undef in case of failure). With no parameter, it returns the whole data as reference to an hash with 2 levels beneath as explained in L in scalar context, or the list of keys of this hash in list context. With one parameter, it returns the hash referenced by the key given as argument at first level in scalar context, or the list of keys of this hash in list context. With two parameters, it walks down two level of the hash using the two parameters as key and subkey and returns the bottom hash referenced in scalar context, or the list of keys of this hash in list context. Please note that in all cases you are given references to the data itself, not copies. You should not try to modify it in any way, but just read it. =head2 as_string() returns a string with all details, with the extended_results part if passed a true value =head2 print() same as CORE::print($rs->as_string(0)) =head2 print_full() same as CORE::print($rs->as_string(1)) =head2 trid() in scalar context, gives the transaction id (our transaction id, that is the client part in EPP) which has generated this result, in array context, gives the transaction id followed by other ids given by registry (example in EPP: server transaction id) =head2 is_pending() returns 1 if the last operation was flagged as pending by registry (asynchronous handling) =head2 is_closing() returns 1 if the last operation made the registry close the connection (should not happen often) =head2 is(NAME) if you really need to test some other codes (this should not happen often), you can using symbolic names defined inside this module (see source). Going that way makes sure you are not hardcoding numbers in your application, and you do not need to import variables from this module to your application. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### ## We give symbolic names only to codes that are used in some modules our %EPP_CODES=( COMMAND_SUCCESSFUL => 1000, COMMAND_SUCCESSFUL_PENDING => 1001, ## needed for async registries when action done correctly on our side COMMAND_SUCCESSFUL_END => 1500, ## after logout COMMAND_SYNTAX_ERROR => 2001, PARAMETER_VALUE_SYNTAX_ERROR => 2005, AUTHENTICATION_ERROR => 2200, AUTHORIZATION_ERROR => 2201, OBJECT_EXISTS => 2302, OBJECT_DOES_NOT_EXIST => 2303, COMMAND_FAILED => 2400, ## Internal server error not related to the protocol COMMAND_FAILED_CLOSING => 2500, ## Same + connection dropped SESSION_LIMIT_EXCEEDED_CLOSING => 2502, ## useful for rate limiting problems GENERIC_SUCCESS => 1900, ## these codes are not defined in EPP RFCs, but provide a nice extension GENERIC_ERROR => 2900, ## 19XX for ok (1900=Undefined success), 29XX for errors (2900=Undefined error) ); sub new { my ($class,$type,$code,$eppcode,$is_success,$message,$lang,$info)=@_; my %s=( is_success => (defined($is_success) && $is_success)? 1 : 0, native_code => $code, message => $message || '', type => $type, ## rrp/epp/afnic/etc... lang => $lang || '?', 'next' => undef, data => {}, ); $s{code}=_eppcode($type,$code,$eppcode,$s{is_success}); $s{info}=(defined $info && ref $info eq 'ARRAY')? $info : []; ## should we now put that instead in data->{session}->{registry}->{extra_info} or something like that ? bless(\%s,$class); return \%s; } sub trid { my $self=shift; return unless (exists($self->{trid}) && (ref($self->{trid}) eq 'ARRAY')); return wantarray()? @{$self->{trid}} : $self->{trid}->[0]; } sub get_extended_results { return @{shift->{info}}; } sub get_data { my ($self,$k1,$k2,$k3)=@_; if (! defined $k1 || (defined $k3 xor defined $k2)) { Net::DRI::Exception::err_insufficient_parameters('get_data() expects one or three parameters'); } my $d=$self->{'data'}; ## 3 parameters form, walk the whole references tree if (defined $k2 && defined $k3) { if (! exists $d->{$k1}) { return; } ($k1,$k2)=Net::DRI::Util::normalize_name($k1,$k2); if (! exists $d->{$k1}->{$k2}) { return; } if (! exists $d->{$k1}->{$k2}->{$k3}) { return; } return $d->{$k1}->{$k2}->{$k3}; } ## 1 parameter form, go directly to leafs if not too much of them (we skip session/exchange + message/info) my @k=grep { $_ ne 'session' && $_ ne 'message' } keys %$d; if (@k != 1) { return; } $d=$d->{$k[0]}; if ( keys(%$d) != 1 ) { return; } ($d)=values %$d; if (! exists $d->{$k1}) { return; } return $d->{$k1}; } sub get_data_collection { my ($self,$k1,$k2)=@_; my $d=$self->{'data'}; if (! defined $k1) { return wantarray ? keys %$d : $d; } if (! exists $d->{$k1}) { return; } if (! defined $k2) { return wantarray ? keys %{$d->{$k1}} : $d->{$k1}; } ($k1,$k2)=Net::DRI::Util::normalize_name($k1,$k2); if (! exists $d->{$k1}->{$k2}) { return; } return wantarray ? keys %{$d->{$k1}->{$k2}} : $d->{$k1}->{$k2}; } sub last { my $self=shift; while ( defined $self->next() ) { $self=$self->next(); } return $self; } ## These methods are not public ! sub _set_trid { my ($self,$v)=@_; $self->{'trid'}=$v; } sub _add_next { my ($self,$v)=@_; $self->{'next'}=$v; } sub _add_last { my ($self,$v)=@_; while ( defined $self->next() ) { $self=$self->next(); } $self->{'next'}=$v; } sub _set_data { my ($self,$v)=@_; $self->{'data'}=$v; } sub _eppcode { my ($type,$code,$eppcode,$is_success)=@_; return $EPP_CODES{GENERIC_ERROR} unless defined($type) && $type && defined($code); $eppcode=$code if (!defined($eppcode) && ($type eq 'epp')); return $is_success? $EPP_CODES{GENERIC_SUCCESS} : $EPP_CODES{GENERIC_ERROR} unless defined($eppcode); return $eppcode if ($eppcode=~m/^\d{4}$/); return $EPP_CODES{$eppcode} if exists($EPP_CODES{$eppcode}); return $EPP_CODES{GENERIC_ERROR}; } sub new_generic_success { my ($class,$msg,$lang,$ri)=@_; return $class->new('epp',$EPP_CODES{GENERIC_SUCCESS},undef,1,$msg,$lang,$ri); } sub new_generic_error { my ($class,$msg,$lang,$ri)=@_; return $class->new('epp',$EPP_CODES{GENERIC_ERROR},undef,0,$msg,$lang,$ri); } sub new_success { my ($class,$code,$msg,$lang,$ri)=@_; return $class->new('epp',$code,undef,1,$msg,$lang,$ri); } sub new_error { my ($class,$code,$msg,$lang,$ri)=@_; return $class->new('epp',$code,undef,0,$msg,$lang,$ri); } sub as_string { my ($self,$withinfo)=@_; my $b=sprintf('%s %d %s',$self->is_success()? 'SUCCESS' : 'ERROR',$self->code(),length $self->message() ? ($self->code() eq $self->native_code()? $self->message() : $self->message().' ['.$self->native_code().']') : '(No message given)'); if (defined($withinfo) && $withinfo) { my @i=$self->get_extended_results(); $b.="\n".join("\n",map { my $rh=$_; join(' ',map { $_.'='.$rh->{$_} } sort(keys(%$rh))) } @i) if @i; } return $b; } sub print { print shift->as_string(0); } sub print_full { print shift->as_string(1); } sub is_pending { return (shift->code()==$EPP_CODES{COMMAND_SUCCESSFUL_PENDING})? 1 : 0; } sub is_closing { my $c=shift->code(); return ($c==$EPP_CODES{COMMAND_SUCCESSFUL_END} || ($c>=2500 && $c<=2502))? 1 : 0; } sub is { my ($self,$symcode)=@_; return unless (defined $symcode && length $symcode && exists $EPP_CODES{$symcode}); return ($self->code()==$EPP_CODES{$symcode})? 1 : 0; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/EPP.pm0000644000175000017500000001146511352534377017204 0ustar patrickpatrick## Domain Registry Interface, EPP Protocol (STD 69) ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol::EPP; use strict; use warnings; use base qw(Net::DRI::Protocol); use Net::DRI::Util; use Net::DRI::Protocol::EPP::Message; use Net::DRI::Protocol::EPP::Core::Status; our $VERSION=do { my @r=(q$Revision: 1.14 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::EPP - EPP Protocol (STD 69 aka RFC 5730,5731,5732,5733,5734 obsoleting RFC 3730,3731,3732,3733,3734 and RFC 3735) for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('EPP'); my $version=Net::DRI::Util::check_equal($rp->{version},['1.0'],'1.0'); $self->version($version); foreach my $o (qw/ip status/) { $self->capabilities('host_update',$o,['add','del']); } $self->capabilities('host_update','name',['set']); $self->capabilities('contact_update','status',['add','del']); $self->capabilities('contact_update','info',['set']); foreach my $o (qw/ns status contact/) { $self->capabilities('domain_update',$o,['add','del']); } foreach my $o (qw/registrant auth/) { $self->capabilities('domain_update',$o,['set']); } $self->{hostasattr}=$drd->info('host_as_attr') || 0; $self->{contacti18n}=$drd->info('contact_i18n') || 7; ## bitwise OR with 1=LOC only, 2=INT only, 4=LOC+INT only $self->{defaulti18ntype}=undef; ## only needed for registries not following truely EPP standard, like .CZ $self->{usenullauth}=$drd->info('use_null_auth') || 0; ## See RFC4931 §3.2.5 $self->ns({ _main => ['urn:ietf:params:xml:ns:epp-1.0','epp-1.0.xsd'], domain => ['urn:ietf:params:xml:ns:domain-1.0','domain-1.0.xsd'], host => ['urn:ietf:params:xml:ns:host-1.0','host-1.0.xsd'], contact => ['urn:ietf:params:xml:ns:contact-1.0','contact-1.0.xsd'], }); $drd->set_factories($self) if $drd->can('set_factories'); $self->factories('message',sub { my $m=Net::DRI::Protocol::EPP::Message->new(@_); $m->ns($self->ns()); $m->version($version); return $m; }); $self->factories('status',sub { return Net::DRI::Protocol::EPP::Core::Status->new(); }); $self->_load($rp); $self->setup($rp); return $self; } sub _load { my ($self,$rp)=@_; my $extramods=$rp->{extensions}; my @class=$self->core_modules($rp); push @class,map { 'Net::DRI::Protocol::EPP::Extensions::'.$_; } $self->default_extensions($rp) if $self->can('default_extensions'); push @class,map { my $f=$_; $f='Net::DRI::Protocol::EPP::Extensions::'.$f unless $f=~m/::/; $f=~s!/!::!g; $f; } (ref($extramods)? @$extramods : ($extramods)) if defined $extramods && $extramods; $self->SUPER::_load(@class); } sub setup {} ## subclass as needed sub core_modules { my ($self,$rp)=@_; my @core=qw/Session RegistryMessage Domain Contact/; push @core,'Host' unless $self->{hostasattr}; return map { 'Net::DRI::Protocol::EPP::Core::'.$_ } @core; } sub server_greeting { my ($self,$v)=@_; $self->{server_greeting}=$v if $v; return $self->{server_greeting}; } sub core_contact_types { return ('admin','tech','billing'); } sub ns { my ($self,$add)=@_; $self->{ns}={ ref($self->{ns})? %{$self->{ns}} : (), %$add } if (defined($add) && ref($add) eq 'HASH'); return $self->{ns}; } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::EPP::Connection', protocol_version => 1); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol/RRP.pm0000644000175000017500000001017411352534377017217 0ustar patrickpatrick## Domain Registry Interface, RRP Protocol ## ## Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Protocol::RRP; use strict; use base qw(Net::DRI::Protocol); use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Protocol::RRP::Message; use Net::DRI::Protocol::RRP::Core::Status; use DateTime; use DateTime::TimeZone; use DateTime::Format::Strptime; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol::RRP - RRP 1.1/2.0 Protocol for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut our %DATES=('registration expiration date' => 'exDate', 'created date' => 'crDate', 'updated date' => 'upDate', 'registrar transfer date' => 'trDate', ); our %IDS=('registrar' => 'clID', 'created by' => 'crID', 'updated by' => 'upID', ); ############################################################################### sub new { my ($c,$drd,$rp)=@_; my $self=$c->SUPER::new(); $self->name('RRP'); my $version=Net::DRI::Util::check_equal($rp->{version},['1.1','2.0'],'2.0'); ## 1.1 (RFC #2832) or 2.0 (RFC #3632) $self->version($version); $self->capabilities('host_update','ip',['add','del']); $self->capabilities('host_update','name',['set']); $self->capabilities('domain_update','ns',['add','del']); $self->capabilities('domain_update','status',['add','del']); $self->factories('message',sub { my $m=Net::DRI::Protocol::RRP::Message->new(@_); $m->version($version); return $m; }); $self->factories('status',sub { return Net::DRI::Protocol::RRP::Core::Status->new(); }); ## Verify that we have the timezone of the registry, since dates in RRP are local to registries my $tzname=$drd->info('tz'); Net::DRI::Exception::usererr_insufficient_parameters('no registry timezone') unless (defined($tzname)); my $tz; eval { $tz=DateTime::TimeZone->new(name => $tzname); }; Net::DRI::Exception::usererr_invalid_parameters("invalid registry timezone ($tzname)") unless (defined($tz) && ref($tz)); my $dtp; eval { $dtp=DateTime::Format::Strptime->new(time_zone=>$tz, pattern=>'%Y-%m-%d %H:%M:%S.0'); }; Net::DRI::Exception::usererr_invalid_parameters("invalid registry timezone ($tzname)") unless (defined($dtp) && ref($dtp)); $self->{dt_parse}=$dtp; $self->_load($rp); return $self; } sub _load { my ($self,$rp)=@_; my $extrah=$rp->{extensions}; my @class=map { "Net::DRI::Protocol::RRP::Core::".$_ } ('Session','Domain','Host'); if (defined($extrah) && $extrah) { push @class,map { /::/? $_ : "Net::DRI::Protocol::RRP::Extensions::".$_ } (ref($extrah)? @$extrah : ($extrah)); } $self->SUPER::_load(@class); } sub transport_default { my ($self)=@_; return (protocol_connection => 'Net::DRI::Protocol::RRP::Connection', protocol_version => 1); } ############################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Protocol.pm0000644000175000017500000001771411352534377016563 0ustar patrickpatrick## Domain Registry Interface, Protocol superclass ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Protocol; use strict; use warnings; use base qw(Class::Accessor::Chained::Fast); __PACKAGE__->mk_accessors(qw(name version commands message default_parameters)); use DateTime; use DateTime::Duration; use DateTime::Format::ISO8601; use DateTime::Format::Strptime; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::Data::Changes; use Net::DRI::Data::Contact; use Net::DRI::Data::ContactSet; use Net::DRI::Data::Hosts; use Net::DRI::Data::StatusList; our $VERSION=do { my @r=(q$Revision: 1.22 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Protocol - Superclass of all Net::DRI Protocols =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($c)=@_; my $self={ capabilities => {}, factories => { datetime => sub { return DateTime->new(@_); }, duration => sub { return DateTime::Duration->new(@_); }, changes => sub { return Net::DRI::Data::Changes->new(@_); }, contact => sub { return Net::DRI::Data::Contact->new(); }, contactset => sub { return Net::DRI::Data::ContactSet->new(@_); }, hosts => sub { return Net::DRI::Data::Hosts->new(@_); }, status => sub { return Net::DRI::Data::StatusList->new(@_); }, }, }; bless($self,$c); $self->message(undef); $self->default_parameters({}); return $self; } sub parse_iso8601 { my ($self,$d)=@_; $self->{iso8601_parser}=DateTime::Format::ISO8601->new() unless exists $self->{iso8601_parser}; return $self->{iso8601_parser}->parse_datetime($d); } sub build_strptime_parser { my $self=shift; my $key=join('|',@_); $self->{strptime_parser}->{$key}=DateTime::Format::Strptime->new(@_) unless exists $self->{strptime_parser}->{$key}; return $self->{strptime_parser}->{$key}; } sub create_local_object { my $self=shift; my $what=shift; return unless defined $self && defined $what; my $fn=$self->factories(); return unless (defined($fn) && ref($fn) && exists($fn->{$what}) && (ref($fn->{$what}) eq 'CODE')); return $fn->{$what}->(@_); } ## This should not be called multiple times for a given Protocol class (as it will erase the loaded_modules slot) sub _load { my $self=shift; my $etype='protocol/'.$self->name(); my $version=$self->version(); my (%c,%done,@done); foreach my $class (@_) { next if exists($done{$class}); $class->require or Net::DRI::Exception::err_failed_load_module($etype,$class,$@); Net::DRI::Exception::err_method_not_implemented('register_commands() in '.$class) unless $class->can('register_commands'); my $rh=$class->register_commands($version); Net::DRI::Util::hash_merge(\%c,$rh); ## { object type => { action type => [ build action, parse action ]+ } } if ($class->can('capabilities_add')) { my @a=$class->capabilities_add(); if (ref($a[0])) { foreach my $a (@a) { $self->capabilities(@$a); } } else { $self->capabilities(@a); } } $done{$class}=1; push @done,$class; } $self->{loaded_modules}=\@done; $self->commands(\%c); return; } sub has_module { my ($self,$mod)=@_; return 0 unless defined $mod && $mod; return (grep { $_ eq $mod } @{$self->{loaded_modules}})? 1 : 0; } sub _load_commands { my ($self,$otype,$oaction)=@_; my $etype='protocol/'.$self->name(); Net::DRI::Exception->die(1,$etype,7,'Object type and/or action not defined') unless (defined($otype) && $otype && defined($oaction) && $oaction); my $h=$self->commands(); Net::DRI::Exception->die(1,$etype,8,'No actions defined for object of type <'.$otype.'>') unless exists($h->{$otype}); Net::DRI::Exception->die(1,$etype,9,'No action name <'.$oaction.'> defined for object of type <'.$otype.'> in '.ref($self)) unless exists($h->{$otype}->{$oaction}); return $h; } sub has_action { my ($self,$otype,$oaction)=@_; eval { my $h=$self->_load_commands($otype,$oaction); }; return ($@)? 0 : 1; } sub action { my $self=shift; my $otype=shift; my $oaction=shift; my $trid=shift; my $h=$self->_load_commands($otype,$oaction); ## Create a new message from scratch and loop through all functions registered for given action & type my $msg=$self->create_local_object('message',$trid,$otype,$oaction); Net::DRI::Exception->die(0,'protocol',1,'Unsuccessfull message creation') unless ($msg && ref($msg) && $msg->isa('Net::DRI::Protocol::Message')); $self->message($msg); ## store it for later use (in loop below) foreach my $t (@{$h->{$otype}->{$oaction}}) { my $pf=$t->[0]; next unless (defined($pf) && (ref($pf) eq 'CODE')); $pf->($self,@_); } $self->message(undef); ## needed ? useful ? return $msg; } sub reaction { my ($self,$otype,$oaction,$dr,$sent,$oname)=@_; my $h=$self->_load_commands($otype,$oaction); my $msg=$self->create_local_object('message'); Net::DRI::Exception->die(0,'protocol',1,'Unsuccessfull message creation') unless ($msg && ref($msg) && $msg->isa('Net::DRI::Protocol::Message')); my %info; ## TODO is $sent needed here really ? if not remove from API above also ! $msg->parse($dr,\%info,$otype,$oaction,$sent); ## will trigger an Exception by itself if problem ## TODO : add later the whole LocalStorage stuff done when sending ? (instead of otype/oaction/message sent) $self->message($msg); ## store it for later use (in loop below) $info{$otype}->{$oname}->{name}=$oname if ($otype eq 'domain' || $otype eq 'host'); foreach my $t (@{$h->{$otype}->{$oaction}}) { my $pf=$t->[1]; next unless (defined($pf) && (ref($pf) eq 'CODE')); $pf->($self,$otype,$oaction,$oname,\%info); } my $rc=$msg->result_status(); if (defined($rc)) { foreach my $v1 (values(%info)) { next unless (ref($v1) eq 'HASH' && keys(%$v1)); foreach my $v2 (values(%{$v1})) { next unless (ref($v2) eq 'HASH' && keys(%$v2)); ## yes, this can happen, with must_reconnect for example next if exists($v2->{result_status}); $v2->{result_status}=$rc; } } } $self->message(undef); ## needed ? useful ? return ($rc,\%info); } sub nameversion { my $self=shift; return $self->name().'/'.$self->version(); } sub factories { my ($self,$object,$code)=@_; if (defined $object && defined $code) { $self->{factories}->{$object}=$code; return $self; } return $self->{factories}; } sub capabilities { my ($self,$action,$object,$cap)=@_; if (defined($action) && defined($object)) { $self->{capabilities}->{$action}={} unless exists($self->{capabilities}->{$action}); if (defined($cap)) { $self->{capabilities}->{$action}->{$object}=$cap; } else { delete($self->{capabilities}->{$action}->{$object}); } } return $self->{capabilities}; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Shell.pm0000644000175000017500000015267411352534377016036 0ustar patrickpatrick## Domain Registry Interface, Shell interface ## ## Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Shell; use strict; use warnings; use Net::DRI; use Net::DRI::Util; use Net::DRI::Protocol::ResultStatus; use Term::ReadLine; ## see also Term::Shell use Time::HiRes (); use IO::Handle (); our $VERSION=do { my @r=(q$Revision: 1.10 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; exit __PACKAGE__->run(@ARGV) if (!caller() || caller() eq 'PAR'); ## This is a modulino :-) =pod =head1 NAME Net::DRI::Shell - Command Line Shell for Net::DRI, with batch features and autocompletion support =head1 SYNOPSYS perl -I../../ ./Shell.pm or perl -MNet::DRI::Shell -e 'Net::DRI::Shell->run()' or in your programs use Net::DRI::Shell; Net::DRI::Shell->run(); Welcome to Net::DRI shell, version 1.07 Net::DRI object created with a cache TTL of 10 seconds and logging into files in current directory NetDRI> add_registry registry=EURid clID=YOURLOGIN NetDRI(EURid)> add_current_profile name=profile1 type=epp defer=0 client_login=YOURLOGIN client_password=YOURPASSWORD Profile profile1 added successfully (1000/COMMAND_SUCCESSFUL) SUCCESS NetDRI(EURid,profile1)> domain_info example.eu Command completed successfully (1000/1000) SUCCESS NetDRI(EURid,profile1)> get_info_all ... all data related to the domain name queried ... NetDRI(EURid,profile1)> domain_check whatever.eu Command completed successfully (1000/1000) SUCCESS NetDRI(EURid,profile1)> get_info_all ... all data related to the domain name queried ... NetDRI(EURid,profile1)> show profiles EURid: profile1 NetDRI(EURid,profile1)> quit =head1 DESCRIPTION This is a shell to be able to use Net::DRI without writing any code. Most of the time commands are the name of methods to use on the Net::DRI object, with some extra ones and some variations in API to make passing parameters simpler. =head1 AVAILABLE COMMANDS After having started this shell, the available commands are the following. =head2 SESSION COMMANDS =head3 add_registry registry=REGISTRYNAME clID=YOURLOGIN Replace REGISTRYNAME with the Net::DRI::DRD module you want to use, and YOURLOGIN with your client login for this registry. =head3 add_current_profile name=profile1 type=epp defer=0 client_login=YOURLOGIN client_password=YOURPASSWORD This will really connect to the registry, replace YOURLOGIN by your client login at registry, and YOURPASSWORD by the associated password. You may have to add parameters remote_host= and remote_port= to connect to other endpoints than the hardcoded default which is most of the time the registry OT&E server, and not the production one ! =head3 add registry=REGISTRYNAME clID=YOURLOGIN name=profile1 type=epp defer=0 client_login=YOURLOGIN client_password=YOURPASSWORD This is a shortcut, doing the equivalent of add_registry, and then add_current_profile. =head3 get_info_all After each call to the registry, like domain_info or domain_check, this will list all available data retrieved from registry. Things are pretty-printed as much as possible. You should call get_info_all right after your domain_something call otherwise if you do another operation previous information is lost. This is done automatically for you on the relevant commands, but you can also use it manually at any time. =head3 show profiles Show the list of registries and associated profiles currently in use (opened in this shell with add_registry + add_current_profile, or add). =head3 show tlds Show the list of TLDs handled by the currently selected registry. =head3 show periods Show the list of allowed periods (domain name durations) for the currently selected registry. =head3 show objects Show the list of managed objects types at the currently selected registry. =head3 show types Show the list of profile types at the currently selected registry =head3 show status Show the list of available status for the currently selected registry, to use as status name in some commands below (domain_update_status_* domain_update host_update_status_* host_update contact_update_status_* contact_update). =head3 show config This will show all current config options. See C command below for the list of config options. =head3 set OPTION=VALUE The set command can be used to change some options inside the shell. The current list of available options is: =head4 verbose Set this option to 1 if you want a dump of all data retrieved from registry automatically after each operation, including failed ones, and including all displaying raw data exchanged with registry. =head3 target REGISTRYNAME PROFILENAME Switch to registry REGISTRYNAME (from currently available registries) and profile PROFILENAME (from currently available profiles in registry REGISTRYNAME). =head3 run FILENAME Will open the local FILENAME and read in it commands and execute all of them; you can also start your shell with a filename as argument and its commands will be run at beginning of session before giving the control back. They will be displayed (username and password will be masked) with their results. =head3 record FILENAME If called with a filename argument, all subsequent commands, and their results will be printed in the filename given. If called without argument, it stops a current recording session. =head3 !cmd All command line starting with a bang (!) will be treated as local commands to run through the local underlying OS shell. Example: !ls -l will display the content of the current directory. =head3 help Returns a succinct list of available commands. =head3 quit Leave the shell. =head2 DOMAIN COMMANDS =head3 domain_create DOMAIN [duration=X] [ns=HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...] [admin=SRID1] [registrant=SRID2] [billing=SRID3] [tech=SRID4] [auth=X] Create the given domain name. See above for the duration format to use. Admin, registrant, billing and tech contact ids are mandatory or optional depending on the registry. They may be repeated (except registrant) for registries allowing multiple contacts per role. =head3 domain_info DOMAIN Do a domain_info call to the registry for the domain YOURDOMAIN ; most of the the registries prohibit getting information on domain names you do not sponsor. =head3 domain_check DOMAIN Do a domain_check call to the registry for the domain ANYDOMAIN ; you can check any domain, existing or not, if you are the sponsoring registrar or not. =head3 domain_exist DOMAIN A kind of simpler domain_check, just reply by YES or NO for the given domain name. =head3 domain_transfer_start DOMAIN auth=AUTHCODE [duration=PERIOD] =head3 domain_transfer_stop DOMAIN [auth=AUTHCODE] =head3 domain_transfer_query DOMAIN [auth=AUTHCODE] =head3 domain_transfer_accept DOMAIN [auth=AUTHCODE] =head3 domain_transfer_refuse DOMAIN [auth=AUTHCODE] Start, or stop an incoming transfer, query status of a current running transfer, accept or refuse an outgoing domain name transfer. The AUTHCODE is mandatory or optional, depending on the registry. The duration is optional and can be specified (the allowed values depend on the registry) as Ayears or Bmonths where A and B are integers for the number of years or months (this can be abbreviated as Ay or Bm). =head3 domain_update_ns_set DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ... =head3 domain_update_ns_add DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ... =head3 domain_update_ns_del DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ... Set the current list of nameservers associated to this DOMAIN, add to the current list or delete from the current list. =head3 domain_update_status_set DOMAIN STATUS1 STATUS2 ... =head3 domain_update_status_add DOMAIN STATUS1 STATUS2 ... =head3 domain_update_status_del DOMAIN STATUS1 STATUS2 ... Set the current list of status associated to this DOMAIN, add to the current list or delete from the current list. First parameter is the domain name, then status names, as needed. The status names are those in the list given back by the show status command (see above). =head3 domain_update_contact_set DOMAIN SRVID1 SRVID2 ... =head3 domain_update_contact_add DOMAIN SRVID2 SRVID2 ... =head3 domain_update_contact_del DOMAIN SRVID1 SRVID2 ... Set the current list of contacts associated to this DOMAIN, add to the current list or delete from the current list by providing the contact server ids. =head3 domain_update DOMAIN +status=S1 -status=S2 +admin=C1 -tech=C2 -billing=C3 registrant=C4 auth=A +ns=... -ns=... Combination of the previous methods, plus ability to change authInfo and other parameters depending on registry. =head3 domain_renew DOMAIN [duration=X] [current_expiration=YYYY-MM-DD] Renew the given domain name. Duration and current expiration are optional. See above for the duration format to use. =head3 domain_delete DOMAIN Delete the given domain name. =head2 HOST COMMANDS For registries handling nameservers as separate objects. =head3 host_create HOSTNAME IP1 IP2 ... Create the host named HOSTNAME at the registry with the list of IP (IPv4 and IPv6 depending on registry support) given. =head3 host_delete HOSTNAME =head3 host_info HOSTNAME =head3 host_check HOSTNAME Various operations on host objects. =head3 host_update_ip_set HOSTNAME IP1 IP2 ... =head3 host_update_ip_add HOSTNAME IP1 IP2 ... =head3 host_update_ip_del HOSTNAME IP1 IP2 ... Set the current list of IP addresses associated to this HOSTNAME, add to the current list or delete from the current list. First parameter is the nameserver hostname, then IP addresses, as needed. =head3 host_update_status_set HOSTNAME STATUS1 STATUS2 ... =head3 host_update_status_add HOSTNAME STATUS1 STATUS2 ... =head3 host_update_status_del HOSTNAME STATUS1 STATUS2 ... Set the current list of status associated to this HOSTNAME, add to the current list or delete from the current list. First parameter is the nameserver hostname, then status names, as needed. The status names are those in the list given back by the show status command (see above). =head3 host_update HOSTNAME +ip=IP1 +ip=IP2 -ip=IP3 +status=STATUS1 -status=STATUS2 name=NEWNAME Combines the previous operations. =head3 host_update_name_set HOSTNAME NEWNAME Change the current name of host objects from HOSTNAME to NEWNAME. =head2 CONTACT COMMANDS For registries handling contacts as separate objects. =head3 contact_create name=X org=Y street=Z1 street=Z2 email=A voice=B ... Create a new contact object. The list of mandatory attributes depend on the registry. Some attributes (like street) may appear multiple times. Some registry allow setting an ID (using srid=yourchoice), others create the ID, in which case you need to do a get_info_all after contact_create to retrieve the given server ID. =head3 contact_delete SRID =head3 contact_info SRID =head3 contact_check SRID Various operations on contacts. =head3 contact_update_status_set SRID STATUS1 STATUS2 ... =head3 contact_update_status_add SRID STATUS1 STATUS2 ... =head3 contact_update_status_del SRID STATUS1 STATUS2 ... Set the current list of status associated to this contact SRID, add to the current list or delete from the current list. First parameter is the contact server ID, then status names, as needed. The status names are those in the list given back by the show status command (see above). =head3 contact_update SRID name=X org=Y ... +status=... -status=... Change some contacts attributes, as well as statuses. =head3 contact_transfer_start SRID =head3 contact_transfer_stop SRID =head3 contact_transfer_query SRID =head3 contact_transfer_accept SRID =head3 contact_transfer_refuse SRID Start, or stop an incoming transfer, query status of a current running transfer, accept or refuse an outgoing contact transfer. =head2 MESSAGE COMMANDS For registries handling messages, like EPP poll features. =head3 message_retrieve [ID] Retrieve a message waiting at registry. =head3 message_delete [ID] Delete a message waiting at registry. =head3 message_waiting Notifies if messages are waiting at registry. =head3 message_count Get the numbers of messages waiting at the registry. =head1 COMPLETION If Term::Readline::Gnu or Term::Readline::Perl are installed, it will be automatically used by this shell to provide standard shell autocompletion for commands and parameters. All commands described above will be available through autocompletion. As you use them, all parameters (domain names, contacts, hostnames, local files) will also be stored and provided to later autocompletion calls (with the [TAB] key). It will also autocomplete registry= and type= parameters during add/add_registry, from a basic default set of values: registry= values are taken from a basic Net::DRI install without taking into account any private DRD module, and type= values are a default set, not checked against registry= value. Same for target calls, where registry and/or profile name will be autocompleted as possible. It will even autocomplete TLD on domain names for your current registry after your typed the first label and a dot (and eventually some other characters), during any domain name operation. Same for durations and status values. Contacts and nameservers will also be autocompleted when used in any domain_* operation. Contacts attributes will be autocompleted during contact_create based on the current registry & profile. Information retrieved with domain_info calls will also be used in later autocompletion tries, regarding contact ids and hostnames. During a contact creation, the registry returned contact id is also added for later autocompletion tries. For autocompletion, contacts are specific to each registry. Hostnames are common to all registries, as are domain names, but domain names are checked against the available TLDs of the current registry when used for autocompletion. =head1 LOGGING By default, all operations will have some logging information done in files stored in the working directory. There will be a core.log file for all operations and then one file per tuple (registry,profile). =head1 BATCH OPERATIONS Batch operations are available for some domain name commands: domain_create, domain_delete, domain_renew, domain_check, domain_info, domain_transfer and all domain_update commands. It can be used on a list of domain names for which all other parameters needed by the command are the same. To do that, just use the command normally as outlined above, but instead of the domain name, put a file path, with at least one / (so for a file "batch.txt" in the current directory, use "./batch.txt"). If you use backticks such as `command` for the domain name, the command will be started locally and its output will be used just like a file. The shell will then apply the command and its parameters on the domain names listed in the specified file: you should have one domain name per line, blank lines and lines starting with # are ignored. At the same place a new file is created with a name derived from the given name in which the result of each domain name command will be written. If "input" is the filename used, the results will be written to "input.PID.TIME.results" where PID is the program id of the running shell for these commands and TIME the Unix epoch when the batch started. As output the shell will give a summary of the number of operations done for each possible outcome (success or error), as well as time statistics. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub run { my (@args)=@_; my $term=Term::ReadLine->new('Net::DRI shell'); my $ctx={ term => $term, term_features => $term->Features(), term_attribs => $term->Attribs(), dprompt => 'NetDRI', output => $term->OUT() || \*STDOUT, record_filename => undef, record_filehandle => undef, config => { verbose => 0 }, completion => { domains => {}, contacts => {}, hosts => {}, files => {} }, }; if (exists $ctx->{term_features}->{ornaments}) { $term->ornaments(1); } $ctx->{term_attribs}->{completion_function}=sub { return complete($ctx,@_); }; $ctx->{prompt}=$ctx->{dprompt}; output($ctx,"Welcome to Net::DRI shell, pid $$, version $VERSION\n"); $ctx->{dri}=Net::DRI->new({cache_ttl => 10,logging=>['files',{level => 'info'}]}); output($ctx,"Net::DRI object created with a cache TTL of 10 seconds and logging into files in current directory\n\n"); $ctx->{file_quit}=0; shift(@args) if ($args[0] eq 'Net::DRI::Shell'); handle_line($ctx,'run '.$args[0]) if (@args); unless ($ctx->{file_quit}) { delete($ctx->{file_quit}); while (defined(my $l=$ctx->{term}->readline($ctx->{prompt}.'> '))) { last if handle_line($ctx,$l); } } $ctx->{dri}->end(); return 0; ## TODO : should reflect true result of last command ? } sub output { my $ctx=shift; print { $ctx->{output} } @_; output_record($ctx,@_); } sub output_record { my $ctx=shift; return unless defined($ctx->{record_filehandle}); return if (@_==1 && ($_[0] eq '.' || $_[0] eq "\n")); my $l=$ctx->{last_line}; print { $ctx->{record_filehandle} } scalar(localtime(time)),"\n\n",(defined($l)? ($l,"\n\n") : ('')),@_,"\n\n"; $ctx->{last_line}=undef; } sub handle_file { my ($ctx,$file)=@_; output($ctx,'Executing commands from file '.$file." :\n"); $ctx->{completion}->{files}->{$file}=time(); open(my $ch,'<',$file) or die "Unable to open $file : $!"; while(defined(my $l=<$ch>)) { chomp($l); next if ($l=~m/^\s*$/ || $l=~m/^#/); my $pl=$l; $pl=~s/(clID|client_login|client_password)=\S+/$1=********/g; output($ctx,$pl."\n"); if (handle_line($ctx,$l)) { $ctx->{file_quit}=1; last; } } close($ch) or die $!; return; } sub handle_line { my ($ctx,$l)=@_; return 0 if ($l=~m/^\s*$/); $l=~s/^\s*//; $l=~s/\s*$//; return 1 if ($l eq 'quit' || $l eq 'q' || $l eq 'exit'); my ($rc,$msg); eval { ($rc,$msg)=process($ctx,$l); $msg.="\n".dump_info($ctx,scalar $rc->get_data_collection()) if (defined($rc) && (($l=~m/^(?:(?:domain|contact|host)_?(?:check|info|create)|domain_renew) / && (!defined($msg) || index($msg,'on average')==-1) && $rc->is_success()) || $ctx->{config}->{verbose}==1)); }; $ctx->{last_line}=$l; if ($@) { output($ctx,"An error happened:\n",ref($@)? $@->msg() : $@,"\n"); } else { my @r; if (defined($rc)) { push @r,$rc->as_string(1),"\n"; } push @r,$msg if (defined($msg)); if (defined($rc) && $rc->is_closing() && $ctx->{dri}->transport()->has_state()) { $ctx->{dri}->transport()->current_state(0); push @r,'Server connection closed, will try to reconnect during next command.'; ## TODO : this is triggered also for type=das, but shouldn't ! } output($ctx,@r,"\n"); } $ctx->{term}->addhistory($l); $ctx->{last_line}=undef; return 0; } sub complete { my ($ctx,$text,$line,$start)=@_; ## $text is last space separated word, $line the whole line, $start the position of the cursor in the line ## Command completion if ($start==0) ## command completion { return sort { $a cmp $b } grep { /^$text/ } qw/quit exit help run record message_retrieve message_delete domain_create domain_renew domain_delete domain_check domain_info domain_transfer_start domain_transfer_stop domain_transfer_query domain_transfer_accept domain_transfer_refuse domain_update_ns_set domain_update_ns_add domain_update_ns_del domain_update_status_set domain_update_status_add domain_update_status_del domain_update_contact_set domain_update_contact_add domain_update_contact_del domain_update host_create host_delete host_info host_check host_update_ip_set host_update_ip_add host_update_ip_del host_update_status_set host_update_status_add host_update_status_del host_update_name_set host_update contact_create contact_info contact_check contact_delete contact_update contact_update_status_set contact_update_status_add contact_update_status_del contact_transfer_start contact_transfer_stop contact_transfer_query contact_transfer_accept contact_transfer_refuse set add add_registry target add_current_profile add_profile show get_info get_info_all message_waiting message_count domain_exist/; } ## Parameter completion my ($cmd)=($line=~m/^(\S+)\s/); if ($cmd eq 'show') { return sort { $a cmp $b } grep { /^$text/ } qw/profiles tlds periods objects types status config/; } if ($cmd eq 'set') { return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } keys(%{$ctx->{config}}); } if ($cmd eq 'run' || $cmd eq 'record') { return sort { $ctx->{completion}->{files}->{$b} <=> $ctx->{completion}->{files}->{$a} || $a cmp $b } grep { /^$text/ } keys(%{$ctx->{completion}->{files}}); } if ($cmd eq 'add' || $cmd eq 'add_registry' || $cmd eq 'add_current_profile' || $cmd eq 'add_profile') { if (substr($line,$start-9,9) eq 'registry=') { my ($reg)=($text=~m/registry=(\S*)/); $reg||=''; return sort { $a cmp $b } grep { /^$reg/ } $ctx->{dri}->installed_registries(); } elsif (substr($line,$start-5,5) eq 'type=') { my ($type)=($text=~m/type=(\S*)/); $type||=''; return sort { $a cmp $b } grep { /^$type/ } (defined $ctx->{dri}->registry_name()? $ctx->{dri}->registry()->driver()->profile_types() : qw/epp rrp rri dchk whois das ws email/); } else { my @p; @p=qw/registry clID/ if $cmd eq 'add_registry'; @p=qw/type name/ if ($cmd=~m/^add_(?:current_)?profile$/); @p=qw/registry clID type name/ if $cmd eq 'add'; return map { $_.'=' } grep { /^$text/ } @p; } } if ($cmd eq 'target') { my $regs=$ctx->{dri}->available_registries_profiles(0); if (my ($reg)=($line=~m/^target\s+(\S+)\s+\S*$/)) { return sort { $a cmp $b } grep { /^$text/ } (exists $regs->{$reg} ? @{$regs->{$reg}} : ()); } elsif ($line=~m/^target\s+\S*$/) { return sort { $a cmp $b } grep { /^$text/ } keys(%$regs); } } if (substr($line,$start-9,9) eq 'duration=') { return () unless defined $ctx->{dri}->registry_name(); my ($p)=($text=~m/duration=(\S*)/); $p||=''; my %p; foreach my $pd ($ctx->{dri}->registry()->driver()->periods()) { my $d=$pd->in_units('years'); if ($d > 0) { $p{$d.'Y'}=12*$d; next; } $d=$pd->in_units('months'); if ($d > 0) { $p{$d.'M'}=$d; next; } } return sort { $p{$a} <=> $p{$b} } grep { /^$p/ } keys(%p); ## this is the correct ascending order, but it seems something else upstream is reordering it differently } if ($line=~m/^domain_\S+\s+\S*$/) { my @p=grep { /^$text/ } keys(%{$ctx->{completion}->{domains}}); if (defined $ctx->{dri}->registry()) { my @tlds=$ctx->{dri}->registry()->driver()->tlds(); my $tlds=join('|',map { quotemeta($_) } @tlds); @p=grep { /\.(?:$tlds)$/i } @p; my $idx=index($text,'.'); if ( $idx >= 0 ) { my $base=substr($text,0,$idx); push @p,map { $base.'.'.$_ } @tlds; } } return sort { ( $ctx->{completion}->{domains}->{$b} || 0) <=> ( $ctx->{completion}->{domains}->{$a} || 0 ) || $a cmp $b } @p; } my @ct=qw/registrant admin tech billing/; ## How to retrieve non core contact types ? my $capa; if ($ctx->{dri}->registry_name() && $ctx->{dri}->available_profile() && $ctx->{dri}->protocol()) { @ct=('registrant',$ctx->{dri}->protocol()->core_contact_types()) if $ctx->{dri}->protocol()->can('core_contact_types'); $capa=$ctx->{dri}->protocol()->capabilities(); } my $ctre=join('|',@ct); if ($cmd eq 'domain_create') ## If we are here, we are sure the domain name has been completed already, due to previous test block { if (substr($line,$start-3,3) eq 'ns=') { my ($ns)=($text=~m/ns=(\S*)/); $ns||=''; return _complete_hosts($ctx,$ns); } elsif (grep { substr($line,$start-(1+length($_)),1+length($_)) eq $_.'=' } @ct) { my ($c)=($text=~m/(?:${ctre})=(\S*)/); $c||=''; return _complete_contacts($ctx,$c); } else { return map { $_.'=' } grep { /^$text/ } (qw/duration ns auth/,@ct); } } if ($cmd eq 'domain_update') ## see previous comment { if (substr($line,$start-4,4)=~m/^[-+]ns=$/) { my ($ns)=($text=~m/ns=(\S*)/); $ns||=''; return _complete_hosts($ctx,$ns); } elsif (grep { substr($line,$start-(1+length($_)),1+length($_)) eq $_.'=' } @ct) ##### { my ($c)=($text=~m/(?:${ctre})=(\S*)/); $c||=''; return _complete_contacts($ctx,$c); } elsif (substr($line,$start-8,8)=~m/^[-+]status=$/) { my $o=$ctx->{dri}->local_object('status'); if (! defined $o) { return (); } my ($s)=($text=~m/status=(\S*)/); $s||=''; return sort { $a cmp $b } grep { /^$s/ } map { 'no'.$_ } $o->possible_no(); } else { $text=~s/\+/[+]/g; return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } (map { if (/^([+-])contact$/) { map { $1.$_ } @ct } else { $_; } } _complete_capa2list($capa,'domain_update')); } } if ($line=~m/^domain_update_ns_\S+\s+\S+\s+\S*/) { return _complete_hosts($ctx,$text); } if ($line=~m/^(?:domain|host|contact)_update_status_\S+\s+\S+\s+\S*/) { my $o=$ctx->{dri}->local_object('status'); if (! defined $o) { return (); } return sort { $a cmp $b } grep { /^$text/ } map { 'no'.$_ } $o->possible_no(); } if ($line=~m/^domain_update_contact_\S+\s+\S+\s+\S*/) { return _complete_contacts($ctx,$text); } if (my ($trans)=($line=~m/^domain_transfer_(\S+)\s+\S+\s+\S*/)) { my @p=qw/auth/; push @p,'duration' if $trans eq 'start'; return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } @p; } if ($cmd eq 'contact_create') { return () unless (defined $ctx->{dri}->registry_name() && defined $ctx->{dri}->profile()); my $c=$ctx->{dri}->local_object('contact'); if (! defined $c) { return (); } return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } $c->attributes(); } if ($line=~m/^contact_\S+\s+\S*$/) { return _complete_contacts($ctx,$text); } if ($cmd eq 'contact_update') { return () unless (defined $ctx->{dri}->registry_name() && defined $ctx->{dri}->profile()); my $c=$ctx->{dri}->local_object('contact'); $text=~s/\+/[+]/g; return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } (defined $c ? $c->attributes() : (),_complete_capa2list($capa,'contact_update')); } if ($line=~m/^host_\S+\s+\S*$/) { return _complete_hosts($ctx,$text); } if (my ($h)=($line=~m/^host_update_name_set\s+\S+\s+(\S*)$/)) { return _complete_hosts($ctx,$h); } if ($cmd eq 'host_update') { if (substr($line,$start-5,5) eq 'name=') { my ($ns)=($text=~m/name=(\S*)/); $ns||=''; return _complete_hosts($ctx,$ns); } elsif ( substr($line,$start-8,8)=~m/^[-+]status=$/ ) { my $o=$ctx->{dri}->local_object('status'); if (! defined $o) { return (); } my ($s)=($text=~m/status=(\S*)/); $s||=''; return sort { $a cmp $b } grep { /^$s/ } map { 'no'.$_ } $o->possible_no(); } else { $text=~s/\+/[+]/g; return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } (_complete_capa2list($capa,'host_update')); } } return (); } sub _complete_capa2list { my ($capa,$what)=@_; return () unless (defined $capa && exists($capa->{$what})); my @r; while(my ($k,$ra)=each(%{$capa->{$what}})) { foreach my $t (@$ra) { if ($t eq 'add') { push @r,'+'.$k; } elsif ($t eq 'del') { push @r,'-'.$k; } elsif ($t eq 'set') { push @r,$k; } } } return @r; } sub _complete_hosts { my ($ctx,$text)=@_; return sort { $ctx->{completion}->{hosts}->{$b} <=> $ctx->{completion}->{hosts}->{$a} || $a cmp $b } grep { /^$text/ } keys(%{$ctx->{completion}->{hosts}}); } sub _complete_contacts { my ($ctx,$text)=@_; my @c=grep { /^$text/ } keys(%{$ctx->{completion}->{contacts}}); my $creg=$ctx->{dri}->registry_name(); if (defined $creg) { @c=grep { defined $ctx->{completion}->{contacts}->{$_}->[1] && $ctx->{completion}->{contacts}->{$_}->[1] eq $creg } @c; } ## Filtering per registry return sort { $ctx->{completion}->{contacts}->{$b}->[0] <=> $ctx->{completion}->{contacts}->{$a}->[0] || $a cmp $b } @c; } sub process { my ($ctx,$wl)=@_; my ($rc,$m); my ($cmd,$params)=split(/\s+/,$wl,2); $params='' unless defined($params); my @p=split(/\s+/,$params); my %p; my @g=($params=~m/\s*(\S+)=(\S[^=]*)(?:\s|$)/g); while (@g) { my $n=shift(@g); my $v=shift(@g); if (exists($p{$n})) { $p{$n}=[$p{$n}] unless (ref($p{$n}) eq 'ARRAY'); push @{$p{$n}},$v; } else { $p{$n}=$v; } } foreach my $k (grep { /\./ } keys(%p)) { my ($tk,$sk)=split(/\./,$k,2); $p{$tk}={} unless exists($p{$tk}); $p{$tk}->{$sk}=$p{$k}; delete($p{$k}); } return do_local($ctx,$cmd,\@p,\%p) if ($cmd=~m/^!/); return help($ctx,$cmd,\@p,\%p) if ($cmd eq 'help'); return handle_file($ctx,$p[0]) if ($cmd eq 'run'); return record($ctx,$p[0]) if ($cmd eq 'record'); return do_dri($ctx,$cmd,\@p,\%p) if ($cmd=~m/^message_(?:retrieve|delete)$/); return do_domain($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_(?:check)$/); return do_domain_transfer($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_transfer_(?:start|stop|query|accept|refuse)$/); return do_domain_update($ctx,$cmd,\@p,\%p) if ($cmd eq 'domain_update'); return do_domain_update_ns($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_update_ns_(?:add|del|set)$/); return do_domain_update_status($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_update_status_(?:add|del|set)$/); return do_domain_update_contact($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_update_contact_(?:add|del|set)$/); if ($cmd eq 'domain_info') { my @r=do_domain($ctx,$cmd,\@p,\%p); if (defined $r[0] && $r[0]->is_success()) { my $ns=$ctx->{dri}->get_info('ns'); if (defined $ns) { foreach my $name ($ns->get_names()) { $ctx->{completion}->{hosts}->{$name}=time(); } } $ns=$ctx->{dri}->get_info('host'); if (defined $ns) { foreach my $name ($ns->get_names()) { $ctx->{completion}->{hosts}->{$name}=time(); } } my $cs=$ctx->{dri}->get_info('contact'); if (defined $cs) { foreach my $t ($cs->types()) { foreach my $cc ($cs->get($t)) { $ctx->{completion}->{contacts}->{$cc->srid()}=[time(),$ctx->{dri}->registry_name()]; } } } } return @r; } if ($cmd=~m/^host_(?:create|delete|info|check|update|update_(?:ip|status|name)_(?:add|del|set))$/) { return (undef,'Registry does not support host objects') unless $ctx->{dri}->has_object('ns'); return do_host($ctx,$cmd,\@p,\%p); } if ($cmd=~m/^contact_(?:create|delete|info|check|update|update_status_(?:add|del|set)|transfer_(?:start|stop|query|accept|refuse))$/) { return (undef,'Registry does not support contact objects') unless $ctx->{dri}->has_object('contact'); my @r=do_contact($ctx,$cmd,\@p,\%p); if ($cmd eq 'contact_create' && defined $r[0] && $r[0]->is_success()) { my $id=$ctx->{dri}->get_info('id'); if (defined $id) { $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()]; } } return @r; } { no strict 'refs'; ## no critic (ProhibitNoStrict) my $sub='do_'.$cmd; return $sub->($ctx,$cmd,\@p,\%p) if (exists(&$sub)); } ## Fallback for all domain extension commands return do_domain_extension($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_\S+/); return (undef,'Unknown command '.$cmd); } sub do_local { my ($ctx,$cmd,$ra,$rh)=@_; $cmd=~s/^!//; my $s=$cmd.' '.join(' ',@$ra); my $out=qx($s); return (undef,defined($out)? $out : 'Local command failed: '.$!); } sub help { my ($ctx,$cmd,$ra,$rh)=@_; my $m=<{record_filehandle})) { close($ctx->{record_filehandle}); $ctx->{record_filehandle}=undef; $m='Stopped recording session to '.$ctx->{record_filename}."\n"; } if (defined($n) && $n) { $ctx->{completion}->{files}->{$n}=time(); open(my $fh,'>',$n) or return (undef,$m.'Unable to write local file '.$n.' : '.$!); $fh->autoflush(1); ## this is thanks to IO::Handle $ctx->{record_filehandle}=$fh; $ctx->{record_filename}=$n; $m.='Started recording session to '.$ctx->{record_filename}; } return (undef,$m? $m : 'Usage: record FILENAME (to start recording session to local FILENAME) or record (to stop current recording)'); } ## For local options, like verbose sub do_set { my($ctx,$cmd,$ra,$rh)=@_; $ctx->{config}={ %{$ctx->{config}},%$rh }; return; } sub do_add { my($ctx,$cmd,$ra,$rh)=@_; return (undef,'Usage: add registry=REGISTRYNAME type=PROTOCOLTYPE [clID=LOGIN] [name=PROFILENAME] [...]') unless (Net::DRI::Util::has_key($rh,'registry') && Net::DRI::Util::has_key($rh,'type')); my %r=(registry => $rh->{registry}); $r{clID}=$rh->{clID} if exists($rh->{clID}); my @r=do_add_registry($ctx,'add_registry',$ra,\%r); if (! defined $r[0] || ! $r[0]->is_success()) { return @r; } unless (exists($rh->{name}) && defined($rh->{name})) { my @p=$ctx->{dri}->available_profiles(); $rh->{name}=lc($rh->{registry}).(1+@p); } delete($rh->{registry}); delete($rh->{clID}); return do_add_current_profile($ctx,'add_current_profile',$ra,$rh); } sub do_add_registry { my ($ctx,$cmd,$ra,$rh)=@_; return (undef,'Usage: add_registry registry=REGISTRYNAME [clID=LOGIN]') unless Net::DRI::Util::has_key($rh,'registry'); my $reg=$rh->{registry}; delete($rh->{registry}); if (! grep { $reg eq $_ } $ctx->{dri}->available_registries() ) { $ctx->{dri}->add_registry($reg,$rh); } $ctx->{dri}->target($reg); $ctx->{prompt}=$ctx->{dprompt}.'('.$reg.')'; return (Net::DRI::Protocol::ResultStatus->new_generic_success('Registry "'.$reg.'" added successfully'),undef); } sub do_target { my ($ctx,$cmd,$ra,$rh)=@_; $ctx->{dri}->target(@$ra); $ctx->{prompt}=$ctx->{dprompt}.'('.join(',',@$ra).')'; return; } sub do_add_current_profile { my ($ctx,$cmd,$ra,$rh)=@_; return (undef,'Usage: add_current_profile name=PROFILENAME type=SERVICENAME [defer=0] [client_login=YOURLOGIN] [client_password=YOURPASSWORD]') unless (Net::DRI::Util::has_key($rh,'name') && Net::DRI::Util::has_key($rh,'type')); my $name=$rh->{name}; my $type=$rh->{type}; my $rp=defined $rh->{protocol}? $rh->{protocol} : {}; delete(@{$rh}{qw/name type protocol/}); my $rc=$ctx->{dri}->$cmd($name,$type,$rh,$rp); if ($rc->is_success() && $cmd eq 'add_current_profile') { my @t=$ctx->{dri}->registry(); $ctx->{prompt}=$ctx->{dprompt}.'('.$t[0].','.$t[1]->profile().')'; } return ($rc,undef); } sub do_add_profile { return do_add_current_profile(@_); } sub do_show { my ($ctx,$cmd,$ra,$rh)=@_; my $m='Usage: show profiles|tlds|periods|objects|types|status|config'; return (undef,$m) unless @$ra; if ($ra->[0] eq 'profiles') { my $rp=$ctx->{dri}->available_registries_profiles(1); $m=''; foreach my $reg (sort(keys(%$rp))) { $m.=$reg.': '.join(' ',@{$rp->{$reg}})."\n"; } } elsif ($ra->[0] eq 'tlds') { $m=join("\n",$ctx->{dri}->registry()->driver()->tlds()); } elsif ($ra->[0] eq 'periods' || $ra->[0] eq 'durations') { $m=join("\n",map { pretty_string($_,0); } $ctx->{dri}->registry()->driver()->periods()); } elsif ($ra->[0] eq 'objects') { $m=join("\n",$ctx->{dri}->registry()->driver()->object_types()); } elsif ($ra->[0] eq 'types') { $m=join("\n",$ctx->{dri}->registry()->driver()->profile_types()); } elsif ($ra->[0] eq 'status') { my $o=$ctx->{dri}->local_object('status'); $m=defined($o)? join("\n",map { 'no'.$_ } $o->possible_no()) : 'No status objects'; } elsif ($ra->[0] eq 'config') { $m=''; foreach my $k (sort(keys(%{$ctx->{config}}))) { $m.=$k.'='.$ctx->{config}->{$k}."\n"; } } return (undef,$m); } sub do_get_info { my ($ctx,$cmd,$ra,$rh)=@_; my $m=$ctx->{dri}->get_info(@$ra); return (undef,pretty_string($m,0)); } sub do_get_info_all { my ($ctx,$cmd,$ra,$rh)=@_; my $rp=$ctx->{dri}->get_info_all(@$ra); my $m=''; foreach my $k (sort(keys(%$rp))) { $m.=$k.': '.pretty_string($rp->{$k},0)."\n"; } return (undef,$m); } sub do_dri { my ($ctx,$cmd,$ra,$rh)=@_; return ($ctx->{dri}->$cmd(@$ra),undef); } sub do_message_waiting { my ($ctx,$cmd,$ra,$rh)=@_; my $e=$ctx->{dri}->$cmd(@$ra); return (undef,'Unable to find if messages are waiting at the registry') unless defined($e); return (undef,'Messages waiting at the registry? '.($e? 'YES' : 'NO')); } sub do_message_count { my ($ctx,$cmd,$ra,$rh)=@_; my $e=$ctx->{dri}->$cmd(@$ra); return (undef,'Unable to find the number of messages waiting at the registry') unless defined($e); return (undef,'Number of messages waiting at the registry: '.$e); } ## Try to handle all domain commands defined in extensions, with some heuristics sub do_domain_extension { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); build_auth($rh); build_duration($ctx,$rh); $rh->{status}=build_status($ctx,ref $rh->{status}? $rh->{status} : [ $rh->{status} ] ) if exists($rh->{status}); $rh->{contact}=build_contactset($ctx,$rh->{contact}) if (exists $rh->{contact}); return wrap_command_domain($ctx,$cmd,$dom,$rh); } sub do_domain { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); return wrap_command_domain($ctx,$cmd,$dom,$rh); } sub do_domain_exist { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=lc($ra->[0]); $ctx->{completion}->{domains}->{$dom}=time(); my $e=$ctx->{dri}->$cmd($dom); return (undef,'Unable to find if domain name '.$dom.' exists') unless defined($e); return (undef,'Does domain name '.$dom.' exists at registry? '.($e? 'YES' : 'NO')); } sub do_domain_transfer { my ($ctx,$cmd,$ra,$rh)=@_; build_auth($rh); build_duration($ctx,$rh); $rh->{contact}=build_contactset($ctx,$rh->{contact}) if exists $rh->{contact}; ## Some registries need contacts during transfer, this is not core EPP, but it does not create drawbacks, so we support it here return wrap_command_domain($ctx,$cmd,$ra->[0],$rh); } sub do_domain_update { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); my $toc=$ctx->{dri}->local_object('changes'); my ($radd,$rdel,$rset)=build_update($ctx,$rh); foreach my $k (keys %$radd) { $toc->add($k,$radd->{$k}); } foreach my $k (keys %$rdel) { $toc->del($k,$rdel->{$k}); } foreach my $k (keys %$rset) { $toc->set($k,$rset->{$k}); } return wrap_command_domain($ctx,$cmd,$dom,$toc); } sub do_domain_update_ns { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); my $ns=build_hosts($ctx,$ra); return wrap_command_domain($ctx,$cmd,$dom,$ns); } sub do_domain_update_status { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); my $s=build_status($ctx,$ra); return wrap_command_domain($ctx,$cmd,$dom,$s); } sub do_domain_update_contact { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); my $cs=$ctx->{dri}->local_object('contactset'); while(my ($type,$ids)=each(%$rh)) { foreach my $id (ref($ids)? @$ids : ($ids)) { $cs->add($ctx->{dri}->local_object('contact')->srid($id),$type); $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()]; } } return wrap_command_domain($ctx,$cmd,$dom,$cs); } sub do_domain_create { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); build_duration($ctx,$rh); build_auth($rh); $rh->{ns}=build_hosts($ctx,[split(/\s+/,ref $rh->{ns} ? join(' ',@{$rh->{ns}}) : $rh->{ns})]) if exists($rh->{ns}); my @ct=qw/registrant admin tech billing/; ## How to retrieve non core contact types ? @ct=('registrant',$ctx->{dri}->protocol()->core_contact_types()) if ($ctx->{dri}->protocol() && $ctx->{dri}->protocol()->can('core_contact_types')); my %c; foreach my $t (@ct) { next unless exists $rh->{$t}; $c{$t}=$rh->{$t}; delete $rh->{$t} ; } $rh->{contact}=build_contactset($ctx,\%c) if (%c); $rh->{pure_create}=1; return wrap_command_domain($ctx,$cmd,$dom,$rh); } sub do_domain_renew { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); build_duration($ctx,$rh); if (exists($rh->{current_expiration})) { my @t=split(/-/,$rh->{current_expiration}); $rh->{current_expiration}=$ctx->{dri}->local_object('datetime','year' => $t[0], 'month' => $t[1], 'day' => $t[2]); } return wrap_command_domain($ctx,$cmd,$dom,$rh); } sub do_domain_delete { my ($ctx,$cmd,$ra,$rh)=@_; my $dom=shift(@$ra); $rh->{pure_delete}=1; return wrap_command_domain($ctx,$cmd,$dom,$rh); } sub do_host { my ($ctx,$cmd,$ra,$rh)=@_; my @p; if ($cmd eq 'host_create') { @p=build_hosts($ctx,$ra); } elsif ($cmd=~m/^host_update_ip_(?:add|del|set)$/) { my $h=shift(@$ra); @p=($h,build_hosts($ctx,[ $h, @$ra ])); } elsif ($cmd=~m/^host_update_status_(?:add|del|set)$/) { my $h=shift(@$ra); @p=($h,build_status($ctx,$ra)); } elsif ($cmd eq 'host_update') { my $h=shift(@$ra); my $toc=$ctx->{dri}->local_object('changes'); my ($radd,$rdel,$rset)=build_update($ctx,$rh); if (keys %$radd) { foreach my $k (keys %$radd) { if ($k eq 'ip') { $radd->{$k}=build_hosts($ctx,[$h,ref $radd->{$k} ? @{$radd->{$k}} : ($radd->{$k})]); } $toc->add($k,$radd->{$k}); } } if (keys %$rdel) { foreach my $k (keys %$rdel) { if ($k eq 'ip') { $rdel->{$k}=build_hosts($ctx,[$h,ref $rdel->{$k} ? @{$rdel->{$k}} : ($rdel->{$k})]); } $toc->del($k,$rdel->{$k}); } } if (keys %$rset) { foreach my $k (keys %$rset) { $toc->set($k,$rset->{$k}); } } $ctx->{completion}->{hosts}->{$rset->{'name'}}=time() if exists $rset->{'name'}; @p=($h,$toc); } else { @p=@$ra; } $ctx->{completion}->{hosts}->{$p[0]}=time(); $ctx->{completion}->{hosts}->{$p[1]}=time() if $cmd eq 'host_update_name_set'; return ($ctx->{dri}->$cmd(@p),undef); } sub do_contact { my ($ctx,$cmd,$ra,$rh)=@_; my @p; my $c=$ctx->{dri}->local_object('contact'); build_auth($rh); if ($cmd eq 'contact_create') { $rh->{street}=[$rh->{street}] if (exists($rh->{street}) && !ref($rh->{street})); $rh->{srid}=$rh->{id} if (exists($rh->{id}) && ! exists($rh->{srid})); $rh->{srid}=$ra->[0] if (@$ra && $ra->[0]!~m/=/ && ! exists $rh->{srid}); build_contact($ctx,$c,$rh); } elsif ($cmd=~m/^contact_update_status_(?:add|del|set)$/) { my $id=shift(@$ra); $c->srid($id); $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()]; @p=(build_status($ctx,$ra)); } elsif ($cmd eq 'contact_update') { my $id=shift(@$ra); $c->srid($id); $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()]; my ($radd,$rdel,$rset)=build_update($ctx,$rh); my $toc=$ctx->{dri}->local_object('changes'); if (keys %$rset) { my $c2=$ctx->{dri}->local_object('contact'); build_contact($ctx,$c2,$rset); $toc->set('info',$c2); } if (keys %$radd) { foreach my $k (keys %$radd) { $toc->add($k,$radd->{$k}); } } if (keys %$rdel) { foreach my $k (keys %$rdel) { $toc->del($k,$rdel->{$k}); } } @p=($toc); } else { my $id=shift(@$ra); $c->srid($id); $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()]; @p=@$ra; } return ($ctx->{dri}->$cmd($c,@p),undef); } #################################################################################################### sub wrap_command_domain { my $ctx=shift; my $cmd=shift; my $dom=shift; return (undef,'Undefined domain name') unless (defined($dom) && $dom); my ($fin,$fout,$res); if ($dom=~m!/!) ## Local file { return (undef,'Local file '.$dom.' does not exist or unreadable') unless (-e $dom && -r _); $res=$dom.'.'.$$.'.'.time().'.results'; ## TODO choose a predictable filename ? if so, use an option open($fin,'<',$dom) or return (undef,'Unable to read local file '.$dom.' : '.$!); open($fout,'>',$res) or return (undef,'Unable to write (for results) local file '.$res.' : '.$!); } elsif ($dom=~m/`.+`/) ## Local executable { $dom=~s/`(.+)`/$1/; $res=$cmd.'.'.$$.'.'.time().'.results'; ## see above open($fin,'-|',$dom) or return (undef,'Unable to execute local command '.$dom.' : '.$!); open($fout,'>',$res) or return (undef,'Unable to write (for results) local file '.$res.' : '.$!); } unless (defined($fin) && defined($fout)) ## Pure unique domain name { $ctx->{completion}->{domains}->{$dom}=time(); return (undef,'Invalid domain name: '.$dom) unless Net::DRI::Util::is_hostname($dom); return ($ctx->{dri}->$cmd(lc($dom),@_),undef); } my $withinfo=($cmd eq 'domain_check' || $cmd eq 'domain_info')? 1 : 0; my @rc; my $tstart=Time::HiRes::time(); while(defined(my $l=<$fin>)) { chomp($l); my @r=($l); $ctx->{completion}->{domains}->{$l}=time(); if (Net::DRI::Util::is_hostname($l)) { my $rc=$ctx->{dri}->$cmd(lc($l),@_); push @r,$rc->as_string(1); push @r,$ctx->{dri}->get_info_all() if $withinfo; } else { push @r,'Invalid domain name'; } push @rc,\@r; output($ctx,'.'); } my $tstop=Time::HiRes::time(); output($ctx,"\n"); close($fin); my %r; ## We write the whole file at the end for better performances (but we opened it right at the beginning to test its writability) foreach my $rc (@rc) { my $l=shift(@$rc); my $rcm=shift(@$rc); $rcm=~s/\n/ /g; if ($cmd eq 'domain_check') { my $rh=shift(@$rc); $rcm.=' | exist='.(defined $rh->{exist} ? $rh->{exist} : '?').' exist_reason='.(defined $rh->{exist_reason} ? $rh->{exist_reason} : ''); ## exist should always be defined ! } elsif ($cmd eq 'domain_info') { my $rh=shift(@$rc); $rcm.=' | '.join(' ',map { $_.'=['.pretty_string($rh->{$_},0).']' } qw/clID crDate exDate contact ns status auth/); if (exists $rh->{ns}) { foreach my $nsname ($rh->{ns}->get_names()) { $ctx->{completion}->{hosts}->{$nsname}=time(); } } if (exists $rh->{contact}) { foreach my $cid ($rh->{contact}->get_all()) { $ctx->{completion}->{contacts}->{$cid}=[time(),$ctx->{dri}->registry_name()]; } } } print { $fout } $l,' ',$rcm,"\n"; $r{$rcm}++; } close($fout); my $t=@rc; my $m=join("\n",map { sprintf('%d/%d (%.02f%%) : %s',$r{$_},$t,100*$r{$_}/$t,$_) } sort { $a cmp $b } keys(%r)); $m.="\n".sprintf('%d operations in %d seconds, on average %.2f op/s = %.3f s/op',$t,$tstop-$tstart,$t/($tstop-$tstart),($tstop-$tstart)/$t); ## Warning, substring "on average" is used in handle_line(), do not change it $m.="\nResults in local file: $res"; return (undef,$m); } #################################################################################################### sub build_contactset { my ($ctx,$rh)=@_; my $cs=$ctx->{dri}->local_object('contactset'); while(my ($t,$ids)=each(%$rh)) { foreach my $c (ref($ids)? @{$ids} : ($ids)) { $cs->add($ctx->{dri}->local_object('contact')->srid($c),$t); $ctx->{completion}->{contacts}->{$c}=[time(),$ctx->{dri}->registry_name()]; } } return $cs; } sub build_contact { my ($ctx,$c,$rh)=@_; no strict 'refs'; ## no critic (ProhibitNoStrict) while(my ($m,$v)=each(%$rh)) { $c->$m($v); } if (exists $rh->{srid}) { $ctx->{completion}->{contacts}->{$rh->{srid}}=[time(),$ctx->{dri}->registry_name()]; } if (exists $rh->{id}) { $ctx->{completion}->{contacts}->{$rh->{id}} =[time(),$ctx->{dri}->registry_name()]; } return $c; } sub build_status { my ($ctx,$ra)=@_; my $s=$ctx->{dri}->local_object('status'); foreach (@$ra) { s/^no//; $s->no($_); } return $s; } sub build_hosts { my ($ctx,$ra)=@_; my $ns=$ctx->{dri}->local_object('hosts'); my $i=-1; my @r; foreach my $o (@$ra) { $r[++$i]=[] if ($o=~m/[a-z]/i); ## new hostname (safe since at least the TLD is not numeric) push @{$r[$i]},$o if $i >= 0; ## the test here makes us skip IP addresses at beginning before first name (a situation that should not happen anyway) } foreach my $rns (@r) { my $name=shift(@$rns); $ns->add($name,$rns); $ctx->{completion}->{hosts}->{$name}=time(); } return $ns; } sub build_auth { my $rd=shift; return unless (exists($rd->{auth}) && ! ref($rd->{auth})); $rd->{auth}={ pw => $rd->{auth} }; } sub build_duration { my ($ctx,$rd)=@_; return unless exists($rd->{duration}); my ($v,$u)=($rd->{duration}=~m/^(\d+)(\S+)$/); $rd->{duration}=$ctx->{dri}->local_object('duration','years' => $v) if ($u=~m/^y(?:ears?)?$/i); $rd->{duration}=$ctx->{dri}->local_object('duration','months' => $v) if ($u=~m/^m(?:onths?)?$/i); } sub build_update { my ($ctx,$rd)=@_; my (%a,%r); ## Some normalizations foreach my $k (grep { /^[+-]?status$/ } keys(%$rd)) { $rd->{$k}=build_status($ctx,ref $rd->{$k} ? $rd->{$k} : [ $rd->{$k} ]); } foreach my $k (grep { /^[+-]?ns$/ } keys(%$rd)) { $rd->{$k}=build_hosts($ctx,[ map { split(/\s+/,$_) } ref $rd->{$k} ? @{$rd->{$k}} : ($rd->{$k})]); } build_auth($rd); my @ct=qw/admin tech billing/; ## How to retrieve non core contact types ? @ct=$ctx->{dri}->protocol()->core_contact_types() if ($ctx->{dri}->protocol() && $ctx->{dri}->protocol()->can('core_contact_types')); my $ctr=join('|',@ct); foreach my $op (qw/+ -/) { my %c; foreach my $k (grep { /^[${op}](?:${ctr})$/ } keys(%$rd) ) { $c{substr($k,1)}=$rd->{$k}; delete($rd->{$k}); } next unless %c; $rd->{$op.'contact'}=build_contactset($ctx,\%c); } $rd->{registrant}=build_contact($ctx,$ctx->{dri}->local_object('contact'),{srid => $rd->{registrant}}) if exists $rd->{registrant}; ## Now split in two hashes foreach my $k (grep { /^\+/ } keys(%$rd)) { $a{substr($k,1)}=$rd->{$k}; delete($rd->{$k}); } foreach my $k (grep { /^-/ } keys(%$rd)) { $r{substr($k,1)}=$rd->{$k}; delete($rd->{$k}); } return (\%a,\%r,$rd); } sub pretty_string { my ($v,$full)=@_; $full||=0; unless(ref($v)) { return '' unless defined($v); $v=~s/\s*$//; return $v unless ($v=~m/^<\?xml /); my $vi=Net::DRI::Util::xml_indent($v); $vi=~s/\n/\n\t\t/g; return $vi; } return join(' ',@$v) if (ref($v) eq 'ARRAY'); return join(' ',map { $_.'='.$v->{$_} } keys(%$v)) if (ref($v) eq 'HASH'); return ($full? "Ns:\n": '').$v->as_string(1) if ($v->isa('Net::DRI::Data::Hosts')); return ($full? "Contact:\n" : '').$v->as_string() if ($v->isa('Net::DRI::Data::Contact')); if ($v->isa('Net::DRI::Data::ContactSet')) { my @v; foreach my $t ($v->types()) { push @v,$t.'='.join(',',map { pretty_string($_,$full) } $v->get($t)); } return ($full? "ContactSet:\n" : '').join(' ',@v); } return ($full? "Status:\n" : '').join(' ',$v->list_status()) if ($v->isa('Net::DRI::Data::StatusList')); return ($full? "Command result:\n" : '').$v->as_string(1) if ($v->isa('Net::DRI::Protocol::ResultStatus')); return ($full? "Date:\n" : '').$v->set_time_zone('UTC')->strftime('%Y-%m-%d %T').' UTC' if ($v->isa('DateTime')); return ($full? "Duration:\n" : '').sprintf('P%dY%dM%dDT%dH%dM%dS',$v->in_units(qw/years months days hours minutes seconds/)) if ($v->isa('DateTime::Duration')); ## ISO8601 return $v; } sub dump_info { my ($ctx,$rh)=@_; my @r; foreach my $k1 (sort(keys(%$rh))) { foreach my $k2 (sort(keys(%{$rh->{$k1}}))) { next if ($k1 eq 'session' && $k2 eq 'exchange' && $ctx->{config}->{verbose}==0); push @r,$k1.','.$k2; foreach my $k3 (sort(keys(%{$rh->{$k1}->{$k2}}))) { push @r,"\t".$k3.': '.pretty_string($rh->{$k1}->{$k2}->{$k3},0); } push @r,''; } } return join("\n",@r); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Exception.pm0000644000175000017500000001116711352534377016714 0ustar patrickpatrick## Domain Registry Interface, Encapsulatng errors (fatal or not) as exceptions in an OO way ## ## Copyright (c) 2005,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Exception; use strict; use Carp; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Exception - Class to store all exceptions inside Net::DRI =head1 SYNOPSIS my $s=Net::DRI::Exception->new(0,'area',500,'message'); die($s); ## OR Net::DRI::Exception->die(0,'area',500,'message'); $s->is_error(); ## gives 0 or 1, first argument of new/die ## (internal error that should not happen are 1, others are 0) $s->area(); ## gives back the area (second argument of new/die) $s->code(); ## gives back the code (third argument of new/die) $s->msg(); ## gives back the message (fourth argument of new/die) $s->as_string(); ## gives back a nicely formatted full backtrace =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $proto=shift; my $class=ref($proto) || $proto; my ($error,$area,$code,$msg)=@_; my $self={ is_error => (defined($error)? $error : 1 ), area => $area || '?', code => $code || 0, msg => $msg || '', }; $self->{bt}=Carp::longmess(); bless($self,$class); return $self; } sub die { die(new(@_)); } sub is_error { return shift->{is_error}; } sub area { return shift->{area}; } sub code { return shift->{code}; } sub msg { return shift->{msg}; } sub backtrace { my $self=shift; my $m=$self->{bt}; my (@bt1,@bt2); foreach (split(/\n/,$m)) { if (/^\s*Net::DRI::(?:BaseClass|Exception)::/) { push @bt1,$_; } else { push @bt2,$_; } } shift(@bt2) if ($bt2[0]=~m!Net/DRI/BaseClass!); shift(@bt2) if ($bt2[0]=~m!Net/DRI/Exception!); my ($f,$l); if (@bt1) { ($f,$l)=(pop(@bt1)=~m/ called at (\S+) line (\d+)\s*$/); } else { ($f,$l)=(shift(@bt2)=~m/ at (\S+) line (\d+)\s*$/); } my @b; push @b,sprintf('EXCEPTION %d@%s from line %d of file %s:',$self->code(),$self->area(),$l,$f); push @b,$self->msg(); return (@b,@bt2); } ## Do not parse result of this call. If needed, use accessors above (is_error(), area(), code(), msg()) sub as_string { my $self=shift; return join("\n",$self->backtrace())."\n"; } sub print { print shift->as_string(); } #################################################################################################### sub err_failed_load_module { my ($w,$m,$e)=@_; Net::DRI::Exception->die(1,$w,8,'Failed to load Perl module '.$m.' : '.(ref($e)? $e->as_string() : $e)); } sub err_method_not_implemented { Net::DRI::Exception->die(1,'internal',1,'Method not implemented'.($_[0]? ': '.$_[0] : '')); } sub err_insufficient_parameters { Net::DRI::Exception->die(1,'internal',2,'Insufficient parameters'.($_[0]? ': '.$_[0] : '')); } sub err_invalid_parameters { Net::DRI::Exception->die(1,'internal',3,'Invalid parameters'.($_[0]? ': '.$_[0] : '')); } sub usererr_insufficient_parameters { Net::DRI::Exception->die(0,'internal',2,'Insufficient parameters'.($_[0]? ': '.$_[0] : '')); } sub usererr_invalid_parameters { Net::DRI::Exception->die(0,'internal',3,'Invalid parameters'.($_[0]? ': '.$_[0] : '')); } sub err_assert { Net::DRI::Exception->die(1,'internal',4,'Assert failed'.($_[0]? ': '.$_[0] : '')); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Util.pm0000644000175000017500000004002411352534377015665 0ustar patrickpatrick## Domain Registry Interface, Misc. useful functions ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Util; use strict; use warnings; use Time::HiRes (); use Encode (); use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.20 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Util - Various useful functions for Net::DRI operations =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### our %CCA2=map { $_ => 1 } qw/AF AX AL DZ AS AD AO AI AQ AG AR AM AW AU AT AZ BS BH BD BB BY BE BZ BJ BM BT BO BA BW BV BR IO BN BG BF BI KH CM CA CV KY CF TD CL CN CX CC CO KM CG CD CK CR CI HR CU CY CZ DK DJ DM DO EC EG SV GQ ER EE ET FK FO FJ FI FR GF PF TF GA GM GE DE GH GI GR GL GD GP GU GT GG GN GW GY HT HM HN HK HU IS IN ID IR IQ IE IM IL IT JM JP JE JO KZ KE KI KP KR KW KG LA LV LB LS LR LY LI LT LU MO MK MG MW MY MV ML MT MH MQ MR MU YT MX FM MD MC MN MS MA MZ MM NA NR NP NL AN NC NZ NI NE NG NU NF MP NO OM PK PW PS PA PG PY PE PH PN PL PT PR QA RE RO RU RW SH KN LC PM VC WS SM ST SA SN CS SC SL SG SK SI SB SO ZA GS ES LK SD SR SJ SZ SE CH SY TW TJ TZ TH TL TG TK TO TT TN TR TM TC TV UG UA AE GB US UM UY UZ VU VA VE VN VG VI WF EH YE ZM ZW/; sub all_valid { foreach (@_) { return 0 unless (defined($_) && (ref($_) || length($_))); } return 1; } sub hash_merge { my ($rmaster,$rtoadd)=@_; while(my ($k,$v)=each(%$rtoadd)) { $rmaster->{$k}={} unless exists($rmaster->{$k}); while(my ($kk,$vv)=each(%$v)) { $rmaster->{$k}->{$kk}=[] unless exists($rmaster->{$k}->{$kk}); my @t=@$vv; push @{$rmaster->{$k}->{$kk}},\@t; } } } sub deepcopy { my $in=shift; return $in unless defined $in; my $ref=ref $in; return $in unless $ref; my $cname; ($cname,$ref)=($1,$2) if ("$in"=~m/^(\S+)=([A-Z]+)\(0x/); if ($ref eq 'SCALAR') { my $tmp=$$in; return \$tmp; } elsif ($ref eq 'HASH') { my $r={ map { $_ => (defined $in->{$_} && ref $in->{$_}) ? deepcopy($in->{$_}) : $in->{$_} } keys(%$in) }; bless($r,$cname) if defined $cname; return $r; } elsif ($ref eq 'ARRAY') { return [ map { (defined $_ && ref $_)? deepcopy($_) : $_ } @$in ]; } else { Net::DRI::Exception::usererr_invalid_parameters('Do not know how to deepcopy '.$in); } } #################################################################################################### sub isint { my $in=shift; return ($in=~m/^\d+$/)? 1 : 0; } sub check_equal { my ($input,$ra,$default)=@_; return $default unless defined($input); foreach my $a (ref($ra)? @$ra : ($ra)) { return $a if ($a=~m/^${input}$/); } return $default if $default; return; } sub check_isa { my ($what,$isa)=@_; Net::DRI::Exception::usererr_invalid_parameters((${what} || 'parameter').' must be a '.$isa.' object') unless ($what && UNIVERSAL::isa($what,$isa)); return 1; } sub isa_contactset { my $cs=shift; return (defined($cs) && UNIVERSAL::isa($cs, 'Net::DRI::Data::ContactSet') && !$cs->is_empty())? 1 : 0; } sub isa_contact { my ($c,$class)=@_; $class='Net::DRI::Data::Contact' unless defined($class); return (defined($c) && UNIVERSAL::isa($c,$class))? 1 : 0; ## no way to check if it is empty or not ? Contact->validate() is too strong as it may die, Contact->roid() maybe not ok always } sub isa_hosts { my ($h,$emptyok)=@_; $emptyok||=0; return (defined($h) && UNIVERSAL::isa($h, 'Net::DRI::Data::Hosts') && ($emptyok || !$h->is_empty()) )? 1 : 0; } sub isa_nsgroup { my $h=shift; return (defined($h) && UNIVERSAL::isa($h, 'Net::DRI::Data::Hosts'))? 1 : 0; } sub isa_changes { my $c=shift; return (defined($c) && UNIVERSAL::isa($c, 'Net::DRI::Data::Changes') && !$c->is_empty())? 1 : 0; } sub isa_statuslist { my $s=shift; return (defined($s) && UNIVERSAL::isa($s,'Net::DRI::Data::StatusList') && !$s->is_empty())? 1 : 0; } sub has_key { my ($rh,$key)=@_; return 0 unless (defined($key) && $key); return 0 unless (defined($rh) && (ref($rh) eq 'HASH') && exists($rh->{$key}) && defined($rh->{$key})); return 1; } sub has_contact { my $rh=shift; return has_key($rh,'contact') && isa_contactset($rh->{contact}); } sub has_ns { my $rh=shift; return has_key($rh,'ns') && isa_hosts($rh->{ns}); } sub has_duration { my $rh=shift; return has_key($rh,'duration') && check_isa($rh->{'duration'},'DateTime::Duration'); ## check_isa throws an Exception if not } sub has_auth { my $rh=shift; return (has_key($rh,'auth') && (ref($rh->{'auth'}) eq 'HASH'))? 1 : 0; } #################################################################################################### sub microtime { my ($t,$v)=Time::HiRes::gettimeofday(); return $t.sprintf('%06d',$v); } sub fulltime { my ($t,$v)=Time::HiRes::gettimeofday(); my @t=localtime($t); return sprintf('%d-%02d-%02d %02d:%02d:%02d.%06d',1900+$t[5],1+$t[4],$t[3],$t[2],$t[1],$t[0],$v); } ## From EPP, trID=token from 3 to 64 characters sub create_trid_1 { my ($name)=@_; my $mt=microtime(); ## length=16 return uc($name).'-'.$$.'-'.$mt; } #################################################################################################### sub is_hostname ## RFC952/1123 { my ($name)=@_; return 0 unless defined($name); my @d=split(/\./,$name,-1); foreach my $d (@d) { return 0 unless (defined($d) && ($d ne '')); return 0 unless (length($d)<=63); return 0 if (($d=~m/[^A-Za-z0-9\-]/) || ($d=~m/^-/) || ($d=~m/-$/)); } return 1; } sub is_ipv4 { my ($ip,$checkpublic)=@_; return 0 unless defined($ip); my (@ip)=($ip=~m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/); return 0 unless (@ip==4); foreach my $s (@ip) { return 0 unless (($s >= 0) && ($s <= 255)); } return 1 unless (defined($checkpublic) && $checkpublic); ## Check if this IP is public (see RFC3330) return 0 if ($ip[0] == 0); ## 0.x.x.x [ RFC 1700 ] return 0 if ($ip[0] == 10); ## 10.x.x.x [ RFC 1918 ] return 0 if ($ip[0] == 127); ## 127.x.x.x [ RFC 1700 ] return 0 if (($ip[0] == 169) && ($ip[1]==254)); ## 169.254.0.0/16 link local return 0 if (($ip[0] == 172 ) && ($ip[1]>=16) && ($ip[1]<=31)); ## 172.16.x.x to 172.31.x.x [ RFC 1918 ] return 0 if (($ip[0] == 192 ) && ($ip[1]==0) && ($ip[2]==2)); ## 192.0.2.0/24 TEST-NET return 0 if (($ip[0] == 192 ) && ($ip[1]==168)); ## 192.168.x.x [ RFC 1918 ] return 0 if (($ip[0] >= 224) && ($ip[0] < 240 )); ## 224.0.0.0/4 Class D [ RFC 3171] return 0 if ($ip[0] >= 240); ## 240.0.0.0/4 Class E [ RFC 1700 ] return 1; } ## Inspired by Net::IP which unfortunately requires Perl 5.8 sub is_ipv6 { my ($ip,$checkpublic)=@_; return 0 unless defined($ip); my (@ip)=split(/:/,$ip); return 0 unless ((@ip > 0) && (@ip <= 8)); return 0 if (($ip=~m/^:[^:]/) || ($ip=~m/[^:]:$/)); return 0 if ($ip =~ s/:(?=:)//g > 1); ## We do not allow IPv4 in IPv6 return 0 if grep { ! /^[a-f\d]{0,4}$/i } @ip; return 1 unless (defined($checkpublic) && $checkpublic); ## Check if this IP is public my ($ip1,$ip2)=split(/::/,$ip); $ip1=join('',map { sprintf('%04s',$_) } split(/:/,$ip1 || '')); $ip2=join('',map { sprintf('%04s',$_) } split(/:/,$ip2 || '')); my $wip=$ip1.('0' x (32-length($ip1)-length($ip2))).$ip2; ## 32 chars my $bip=unpack('B128',pack('H32',$wip)); ## 128-bit array ## RFC 3513 §2.4 return 0 if ($bip=~m/^0{127}/); ## unspecified + loopback return 0 if ($bip=~m/^1{7}/); ## multicast + link-local unicast + site-local unicast ## everything else is global unicast, ## but see §4 and http://www.iana.org/assignments/ipv6-address-space return 0 if ($bip=~m/^000/); ## unassigned + reserved (first 6 lines) return 1 if ($bip=~m/^001/); ## global unicast (2000::/3) return 0; ## everything else is unassigned } #################################################################################################### sub compare_durations { my ($dtd1,$dtd2)=@_; ## from DateTime::Duration module, internally are stored: months, days, minutes, seconds and nanoseconds ## those are the keys of the hash ref given by the deltas method my %d1=$dtd1->deltas(); my %d2=$dtd2->deltas(); ## Not perfect, but should be enough for us return (($d1{months} <=> $d2{months}) || ($d1{days} <=> $d2{days}) || ($d1{minutes} <=> $d2{minutes}) || ($d1{seconds} <=> $d2{seconds}) ); } #################################################################################################### sub xml_is_normalizedstring { my ($what,$min,$max)=@_; return 0 unless defined($what); return 0 if ($what=~m/[\r\n\t]/); my $l=length($what); return 0 if (defined($min) && ($l < $min)); return 0 if (defined($max) && ($l > $max)); return 1; } sub xml_is_token { my ($what,$min,$max)=@_; return 0 unless defined($what); return 0 if ($what=~m/[\r\n\t]/); return 0 if ($what=~m/^\s/); return 0 if ($what=~m/\s$/); return 0 if ($what=~m/\s\s/); my $l=length($what); return 0 if (defined($min) && ($l < $min)); return 0 if (defined($max) && ($l > $max)); return 1; } sub xml_is_ncname ## xml:id is of this type { my ($what)=@_; return 0 unless defined($what) && $what; return ($what=~m/^\p{ID_Start}\p{ID_Continue}*$/) } sub verify_ushort { my $in=shift; return (defined($in) && ($in=~m/^\d+$/) && ($in < 65536))? 1 : 0; } sub verify_ubyte { my $in=shift; return (defined($in) && ($in=~m/^\d+$/) && ($in < 256))? 1 : 0; } sub verify_hex { my $in=shift; return (defined($in) && ($in=~m/^[0-9A-F]+$/i))? 1 : 0; } sub verify_int { my ($in,$min,$max)=@_; return 0 unless defined($in) && ($in=~m/^-?\d+$/); return 0 if ($in < (defined($min)? $min : -2147483648)); return 0 if ($in > (defined($max)? $max : 2147483647)); return 1; } sub verify_base64 { my ($in,$min,$max)=@_; my $b04='[AQgw]'; my $b16='[AEIMQUYcgkosw048]'; my $b64='[A-Za-z0-9+/]'; return 0 unless ($in=~m/^(?:(?:$b64 ?$b64 ?$b64 ?$b64 ?)*(?:(?:$b64 ?$b64 ?$b64 ?$b64)|(?:$b64 ?$b64 ?$b16 ?=)|(?:$b64 ?$b04 ?= ?=)))?$/); return 0 if (defined($min) && (length($in) < $min)); return 0 if (defined($max) && (length($in) > $max)); return 1; } ## Same in XML and in RFC3066 sub xml_is_language { my $in=shift; return 0 unless defined($in); return 1 if ($in=~m/^[a-zA-Z]{1,8}(?:-[a-zA-Z0-9]{1,8})*$/); return 0; } sub xml_is_boolean { my $in=shift; return 0 unless defined($in); return 1 if ($in=~m/^(?:1|0|true|false)$/); return 0; } sub xml_parse_boolean { my $in=shift; return {'true'=>1,1=>1,0=>0,'false'=>0}->{$in}; } sub xml_escape { my ($in)=@_; $in=~s/&/&/g; $in=~s//>/g; return $in; } sub xml_write { my $rd=shift; my @t; foreach my $d ((ref($rd->[0]))? @$rd : ($rd)) ## $d is a node=ref array { my @c; ## list of children nodes my %attr; foreach my $e (grep { defined } @$d) { if (ref($e) eq 'HASH') { while(my ($k,$v)=each(%$e)) { $attr{$k}=$v; } } else { push @c,$e; } } my $tag=shift(@c); my $attr=keys(%attr)? ' '.join(' ',map { $_.'="'.$attr{$_}.'"' } sort(keys(%attr))) : ''; if (!@c || (@c==1 && !ref($c[0]) && ($c[0] eq ''))) { push @t,'<'.$tag.$attr.'/>'; } else { push @t,'<'.$tag.$attr.'>'; push @t,(@c==1 && !ref($c[0]))? xml_escape($c[0]) : xml_write(\@c); push @t,''; } } return @t; } sub xml_indent { my $xml=shift; chomp($xml); my $r; $xml=~s!(<)!\n$1!g; $xml=~s!<(\S+)>(.+)\n!<$1>$2!g; $xml=~s!<(\S+)((?:\s+\S+=['"][^'"]+['"])+)>(.+)\n!<$1$2>$3!g; my $s=0; foreach my $m (split(/\n/,$xml)) { next if $m=~m/^\s*$/; $s-- if ($m=~m!^$!); $r.=' ' x $s; $r.=$m."\n"; $s++ if ($m=~m!^<[^>?]+[^/](?:\s+\S+=['"][^'"]+['"])*>$!); $s-- if ($m=~m!^$!); } ## As xml_indent is used during logging, we do a final quick check (spaces should not be relevant anyway) ## This test should probably be dumped as some point in the future when we are confident enough. But we got hit in the past by some subtleties, so... my $in=$xml; $in=~s/\s+//g; my $out=$r; $out=~s/\s+//g; if ($in ne $out) { Net::DRI::Exception::err_assert('xml_indent failed to do its job, please report !'); } return $r; } sub xml_list_children { my $node=shift; ## '*' catch all element nodes being direct children of given node return map { [ $_->localname() || $_->nodeName(),$_ ] } grep { $_->nodeType() == 1 } $node->getChildrenByTagName('*'); } sub xml_traverse { my ($node,$ns,@nodes)=@_; my $p=sprintf('*[namespace-uri()="%s" and local-name()="%s"]',$ns,shift(@nodes)); $p.='/'.join('/',map { '*[local-name()="'.$_.'"]' } @nodes) if @nodes; my $r=$node->findnodes($p); return unless $r->size(); return ($r->size()==1)? $r->get_node(1) : $r->get_nodelist(); } sub xml_child_content { my ($node,$ns,$what)=@_; my $list=$node->getChildrenByTagNameNS($ns,$what); return unless $list->size()==1; my $n=$list->get_node(1); return defined $n ? $n->textContent() : undef; } #################################################################################################### sub remcam { my $in=shift; $in=~s/ID/_id/g; $in=~s/([A-Z])/_$1/g; return lc($in); } sub encode { my ($cs,$data)=@_; return Encode::encode($cs,ref $data? $data->as_string() : $data,1); } ## Will croak on malformed data (a case that should not happen) sub encode_utf8 { return encode('UTF-8',$_[0]); } sub encode_ascii { return encode('ascii',$_[0]); } sub decode { my ($cs,$data)=@_; return Encode::decode($cs,$data,1); } ## Will croak on malformed data (a case that should not happen) sub decode_utf8 { return decode('UTF-8',$_[0]); } sub decode_ascii { return decode('ascii',$_[0]); } sub decode_latin1{ return decode('iso-8859-1',$_[0]); } sub normalize_name { my ($type,$key)=@_; $type=lc($type); ## contact IDs may be case sensitive... ## Will need to be redone differently with IDNs $key=lc($key) if ($type eq 'domain' || $type eq 'nsgroup'); $key=lc($key) if ($type eq 'host' && $key=~m/\./); ## last test part is done only to handle the pure mess created by Nominet .UK "EPP" implementation... return ($type,$key); } #################################################################################################### ## RFC2782 ## (Net::DNS rrsort for SRV records does not seem to implement the same algorithm as the one specificied in the RFC, ## as it just does a comparison on priority then weight) sub dns_srv_order { my (@r,%r); foreach my $ans (@_) { push @{$r{$ans->priority()}},$ans; } foreach my $pri (sort { $a <=> $b } keys(%r)) { my @o=@{$r{$pri}}; if (@o > 1) { my $ts=0; foreach (@o) { $ts+=$_->weight(); } my $s=0; @o=map { $s+=$_->weight(); [ $s, $_ ] } (grep { $_->weight() == 0 } @o, grep { $_->weight() > 0 } @o); my $cs=0; while(@o > 1) { my $r=int(rand($ts-$cs+1)); foreach my $i (0..$#o) { next unless $o[$i]->[0] >= $r; $cs+=$o[$i]->[0]; foreach my $j (($i+1)..$#o) { $o[$j]->[0]-=$o[$i]->[0]; } push @r,$o[$i]->[1]; splice(@o,$i,1); last; } } } push @r,$o[0]->[1]; } return map { [$_->target(),$_->port()] } @r; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Transport.pm0000644000175000017500000001657011352534377016755 0ustar patrickpatrick## Domain Registry Interface, Superclass of all Transport/* modules (hence virtual class, never used directly) ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Transport; use strict; use warnings; use base qw(Class::Accessor::Chained::Fast Net::DRI::BaseClass); __PACKAGE__->mk_accessors(qw/name version retry pause trace timeout defer current_state has_state is_sync time_creation time_open time_used trid_factory logging/); use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.20 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Transport - Superclass of all Transport Modules in Net::DRI =head1 DESCRIPTION Please see the README file for details. This is a superclass that should never be used directly, but only through its subclasses. =head1 METHODS During the new() call, subclasses will call this new() method, which expects a ref hash with some keys (other are handled by the subclasses), among which: =head2 defer do we open the connection right now (0) or later (1) =head2 timeout time to wait (in seconds) for server reply (default 60) =head2 retry number of times we try to send the message to the registry (default 2) =head2 trid (optional) code reference of a subroutine generating a transaction id when passed a name ; if not defined, $dri->trid_factory() is used, which is Net::DRI::Util::create_trid_1 by default =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,$ctx,$ropts)=@_; my $ndr=$ctx->{registry}; my $pname=$ctx->{profile}; my $self={ is_sync => exists($ropts->{is_sync})? $ropts->{is_sync} : 1, ## do we need to wait for reply as soon as command sent ? retry => exists($ropts->{retry})? $ropts->{retry} : 2, ## by default, we will try once only pause => exists($ropts->{pause})? $ropts->{pause} : 10, ## time in seconds to wait between two retries # trace => exists($ropts->{trace})? $ropts->{trace} : 0, ## NOT IMPL timeout => exists($ropts->{timeout})? $ropts->{timeout} : 60, defer => exists($ropts->{defer})? $ropts->{defer} : 0, ## defer opening connection as long as possible (irrelevant if stateless) ## XX maybe not here, too low logging => exists($ropts->{logging})? $ropts->{logging} : $ndr->logging(), trid_factory => (exists($ropts->{trid}) && (ref($ropts->{trid}) eq 'CODE'))? $ropts->{trid} : $ndr->trid_factory(), current_state => undef, ## for stateless transport, otherwise 0=close, 1=open has_state => undef, ## do we need to open a session before sending commands ? transport => undef, ## will be defined in subclasses time_creation => time(), logging_ctx => { registry => $ndr->name(), profile => $pname, protocol => $ctx->{protocol}->name() }, }; if (exists($ropts->{log_fh}) && defined($ropts->{log_fh})) { print STDERR 'log_fh is deprecated and will not be used now, please use new Logging framework',"\n"; } bless $self,$class; $self->log_setup_channel($class,'transport',$self->{logging_ctx}); ## if we need the transport name here, we will have to put that further below, in another method called after new() ; otherwise we derive it from $class $self->log_output('debug','core',sprintf('Added transport %s for registry %s',$class,$ndr->name())); return $self; } sub transport_data { my ($self,$data)=@_; return defined $data ? $self->{transport}->{$data} : $self->{transport}; } sub log_output { my ($self,$level,$type,$data1,$data2)=@_; return $self->logging()->output($level,$type,$data1) unless defined $data2; $self->{logging_ctx}->{transport}=$self->name().'/'.$self->version() unless exists $self->{logging_ctx}->{transport}; return $self->logging()->output($level,$type,{ %{$self->{logging_ctx}}, %$data1, %$data2 }); } sub send { my ($self,$ctx,$tosend,$cb1,$cb2,$count)=@_; ## $cb1=how to send, $cb2=how to test if fatal (to break loop) or not (retry once more) Net::DRI::Exception::err_insufficient_parameters() unless ($cb1 && (ref($cb1) eq 'CODE')); my $ok=0; ## Try to reconnect if needed $self->open_connection($ctx) if ($self->has_state() && !$self->current_state()); ## Here $tosend is a Net::DRI::Protocol::Message object (in fact, a subclass of that), in perl internal encoding, no transport related data (such as EPP 4 bytes header) $self->log_output('notice','transport',$ctx,{phase=>'active',direction=>'out',message=>$tosend}); $ok=$self->$cb1($count,$tosend,$ctx); $self->time_used(time()); Net::DRI::Exception->die(0,'transport',4,'Unable to send message to registry') unless $ok; } sub receive { my ($self,$ctx,$cb1,$cb2,$count)=@_; Net::DRI::Exception::err_insufficient_parameters() unless ($cb1 && (ref($cb1) eq 'CODE')); my $ans; $ans=$self->$cb1($count,$ctx); ## a Net::DRI::Data::Raw object Net::DRI::Exception->die(0,'transport',5,'Unable to receive message from registry') unless defined($ans); ## $ans should have been properly decoded into a native Perl string $self->log_output('notice','transport',$ctx,{phase=>'active',direction=>'in',message=>$ans}); return $ans; } sub try_again ## TO BE SUBCLASSED { my ($self,$ctx,$po,$err,$count,$istimeout,$step,$rpause,$rtimeout)=@_; ## $step is 0 before send, 1 after, and 2 after receive successful ## Should return 1 if we try again, or 0 if we should stop processing now return ($istimeout && ($count <= $self->{retry}))? 1 : 0; } sub open_connection { my ($self,$ctx)=@_; return unless $self->has_state(); Net::DRI::Exception::err_method_not_implemented(); } sub end { my ($self)=@_; return unless $self->has_state(); Net::DRI::Exception::err_method_not_implemented(); } #################################################################################################### ## Returns 1 if we are still connected, 0 otherwise (and sets current_state to 0) ## Pass a true value if you want the connection to be automatically redone if the ping failed sub ping { my ($self,$autorecon)=@_; return unless $self->has_state(); Net::DRI::Exception::err_method_not_implemented(); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/DRD.pm0000644000175000017500000011416711352534377015373 0ustar patrickpatrick## Domain Registry Interface, virtual superclass for all DRD modules ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::DRD; use strict; use warnings; use base qw/Net::DRI::BaseClass/; __PACKAGE__->make_exception_if_not_implemented(qw/name tlds object_types periods profile_types transport_protocol_default/); ## methods that should be in subclasses use DateTime; use Net::DRI::Exception; use Net::DRI::Util; use Net::DRI::DRD::ICANN; our $VERSION=do { my @r=(q$Revision: 1.33 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::DRD - Superclass of all Net::DRI Registry Drivers =head1 DESCRIPTION Please see the README file for details. =head1 SUBROUTINES/METHODS =head2 name() Name of this registry driver (this should not contain any dot at all) =head2 tlds() Array of tlds (lowercase, no starting or ending dot) handled by this registry =head2 object_types() Array of object types managed by this registry =head2 periods() Array of DateTime::Duration objects for valid domain name creation durations at registry =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my ($class,@r)=@_; my $self={ info => defined $r[0] ? $r[0] : {} }; bless($self,$class); return $self; } sub info { my ($self,$ndr,$key)=@_; $key=$ndr unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return unless defined($self->{info}); return unless (defined($key) && exists($self->{info}->{$key})); return $self->{info}->{$key}; } sub is_my_tld { my ($self,$ndr,$domain,$strict)=@_; ($domain,$strict)=($ndr,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); if (! defined($strict)) { $strict=1; } if ($domain=~m/\.e164\.arpa$/) { $strict=0; } my $tlds=join('|',map { quotemeta($_) } sort { length($b) <=> length($a) } $self->tlds()); my $r=$strict? qr/^[^.]+\.(?:$tlds)$/i : qr/\.(?:$tlds)$/i; return ($domain=~$r)? 1 : 0; } sub _verify_name_rules { my ($self,$domain,$op,$rules)=@_; if (exists $rules->{check_name} && $rules->{check_name}) { my $dots=$rules->{check_name_dots}; if (! defined $dots) { $dots=$self->dots(); } my $r=$self->check_name($domain,$dots); if ($r) { return $r; } } if (exists $rules->{check_name_no_dots} && $rules->{check_name_no_dots}) { my $r=$self->check_name($domain); if ($r) { return $r; } } if (exists $rules->{my_tld} && $rules->{my_tld} && ! $self->is_my_tld($domain)) { return 'NAME_NOT_IN_TLD'; } if (exists $rules->{my_tld_not_strict} && $rules->{my_tld_not_strict} && ! $self->is_my_tld($domain,0)) { return 'NAME_NOT_IN_TLD'; } if (exists $rules->{icann_reserved} && $rules->{icann_reserved} && Net::DRI::DRD::ICANN::is_reserved_name($domain,$op)) { return 'NAME_RESERVED_PER_ICANN_RULES'; } my @d=split(/\./,$domain); if (exists $rules->{min_length} && $rules->{min_length} && length($d[0]) < $rules->{min_length}) { return 'NAME_TOO_SHORT'; } if (exists $rules->{no_double_hyphen} && $rules->{no_double_hyphen} && substr($d[0],2,2) eq '--') { return 'NAME_WITH_TWO_HYPHENS'; } if (exists $rules->{no_double_hyphen_except_idn} && $rules->{no_double_hyphen_except_idn} && substr($d[0],2,2) eq '--' && substr($d[0],0,2) ne 'xn') { return 'NAME_WITH_TWO_HYPHENS_NOT_IDN'; } if (exists $rules->{no_country_code} && $rules->{no_country_code} && exists $Net::DRI::Util::CCA2{uc($d[0])}) { return 'NAME_WITH_COUNTRY_CODE'; } if (exists $rules->{no_digits_only} && $rules->{no_digits_only} && $d[0]=~m/^\d+$/) { return 'NAME_WITH_ONLY_DIGITS'; } if ($domain=~m/\.e164\.arpa$/ && $domain!~m/^(?:\d+\.)+e164\.arpa$/) { return 'NAME_INVALID_IN_E164'; } if (exists $rules->{excluded_labels}) { my $n=join('|',ref $rules->{excluded_labels}? @{$rules->{excluded_labels}} : ($rules->{excluded_labels})); if (lc($d[0])=~m/^(?:$n)$/o) { return 'NAME_WITH_EXCLUDED_LABELS'; } } ## It seems all rules have passed successfully return ''; } ## Compute the number of dots for each tld in tlds(), returns a ref array and store it for later quick access sub dots { my ($self)=@_; if (! exists $self->{dots}) { my %a=map { $_ => 1 } map { my $r=$_; my $c=($r=~tr/\././); 1+$c; } $self->tlds(); $self->{dots}=[ sort { $a <=> $b } keys(%a) ]; } return $self->{dots}; } sub has_object { my ($self,$ndr,$type)=@_; $type=$ndr unless (defined($type) && ref($ndr)); return 0 unless (defined($type) && $type); $type=lc($type); return (grep { lc($_) eq $type } ($self->object_types()))? 1 : 0; } ## TODO : use also protocol->has_action() ? (see end of domain_create) sub registry_can { my ($self,$ndr,$what)=@_; return ($self->UNIVERSAL::can($what) && ! grep { $what eq $_ } $self->unavailable_operations())? 1 : 0; } ## It would be probably more useful to know the list of available ones ! ## An overhaul would be probably needed when more non domain names registries are added sub unavailable_operations { return (); } ## will be overruled by BaseClass, as needed #################################################################################################### ## A common default, which should be fine for EPP & related ways of doing things ## (should it be done in the Protocol class instead ?) sub domain_operation_needs_is_mine { my ($self,$ndr,$domain,$op)=@_; if (! defined $op) { return; } if ($op=~m/^(?:renew|update|delete)$/) { return 1; } if ($op eq 'transfer') { return 0; } return; } ## This is the default basic one, it should get subclassed as needed sub verify_name_domain { my ($self,$ndr,$domain,$op)=@_; return $self->_verify_name_rules($domain,$op,{check_name=>1,my_tld=>1}); } sub verify_name_host { my ($self,$ndr,$host,$checktld)=@_; $host=$host->get_names(1) if ref $host; my $r=$self->check_name($host); return $r if length $r; return 'HOST_NAME_NOT_IN_CORRECT_TLD' if (defined $checktld && $checktld && !$self->is_my_tld($host,0)); return ''; } sub check_name { my ($self,$ndr,$data,$dots)=@_; ($data,$dots)=($ndr,$data) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return 'UNDEFINED_NAME' unless defined $data; return 'ZERO_LENGTH_NAME' unless length $data; return 'NON_SCALAR_NAME' unless !ref($data); return 'INVALID_HOSTNAME' unless Net::DRI::Util::is_hostname($data); if (defined($dots) && $data!~m/\.e164\.arpa$/) { my @d=split(/\./,$data); my @ok=ref($dots)? @$dots : ($dots); return 'INVALID_NUMBER_OF_DOTS_IN_NAME' unless grep { 1+$_== @d } @ok; } return ''; #everything ok } sub verify_duration_create { my ($self,$ndr,$duration,$domain)=@_; ($duration,$domain)=($ndr,$duration) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); my @d=$self->periods(); return 1 unless @d; foreach my $d (@d) { return 0 if (0==Net::DRI::Util::compare_durations($d,$duration)) } return 2; } sub verify_duration_renew { my ($self,$ndr,$duration,$domain,$curexp)=@_; ($duration,$domain,$curexp)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); my @d=$self->periods(); if (defined($duration) && @d) { my $ok=0; foreach my $d (@d) { next unless (0==Net::DRI::Util::compare_durations($d,$duration)); $ok=1; last; } return 1 unless $ok; if (defined($curexp) && UNIVERSAL::isa($curexp,'DateTime')) { my $maxdelta=$d[-1]; my $newexp=$curexp+$duration; ## New expiration my $now=DateTime->now(time_zone => $curexp->time_zone()->name()); my $cmp=DateTime->compare($newexp,$now+$maxdelta); return 2 unless ($cmp == -1); ## we must have : curexp+duration < now + maxdelta } } return 0; ## everything ok } sub verify_duration_transfer { my ($self,$ndr,$duration,$domain,$op)=@_; ($duration,$domain,$op)=($ndr,$duration,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry')); return 0; ## everything ok } #################################################################################################### sub enforce_domain_name_constraints { my ($self,$ndr,$domain,$op)=@_; my $err=$self->verify_name_domain($ndr,$domain,$op); Net::DRI::Exception->die(0,'DRD',1,'Invalid domain name (error '.$err.'): '.((defined($domain) && $domain)? $domain : '?')) if length $err; } sub enforce_host_name_constraints { my ($self,$ndr,$dh,$checktld)=@_; my $err=$self->verify_name_host($ndr,$dh,$checktld); Net::DRI::Exception->die(0,'DRD',2,'Invalid host name (error '.$err.'): '.((UNIVERSAL::isa($dh,'Net::DRI::Data::Hosts'))? $dh->get_names(1) : (defined $dh? $dh : '?'))) if length $err; } sub err_invalid_contact { my ($self,$c)=@_; Net::DRI::Exception->die(0,'DRD',6,'Invalid contact: '.((defined($c) && $c && UNIVERSAL::can($c,'srid'))? $c->srid() : '?')); } #################################################################################################### ## Operations on DOMAINS #################################################################################################### sub domain_create { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'create'); my %rd=(defined($rd) && (ref($rd) eq 'HASH'))? %$rd : (); my $pure=(exists($rd{pure_create}) && $rd{pure_create})? 1 : 0; delete($rd{pure_create}); my ($rc,$rcl); if (!$pure) { $rcl=$self->domain_check($ndr,$domain,$rd); return $rcl unless ($rcl->is_success() && $rcl->get_data('domain',$domain,'exist')==0); $rc=$rcl; } my $nsin=$ndr->local_object('hosts'); my $nsout=$ndr->local_object('hosts'); Net::DRI::Util::check_isa($rd{ns},'Net::DRI::Data::Hosts') if (exists($rd{ns})); ## test needed in both cases ## If not pure domain creation, separate nameservers (inside & outside of domain) and then create outside nameservers if needed if (!$pure && exists($rd{ns}) && $self->has_object('ns')) { foreach (1..$rd{ns}->count()) { my @a=$rd{ns}->get_details($_); if ($a[0]=~m/^(.+\.)?${domain}$/i) { $nsin->add(@a); } else { my $ns=$ndr->local_object('hosts')->set(@a); my $e=$self->host_exist($ndr,$ns); unless (defined $e && $e==1) { $rcl=$self->host_create($ndr,$ns); if (defined $rc) { $rc->_add_last($rcl); } else { $rc=$rcl; } return $rc unless $rcl->is_success(); } $nsout->add(@a); } } $rd{ns}=$nsout; } ## If not pure domain creation, and if contacts are used make sure they exist as objects in the registry if needed if (!$pure && exists($rd{contact}) && Net::DRI::Util::isa_contactset($rd{contact}) && $self->has_object('contact')) { my %cd; foreach my $t ($rd{contact}->types()) { foreach my $co ($rd{contact}->get($t)) { next if exists($cd{$co->srid()}); my $e=$self->contact_exist($ndr,$co); unless (defined $e && $e==1) { $rcl=$self->contact_create($ndr,$co); if (defined $rc) { $rc->_add_last($rcl); } else { $rc=$rcl; } return $rc unless $rcl->is_success(); } $cd{$co->srid()}=1; } } } Net::DRI::Exception->die(0,'DRD',3,'Invalid duration') if (exists($rd{duration}) && defined($rd{duration}) && ((ref($rd{duration}) ne 'DateTime::Duration') || $self->verify_duration_create($rd{duration},$domain))); $rcl=$ndr->process('domain','create',[$domain,\%rd]); return $rcl if $pure; ## pure domain creation we do not bother with other stuff and we stop here ## From now on, we are sure $rc is defined $rc->_add_last($rcl); return $rc unless $rcl->is_success(); ## Create inside nameservers and add them to the domain unless ($nsin->is_empty()) { foreach (1..$nsin->count()) { my $ns=$ndr->local_object('hosts')->set($nsin->get_details($_)); $rcl=$self->host_create($ndr,$ns); $rc->_add_last($rcl); return $rc unless $rcl->is_success(); } $rcl=$ndr->protocol_capable('domain_update','ns','add')? $self->domain_update_ns_add($ndr,$domain,$nsin) : $self->domain_update_ns_set($ndr,$domain,$nsin); $rc->_add_last($rcl); return $rc unless $rcl->is_success(); } ## Add status to domain, if provided if (exists($rd{status})) { $rcl=$ndr->protocol_capable('domain_update','status','add')? $self->domain_update_status_add($ndr,$domain,$rd{status}) : $self->domain_update_status_set($ndr,$domain,$rd{status}); $rc->_add_last($rcl); return $rc unless $rcl->is_success(); } ## Do a final info to populate the local cache if ($ndr->protocol()->has_action('domain','info')) { $rcl=$self->domain_info($ndr,$domain); $rc->_add_last($rcl); } return $rc; } sub domain_delete { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'delete'); my %rd=(defined($rd) && (ref($rd) eq 'HASH'))? %$rd : (); my $rc; if ((! exists($rd{pure_delete})) || $rd{pure_delete}==0) { $rc=$self->domain_info($ndr,$domain); return $rc unless $rc->is_success(); ## This will make sure we remove in-bailiwick nameservers, otherwise the final delete would fail my $ns=$ndr->get_info('ns'); if (defined($ns) && !$ns->is_empty()) { my $rcn=$self->domain_update_ns_del($ndr,$domain,$ns); $rc->_add_last($rcn); return $rc unless $rc->is_success(); } } delete($rd{pure_delete}); my $rcn=$ndr->process('domain','delete',[$domain,\%rd]); if (defined $rc) { $rc->_add_last($rcn); } else { $rc=$rcn; } return $rc; } sub domain_info { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'info'); my $rc=$ndr->try_restore_from_cache('domain',$domain,'info'); if (! defined $rc) { $rc=$ndr->process('domain','info',[$domain,$rd]); } return $rc; } sub domain_check { my ($self,$ndr,$domain,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'check'); my $rc=$ndr->try_restore_from_cache('domain',$domain,'check'); if (! defined $rc) { $rc=$ndr->process('domain','check',[$domain,$rd]); } return $rc; } sub domain_check_multi { my ($self,$ndr,@r)=@_; my $rd; $rd=pop(@r) if ($r[-1] && (ref($r[-1]) eq 'HASH')); my $rc; my @d; foreach my $domain (@r) { $self->enforce_domain_name_constraints($ndr,$domain,'check'); $rc=$ndr->try_restore_from_cache('domain',$domain,'check'); if (! defined $rc) { push @d,$domain; } } if (@d) { if ($ndr->protocol()->has_action('domain','check_multi')) { $rc=$ndr->process('domain','check_multi',[\@d,$rd]); } else { foreach my $domain (@d) { $rc=$ndr->process('domain','check',[$domain,$rd]); } } } return $rc; ## this is the result status of last call, maybe we should chain them using ResultStatus->next() ? } sub domain_exist ## 1/0/undef { my ($self,$ndr,$domain,$rd)=@_; my $rc=$ndr->domain_check($domain,$rd); return unless $rc->is_success(); return $ndr->get_info('exist'); } sub domain_update { my ($self,$ndr,$domain,$tochange,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'update'); Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes'); Net::DRI::Exception->new(0,'DRD',4,'Registry does not handle contacts') if ($tochange->all_defined('contact') && ! $self->has_object('contact')); my $fp=$ndr->protocol->nameversion(); foreach my $t ($tochange->types()) { Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of domain_update/'.$t) unless $ndr->protocol_capable('domain_update',$t); my $add=$tochange->add($t); my $del=$tochange->del($t); my $set=$tochange->set($t); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of domain_update/'.$t.' (add)') if (defined($add) && ! $ndr->protocol_capable('domain_update',$t,'add')); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of domain_update/'.$t.' (del)') if (defined($del) && ! $ndr->protocol_capable('domain_update',$t,'del')); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of domain_update/'.$t.' (set)') if (defined($set) && ! $ndr->protocol_capable('domain_update',$t,'set')); } foreach ($tochange->all_defined('ns')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::Hosts'); } foreach ($tochange->all_defined('status')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::StatusList'); } foreach ($tochange->all_defined('contact')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::ContactSet'); } my $rc=$ndr->process('domain','update',[$domain,$tochange,$rd]); return $rc; } sub domain_update_ns_add { my ($self,$ndr,$domain,$ns,$rd)=@_; return $self->domain_update_ns($ndr,$domain,$ns,$ndr->local_object('hosts'),$rd); } sub domain_update_ns_del { my ($self,$ndr,$domain,$ns,$rd)=@_; return $self->domain_update_ns($ndr,$domain,$ndr->local_object('hosts'),$ns,$rd); } sub domain_update_ns_set { my ($self,$ndr,$domain,$ns,$rd)=@_; return $self->domain_update_ns($ndr,$domain,$ns,undef,$rd); } sub domain_update_ns { my ($self,$ndr,$domain,$nsadd,$nsdel,$rd)=@_; Net::DRI::Util::check_isa($nsadd,'Net::DRI::Data::Hosts'); if (defined($nsdel)) ## add + del { Net::DRI::Util::check_isa($nsdel,'Net::DRI::Data::Hosts'); my $c=$ndr->local_object('changes'); $c->add('ns',$nsadd) unless ($nsadd->is_empty()); $c->del('ns',$nsdel) unless ($nsdel->is_empty()); return $self->domain_update($ndr,$domain,$c,$rd); } else { return $self->domain_update($ndr,$domain,$ndr->local_object('changes')->set('ns',$nsadd),$rd); } } sub domain_update_status_add { my ($self,$ndr,$domain,$s,$rd)=@_; return $self->domain_update_status($ndr,$domain,$s,$ndr->local_object('status'),$rd); } sub domain_update_status_del { my ($self,$ndr,$domain,$s,$rd)=@_; return $self->domain_update_status($ndr,$domain,$ndr->local_object('status'),$s,$rd); } sub domain_update_status_set { my ($self,$ndr,$domain,$s,$rd)=@_; return $self->domain_update_status($ndr,$domain,$s,undef,$rd); } sub domain_update_status { my ($self,$ndr,$domain,$sadd,$sdel,$rd)=@_; Net::DRI::Util::check_isa($sadd,'Net::DRI::Data::StatusList'); if (defined($sdel)) ## add + del { Net::DRI::Util::check_isa($sdel,'Net::DRI::Data::StatusList'); my $c=$ndr->local_object('changes'); $c->add('status',$sadd) unless ($sadd->is_empty()); $c->del('status',$sdel) unless ($sdel->is_empty()); return $self->domain_update($ndr,$domain,$c,$rd); } else { return $self->domain_update($ndr,$domain,$ndr->local_object('changes')->set('status',$sadd),$rd); } } sub domain_update_contact_add { my ($self,$ndr,$domain,$c,$rd)=@_; return $self->domain_update_contact($ndr,$domain,$c,$ndr->local_object('contactset'),$rd); } sub domain_update_contact_del { my ($self,$ndr,$domain,$c,$rd)=@_; return $self->domain_update_contact($ndr,$domain,$ndr->local_object('contactset'),$c,$rd); } sub domain_update_contact_set { my ($self,$ndr,$domain,$c,$rd)=@_; return $self->domain_update_contact($ndr,$domain,$c,undef,$rd); } sub domain_update_contact { my ($self,$ndr,$domain,$cadd,$cdel,$rd)=@_; Net::DRI::Util::check_isa($cadd,'Net::DRI::Data::ContactSet'); if (defined($cdel)) ## add + del { Net::DRI::Util::check_isa($cdel,'Net::DRI::Data::ContactSet'); my $c=$ndr->local_object('changes'); $c->add('contact',$cadd) unless ($cadd->is_empty()); $c->del('contact',$cdel) unless ($cdel->is_empty()); return $self->domain_update($ndr,$domain,$c,$rd); } else { return $self->domain_update($ndr,$domain,$ndr->local_object('changes')->set('contact',$cadd),$rd); } } sub domain_renew { my ($self,$ndr,$domain,$rd,@e)=@_; ## Previous API : ($self,$ndr,$domain,$duration,$curexp,$deletedate,$rd) if (@e) { my ($duration,$curexp,$deletedate,$rd2)=($rd,@e); $rd2={} unless (defined($rd2) && (ref($rd2) eq 'HASH')); $rd2->{duration}=$duration if (defined($duration)); $rd2->{current_expiration}=$curexp if (defined($curexp)); ## deletedate should never have been there, a bug probably $rd=$rd2; } elsif (defined($rd) && (ref($rd) ne 'HASH')) { $rd={duration => $rd}; } $self->enforce_domain_name_constraints($ndr,$domain,'renew'); Net::DRI::Util::check_isa($rd->{duration},'DateTime::Duration') if defined($rd->{duration}); Net::DRI::Util::check_isa($rd->{current_expiration},'DateTime') if defined($rd->{current_expiration}); Net::DRI::Exception->die(0,'DRD',3,'Invalid duration') if $self->verify_duration_renew($rd->{duration},$domain,$rd->{current_expiration}); return $ndr->process('domain','renew',[$domain,$rd]); } sub domain_transfer { my ($self,$ndr,$domain,$op,$rd)=@_; $self->enforce_domain_name_constraints($ndr,$domain,'transfer'); Net::DRI::Exception::usererr_invalid_parameters('Transfer operation must be start,stop,accept,refuse or query') unless ($op=~m/^(?:start|stop|query|accept|refuse)$/); Net::DRI::Exception->die(0,'DRD',3,'Invalid duration') if $self->verify_duration_transfer($ndr,(defined($rd) && (ref($rd) eq 'HASH') && exists($rd->{duration}))? $rd->{duration} : undef,$domain,$op); my $rc; if ($op eq 'start') { $rc=$ndr->process('domain','transfer_request',[$domain,$rd]); } elsif ($op eq 'stop') { $rc=$ndr->process('domain','transfer_cancel',[$domain,$rd]); } elsif ($op eq 'query') { $rc=$ndr->process('domain','transfer_query',[$domain,$rd]); } else ## accept/refuse { $rd={} unless (defined($rd) && (ref($rd) eq 'HASH')); $rd->{approve}=($op eq 'accept')? 1 : 0; $rc=$ndr->process('domain','transfer_answer',[$domain,$rd]); } return $rc; } sub domain_transfer_start { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'start',$rd); } sub domain_transfer_stop { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'stop',$rd); } sub domain_transfer_query { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'query',$rd); } sub domain_transfer_accept { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'accept',$rd); } sub domain_transfer_refuse { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'refuse',$rd); } sub domain_can { my ($self,$ndr,$domain,$what,$rd)=@_; my $sok=$self->domain_status_allows($ndr,$domain,$what,$rd); return 0 unless ($sok); my $ismine=$self->domain_is_mine($ndr,$domain,$rd); my $n=$self->domain_operation_needs_is_mine($ndr,$domain,$what); return unless (defined($n)); return ($ismine xor $n)? 0 : 1; } sub domain_status_allows_delete { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_status_allows($ndr,$domain,'delete',$rd); } sub domain_status_allows_update { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_status_allows($ndr,$domain,'update',$rd); } sub domain_status_allows_transfer { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_status_allows($ndr,$domain,'transfer',$rd); } sub domain_status_allows_renew { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_status_allows($ndr,$domain,'renew',$rd); } sub domain_status_allows { my ($self,$ndr,$domain,$what,$rd)=@_; return 0 unless ($what=~m/^(?:delete|update|transfer|renew)$/); my $s=$self->domain_current_status($ndr,$domain,$rd); return 0 unless (defined($s)); return $s->can_delete() if ($what eq 'delete'); return $s->can_update() if ($what eq 'update'); return $s->can_transfer() if ($what eq 'transfer'); return $s->can_renew() if ($what eq 'renew'); return 0; ## failsafe } sub domain_current_status { my ($self,$ndr,$domain,$rd)=@_; my $rc=$self->domain_info($ndr,$domain,$rd); return unless $rc->is_success(); my $s=$ndr->get_info('status'); return unless Net::DRI::Util::isa_statuslist($s); return $s; } sub domain_is_mine { my ($self,$ndr,$domain,$rd)=@_; my $clid=$self->info('clid'); return 0 unless defined($clid); my $id; eval { my $rc=$self->domain_info($ndr,$domain,$rd); $id=$ndr->get_info('clID') if ($rc->is_success()); }; return 0 unless (!$@ && defined($id)); return ($clid=~m/^${id}$/)? 1 : 0; } #################################################################################################### ## Operations on HOSTS #################################################################################################### sub host_create { my ($self,$ndr,$dh,$rh)=@_; my $name=(UNIVERSAL::isa($dh,'Net::DRI::Data::Hosts'))? $dh->get_details(1) : $dh; $self->enforce_host_name_constraints($ndr,$name,0); my $rc=$ndr->process('host','create',[$dh,$rh]); return $rc; } sub host_delete { my ($self,$ndr,$dh,$rh)=@_; my $name=(UNIVERSAL::isa($dh,'Net::DRI::Data::Hosts'))? $dh->get_details(1) : $dh; $self->enforce_host_name_constraints($ndr,$name); my $rc=$ndr->process('host','delete',[$dh,$rh]); return $rc; } sub host_info { my ($self,$ndr,$dh,$rh)=@_; my $name=(UNIVERSAL::isa($dh,'Net::DRI::Data::Hosts'))? $dh->get_details(1) : $dh; $self->enforce_host_name_constraints($ndr,$name); my $rc=$ndr->try_restore_from_cache('host',$name,'info'); if (! defined $rc) { $rc=$ndr->process('host','info',[$dh,$rh]); } return $rc unless $rc->is_success(); return (wantarray())? ($rc,$ndr->get_info('self')) : $rc; } sub host_check { my ($self,$ndr,$dh,$rh)=@_; my $name=UNIVERSAL::isa($dh,'Net::DRI::Data::Hosts')? $dh->get_details(1) : $dh; $self->enforce_host_name_constraints($ndr,$name); my $rc=$ndr->try_restore_from_cache('host',$name,'check'); if (! defined $rc) { $rc=$ndr->process('host','check',[$dh,$rh]); } return $rc; } sub host_check_multi { my $self=shift; my $ndr=shift; my $rh; $rh=pop(@_) if ($_[-1] && (ref($_[-1]) eq 'HASH')); my ($rc,@h); foreach my $host (map {UNIVERSAL::isa($_,'Net::DRI::Data::Hosts')? $_->get_names() : $_ } @_) { $self->enforce_host_name_constraints($ndr,$host); $rc=$ndr->try_restore_from_cache('host',$host,'check'); if (! defined $rc) { push @h,$host; } } if (@h) { if ($ndr->protocol()->has_action('host','check_multi')) { $rc=$ndr->process('host','check_multi',[\@h,$rh]); } else { foreach my $host (@h) { $rc=$ndr->process('host','check',[$host,$rh]); } } } return $rc; ## see comment in domain_check_multi } sub host_exist ## 1/0/undef { my ($self,$ndr,$dh,$rh)=@_; my $rc=$ndr->host_check($dh,$rh); return unless $rc->is_success(); return $ndr->get_info('exist'); } sub host_update { my ($self,$ndr,$dh,$tochange,$rh)=@_; my $name=(UNIVERSAL::isa($dh,'Net::DRI::Data::Hosts'))? $dh->get_details(1) : $dh; $self->enforce_host_name_constraints($ndr,$name); Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes'); my $fp=$ndr->protocol->nameversion(); foreach my $t ($tochange->types()) { Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of host_update/'.$t) unless $ndr->protocol_capable('host_update',$t); my $add=$tochange->add($t); my $del=$tochange->del($t); my $set=$tochange->set($t); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of host_update/'.$t.' (add)') if (defined($add) && ! $ndr->protocol_capable('host_update',$t,'add')); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of host_update/'.$t.' (del)') if (defined($del) && ! $ndr->protocol_capable('host_update',$t,'del')); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of host_update/'.$t.' (set)') if (defined($set) && ! $ndr->protocol_capable('host_update',$t,'set')); } foreach ($tochange->all_defined('ip')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::Hosts'); } foreach ($tochange->all_defined('status')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::StatusList'); } foreach ($tochange->all_defined('name')) { $self->enforce_host_name_constraints($ndr,$_); } my $rc=$ndr->process('host','update',[$dh,$tochange,$rh]); return $rc; } sub host_update_ip_add { my ($self,$ndr,$dh,$ip,$rh)=@_; return $self->host_update_ip($ndr,$dh,$ip,$ndr->local_object('hosts'),$rh); } sub host_update_ip_del { my ($self,$ndr,$dh,$ip,$rh)=@_; return $self->host_update_ip($ndr,$dh,$ndr->local_object('hosts'),$ip,$rh); } sub host_update_ip_set { my ($self,$ndr,$dh,$ip,$rh)=@_; return $self->host_update_ip($ndr,$dh,$ip,undef,$rh); } sub host_update_ip { my ($self,$ndr,$dh,$ipadd,$ipdel,$rh)=@_; Net::DRI::Util::check_isa($ipadd,'Net::DRI::Data::Hosts'); if (defined($ipdel)) ## add + del { Net::DRI::Util::check_isa($ipdel,'Net::DRI::Data::Hosts'); my $c=$ndr->local_object('changes'); $c->add('ip',$ipadd) unless ($ipadd->is_empty()); $c->del('ip',$ipdel) unless ($ipdel->is_empty()); return $self->host_update($ndr,$dh,$c,$rh); } else ## just set { return $self->host_update($ndr,$dh,$ndr->local_object('changes')->set('ip',$ipadd),$rh); } } sub host_update_status_add { my ($self,$ndr,$dh,$s,$rh)=@_; return $self->host_update_status($ndr,$dh,$s,$ndr->local_object('status'),$rh); } sub host_update_status_del { my ($self,$ndr,$dh,$s,$rh)=@_; return $self->host_update_status($ndr,$dh,$ndr->local_object('status'),$s,$rh); } sub host_update_status_set { my ($self,$ndr,$dh,$s,$rh)=@_; return $self->host_update_status($ndr,$dh,$s,undef,$rh); } sub host_update_status { my ($self,$ndr,$dh,$sadd,$sdel,$rh)=@_; Net::DRI::Util::check_isa($sadd,'Net::DRI::Data::StatusList'); if (defined($sdel)) ## add + del { Net::DRI::Util::check_isa($sdel,'Net::DRI::Data::StatusList'); my $c=$ndr->local_object('changes'); $c->add('status',$sadd) unless ($sadd->is_empty()); $c->del('status',$sdel) unless ($sdel->is_empty()); return $self->host_update($ndr,$dh,$c,$rh); } ## just set { return $self->host_update($ndr,$dh,$ndr->local_object('changes')->set('status',$sadd),$rh); } } sub host_update_name_set { my ($self,$ndr,$dh,$newname,$rh)=@_; $newname=$newname->get_names(1) if ($newname && UNIVERSAL::isa($newname,'Net::DRI::Data::Hosts')); $self->enforce_host_name_constraints($ndr,$newname); return $self->host_update($ndr,$dh,$ndr->local_object('changes')->set('name',$newname),$rh); } sub host_current_status { my ($self,$ndr,$dh,$rh)=@_; my $rc=$self->host_info($ndr,$dh,$rh); return unless $rc->is_success(); my $s=$ndr->get_info('status'); return unless Net::DRI::Util::isa_statuslist($s); return $s; } sub host_is_mine { my ($self,$ndr,$dh,$rh)=@_; my $clid=$self->info('clid'); return 0 unless defined($clid); my $id; eval { my $rc=$self->host_info($ndr,$dh,$rh); $id=$ndr->get_info('clID') if ($rc->is_success()); }; return 0 unless (!$@ && defined($id)); return ($clid=~m/^${id}$/)? 1 : 0; } #################################################################################################### ## Operations on CONTACTS #################################################################################################### sub contact_create { my ($self,$ndr,$contact,$ep)=@_; $self->err_invalid_contact($contact) unless Net::DRI::Util::isa_contact($contact); $contact->init('create',$ndr) if $contact->can('init'); $contact->validate(); ## will trigger an Exception if validation not ok my $rc=$ndr->process('contact','create',[$contact,$ep]); return $rc; } sub contact_delete { my ($self,$ndr,$contact,$ep)=@_; $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid()); my $rc=$ndr->process('contact','delete',[$contact,$ep]); return $rc; } sub contact_info { my ($self,$ndr,$contact,$ep)=@_; $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid()); my $rc=$ndr->try_restore_from_cache('contact',$contact->srid(),'info'); if (! defined $rc) { $rc=$ndr->process('contact','info',[$contact,$ep]); } return $rc; } sub contact_check { my ($self,$ndr,$contact,$ep)=@_; $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid()); my $rc=$ndr->try_restore_from_cache('contact',$contact->srid(),'check'); if (! defined $rc) { $rc=$ndr->process('contact','check',[$contact,$ep]); } return $rc; } sub contact_check_multi { my ($self,$ndr,@r)=@_; my $ep; $ep=pop(@r) if ($r[-1] && (ref($r[-1]) eq 'HASH')); my ($rc,@c); foreach my $contact (@r) { $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid()); $rc=$ndr->try_restore_from_cache('contact',$contact->srid(),'check'); if (! defined $rc) { push @c,$contact; } } if (@c) { if ($ndr->protocol()->has_action('contact','check_multi')) { $rc=$ndr->process('contact','check_multi',[\@c,$ep]); } else { foreach my $c (@c) { $rc=$ndr->process('contact','check',[$c,$ep]); } } } return $rc; ## see comment in domain_check_multi } sub contact_exist ## 1/0/undef { my ($self,$ndr,$contact,$ep)=@_; $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid()); my $rc=$ndr->contact_check($contact,$ep); return unless $rc->is_success(); return $ndr->get_info('exist'); } sub contact_update { my ($self,$ndr,$contact,$tochange,$ep)=@_; $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid()); Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes'); my $fp=$ndr->protocol->nameversion(); foreach my $t ($tochange->types()) { Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of contact_update/'.$t) unless $ndr->protocol_capable('contact_update',$t); my $add=$tochange->add($t); my $del=$tochange->del($t); my $set=$tochange->set($t); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of contact_update/'.$t.' (add)') if (defined($add) && ! $ndr->protocol_capable('contact_update',$t,'add')); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of contact_update/'.$t.' (del)') if (defined($del) && ! $ndr->protocol_capable('contact_update',$t,'del')); Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of contact_update/'.$t.' (set)') if (defined($set) && ! $ndr->protocol_capable('contact_update',$t,'set')); } foreach ($tochange->all_defined('status')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::StatusList'); } my $rc=$ndr->process('contact','update',[$contact,$tochange,$ep]); return $rc; } sub contact_update_status_add { my ($self,$ndr,$contact,$s,$ep)=@_; return $self->contact_update_status($ndr,$contact,$s,$ndr->local_object('status'),$ep); } sub contact_update_status_del { my ($self,$ndr,$contact,$s,$ep)=@_; return $self->contact_update_status($ndr,$contact,$ndr->local_object('status'),$s,$ep); } sub contact_update_status_set { my ($self,$ndr,$contact,$s,$ep)=@_; return $self->contact_update_status($ndr,$contact,$s,undef,$ep); } sub contact_update_status { my ($self,$ndr,$contact,$sadd,$sdel,$ep)=@_; Net::DRI::Util::check_isa($sadd,'Net::DRI::Data::StatusList'); if (defined($sdel)) ## add + del { Net::DRI::Util::check_isa($sdel,'Net::DRI::Data::StatusList'); my $c=$ndr->local_object('changes'); $c->add('status',$sadd) unless ($sadd->is_empty()); $c->del('status',$sdel) unless ($sdel->is_empty()); return $self->contact_update($ndr,$contact,$c,$ep); } else { return $self->contact_update($ndr,$contact,$ndr->local_object('changes')->set('status',$sadd),$ep); } } sub contact_transfer { my ($self,$ndr,$contact,$op,$ep)=@_; $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid()); Net::DRI::Exception::usererr_invalid_parameters('Transfer operation must be start,stop,accept,refuse or query') unless ($op=~m/^(?:start|stop|query|accept|refuse)$/); my $rc; if ($op eq 'start') { $rc=$ndr->process('contact','transfer_request',[$contact,$ep]); } elsif ($op eq 'stop') { $rc=$ndr->process('contact','transfer_cancel',[$contact,$ep]); } elsif ($op eq 'query') { $rc=$ndr->process('contact','transfer_query',[$contact,$ep]); } else ## accept/refuse { $rc=$ndr->process('contact','transfer_answer',[$contact,($op eq 'accept')? 1 : 0,$ep]); } return $rc; } sub contact_transfer_start { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'start',$ep); } sub contact_transfer_stop { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'stop',$ep); } sub contact_transfer_query { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'query',$ep); } sub contact_transfer_accept { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'accept',$ep); } sub contact_transfer_refuse { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'refuse',$ep); } sub contact_current_status { my ($self,$ndr,$contact,$ep)=@_; my $rc=$self->contact_info($ndr,$contact,$ep); return unless $rc->is_success(); my $s=$ndr->get_info('status'); return unless Net::DRI::Util::isa_statuslist($s); return $s; } sub contact_is_mine { my ($self,$ndr,$contact,$ep)=@_; my $clid=$self->info('clid'); return 0 unless defined($clid); my $id; eval { my $rc=$self->contact_info($ndr,$contact,$ep); $id=$ndr->get_info('clID') if ($rc->is_success()); }; return 0 unless (!$@ && defined($id)); return ($clid=~m/^${id}$/)? 1 : 0; } #################################################################################################### ## Message commands (like POLL in EPP) #################################################################################################### sub message_retrieve { my ($self,$ndr,$id)=@_; my $rc=$ndr->process('message','retrieve',[$id]); return $rc; } sub message_delete { my ($self,$ndr,$id)=@_; my $rc=$ndr->process('message','delete',[$id]); return $rc; } sub message_waiting { my ($self,$ndr)=@_; my $c=$self->message_count($ndr); return (defined($c) && $c)? 1 : 0; } sub message_count { my ($self,$ndr)=@_; my $count=$ndr->get_info('count','message','info'); return $count if defined($count); my $rc=$ndr->process('message','retrieve'); return unless $rc->is_success(); $count=$ndr->get_info('count','message','info'); return (defined($count) && $count)? $count : 0; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/0002755000175000017500000000000011352534417015260 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Data/ContactSet.pm0000644000175000017500000001411711352534377017674 0ustar patrickpatrick## Domain Registry Interface, Stores ordered list of contacts + type (registrant, admin, tech, bill, etc...) ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::ContactSet; use strict; use warnings; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Data::ContactSet - Handle an ordered collection of contacts for Net::DRI =head1 DESCRIPTION This class encapsulates a set of contacts, with associated types. For each type, it can stores as many contacts as needed. Contacts are compared among themselves by calling the id() method on them. Thus all Contact classes must define such a method, which returns a string. =head1 METHODS =head2 new() creates a new object =head2 types() returns the list of current types stored in this class =head2 has_type() returns 1 if the given type as first argument has some contacts in this object, 0 otherwise =head2 add() with the first argument being a contact, and the second (optional) a type, adds the contact to the list of contacts for this type or all types (if no second argument). If the contact already exists (same id()), it will be replaced when found. Returns the object itself. =head2 del() the opposite of add() =head2 rem() alias for del() =head2 clear() removes all contact currently associated to all types =head2 set() with an array ref as first argument, and a type (optional) as second, set the current list of the given type (or all types) to be the list of contacts in first argument. Returns the object itself. =head2 get() returns list (in list context) or first element of list (in scalar context) for the type given as argument =head2 get_all() returns list of contacts, without duplicates, for all types =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ################################################################################################################ sub new { my $class=shift; my $self={ c => {} }; bless($self,$class); return $self; } sub types { my ($self)=@_; return sort(grep { @{$self->{c}->{$_}} } keys(%{$self->{c}})); } sub has_type { my ($self,$ctype)=@_; return 0 unless defined($ctype); return exists($self->{c}->{$ctype}); } sub is_empty { my $self=shift; my @a=$self->types(); return (@a)? 0 : 1; } sub _pos { my ($self,$t,$id)=@_; my $c=$self->{c}; my $l=$#{$c->{$t}}; my @p=grep { my $i=$c->{$t}->[$_]->id(); (defined($i) && ($i eq $id))? 1 : 0 } (0..$l); return $p[0] if @p; return; } sub add { my ($self,$cobj,$ctype)=@_; return unless defined($cobj); my $c=$self->{c}; $c->{$ctype}=[] if (defined($ctype) && !exists($c->{$ctype})); my $id=$cobj->id(); foreach my $k (keys(%$c)) { next if (defined($ctype) && ($k ne $ctype)); if ($id) { my $p=$self->_pos($k,$id); if (defined($p)) { $c->{$k}->[$p]=$cobj; next; } } push @{$c->{$k}},$cobj; } return $self; } sub del { my ($self,$cobj,$ctype)=@_; return unless defined($ctype); my $c=$self->{c}; return if (defined($ctype) && !exists($c->{$ctype})); my $id=$cobj->id(); return unless $id; foreach my $k (keys(%$c)) { next if (defined($ctype) && ($k ne $ctype)); my $p=$self->_pos($k,$id); next unless defined($p); splice(@{$c->{$k}},$p,1); } return $self; } sub rem { return shift->del(@_); } sub clear { my ($self,$ctype)=@_; return $self->set($ctype,[]); } sub set { my ($self,$robj,$ctype)=@_; return unless defined($robj); my $c=$self->{c}; $c->{$ctype}=[] if (defined($ctype) && !exists($c->{$ctype})); foreach my $k (keys(%$c)) { next if (defined($ctype) && ($k ne $ctype)); $c->{$k}=(ref($robj) eq 'ARRAY')? $robj : [$robj]; } return $self; } sub get { my ($self,$ctype)=@_; return unless defined($ctype); my $c=$self->{c}; return unless exists($c->{$ctype}); return wantarray()? @{$c->{$ctype}} : $c->{$ctype}->[0]; } sub get_all { my ($self)=@_; my %r=map { $_ => 1 } map { @{$_} } values(%{$self->{c}}); return keys %r; } sub match ## compare two contact lists { my ($self,$other)=@_; return 0 unless (defined($other) && (ref($other) eq ref($self))); my $c1=$self->{c}; my $c2=$other->{c}; return 0 unless (keys(%$c1)==keys(%$c2)); return 0 if grep { ! exists($c1->{$_}) } keys(%$c2); return 0 if grep { ! exists($c2->{$_}) } keys(%$c1); foreach my $k (keys(%$c1)) { my %tmp1=map { $_->id() => 1 } @{$c1->{$k}}; my %tmp2=map { $_->id() => 1 } @{$c2->{$k}}; return 0 if grep { ! exists($tmp2{$_}) } keys(%tmp1); return 0 if grep { ! exists($tmp1{$_}) } keys(%tmp2); } return 1; } sub has_contact { my ($self,$cobj,$ctype)=@_; return 0 unless defined($cobj); my $c=$self->{c}; return 0 if (defined($ctype) && !exists($c->{$ctype})); my $id=(ref($cobj))? $cobj->id() : $cobj; return 0 unless (defined($id) && $id); foreach my $k (keys(%$c)) { next if (defined($ctype) && ($k ne $ctype)); return 1 if defined($self->_pos($k,$id)); } return 0; } ############################################################################## 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact.pm0000644000175000017500000002442111352534377017217 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact; use strict; use warnings; use base qw(Class::Accessor::Chained); ## provides a new() method our @ATTRS=qw(name org street city sp pc cc email voice fax loid roid srid auth disclose); __PACKAGE__->register_attributes(@ATTRS); use Net::DRI::Exception; use Net::DRI::Util; use Email::Valid; use Encode (); ## we need here direct use of Encode, not through Net::DRI::Util::encode_* as we need the default substitution for unknown data our $VERSION=do { my @r=(q$Revision: 1.14 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Data::Contact - Handle contact data, modeled from EPP for Net::DRI =head1 DESCRIPTION This base class encapsulates all data for a contact as defined in EPP (RFC4933). It can (and should) be subclassed for TLDs needing to store other data for a contact. All subclasses must have a validate() method that takes care of verifying contact data, and an id() method returning an opaque value, unique per contact (in a given registry). The following methods are both accessors and mutators : as mutators, they can be called in chain, as they all return the object itself. Postal information through name() org() street() city() sp() pc() cc() can be provided twice. EPP allows a localized form (content is in unrestricted UTF-8) and internationalized form (content MUST be represented in a subset of UTF-8 that can be represented in the 7-bit US-ASCII character set). Not all registries support both forms. When setting values, you pass one element if both forms are equal or two elements as a list (first the localized form, then the internationalized one). When getting values, in list context you get back both values, in scalar context you get back the first one, that is the localized form. You can also use methods int2loc() and loc2int() to create one version from the other. =head1 METHODS =head2 loid() local object ID for this contact, never sent to registry (can be used to track the local db id of this object) =head2 srid() server ID, ID of the object as known by the registry in which it was created =head2 id() an alias (needed for Net::DRI::Data::ContactSet) of the previous method =head2 roid() registry/remote object id (internal to a registry) =head2 name() name of the contact =head2 org() organization of the contact =head2 street() street address of the contact (ref array of up to 3 elements) =head2 city() city of the contact =head2 sp() state/province of the contact =head2 pc() postal code of the contact =head2 cc() alpha2 country code of the contact (will be verified against list of valid country codes) =head2 email() email address of the contact =head2 voice() voice number of the contact (in the form +CC.NNNNNNNNxEEE) =head2 fax() fax number of the contact (same form as above) =head2 auth() authentification for this contact (hash ref with a key 'pw' and a value being the password) =head2 disclose() privacy settings related to this contact (see RFC) =head2 int2loc() create the localized part from the internationalized part ; existing internationalized data is overwritten =head2 loc2int() create the internationalized part from the localized part ; existing localized data is overwritten ; as the internationalized part must be a subset of UTF-8 when the localized one can be the full UTF-8, this operation may creates undefined characters (?) as result =head2 as_string() return a string formed with all data contained in this contact object ; this is mostly useful for debugging and logging, this string should not be parsed as its format is not guaranteed to remain stable, you should use the above accessors =head2 attributes() return an array of attributes name available in this contact object (taking into account any subclass specific attribute) =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### ## Needed for ContactSet sub id { return shift->srid(@_); } sub register_attributes { my $class=shift; my @a=@_; __PACKAGE__->mk_accessors(@a); no strict 'refs'; ## no critic (ProhibitNoStrict) ${$class.'::ATTRS'}=($class eq 'Net::DRI::Data::Contact')? \@a : [ @ATTRS,@a ]; ${$class.'::ATTRS'}; } sub attributes { my $class=shift; $class=ref($class) || $class; no strict 'refs'; ## no critic (ProhibitNoStrict) return @{${$class.'::ATTRS'}}; } ## Overrides method in Class::Accessor, needed for int/loc data sub get { my ($self,$what)=@_; return unless defined($what) && $what && exists($self->{$what}); my $d=$self->{$what}; return $d unless ($what=~m/^(name|org|street|city|sp|pc|cc)$/); if ($what eq 'street') ## special case because it is always a ref array { return $d if !ref($d); ## should not happen, since it is either a ref array of up to 3 elements, or a ref array of two such ref arrays return $d if !ref($d->[0]); } else { return $d if !ref($d); } return wantarray()? @$d : $d->[0]; } sub loc2int { my $self=shift; foreach my $f (qw/name org city sp pc cc/) { my @c=$self->$f(); $c[1]=defined($c[0])? Encode::encode('ascii',$c[0],0) : undef; $self->$f(@c); } my @c=$self->street(); $c[1]=[ map { defined($_)? Encode::encode('ascii',$_,0) : undef } defined($c[0])? @{$c[0]} : () ]; $c[0]=[] unless defined $c[0]; $self->street(@c); return $self; } sub int2loc { my $self=shift; foreach my $f (qw/name org street city sp pc cc/) { my @c=$self->$f(); $c[0]=$c[1]; ## internationalized form is a subset of UTF-8 and localized form is full UTF-8 $self->$f(@c); } return $self; } sub has_loc { return shift->_has(0); } sub has_int { return shift->_has(1); } sub _has { my ($self,$pos)=@_; my @d=map { ($self->$_())[$pos] } qw/name org city sp pc cc/; my $s=($self->street())[$pos]; push @d,@$s if (defined($s) && ref($s)); return (grep { defined } @d)? 1 : 0; } sub validate ## See RFC4933,§4 { my ($self,$change)=@_; $change||=0; my @errs; if (!$change) { my @missing=grep { my $r=scalar $self->$_(); (defined $r && length $r)? 0 : 1 } qw/name city cc email auth srid/; Net::DRI::Exception::usererr_insufficient_parameters('Mandatory contact information missing: '.join('/',@missing)) if @missing; push @errs,'srid' unless Net::DRI::Util::xml_is_token($self->srid(),3,16); } push @errs,'srid' if ($self->srid() && ! Net::DRI::Util::xml_is_token($self->srid(),3,16)); push @errs,'name' if ($self->name() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->name())); push @errs,'org' if ($self->org() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } ($self->org())); my @rs=($self->street()); foreach my $i (0,1) { next unless $rs[$i]; push @errs,'street' if ((ref($rs[$i]) ne 'ARRAY') || (@{$rs[$i]} > 3) || (grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } @{$rs[$i]})); } push @errs,'city' if ($self->city() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->city())); push @errs,'sp' if ($self->sp() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } ($self->sp())); push @errs,'pc' if ($self->pc() && grep { !Net::DRI::Util::xml_is_token($_,undef,16) } ($self->pc())); push @errs,'cc' if ($self->cc() && grep { !Net::DRI::Util::xml_is_token($_,2,2) } ($self->cc())); push @errs,'cc' if ($self->cc() && grep { !exists($Net::DRI::Util::CCA2{uc($_)}) } ($self->cc())); push @errs,'voice' if ($self->voice() && ! ($self->voice()=~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/)); push @errs,'fax' if ($self->fax() && ! ($self->fax()=~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/)); push @errs,'email' if ($self->email() && ! (Net::DRI::Util::xml_is_token($self->email(),1,undef) && Email::Valid->rfc822($self->email()))); my $ra=$self->auth(); push @errs,'auth' if ($ra && (ref($ra) eq 'HASH') && exists($ra->{pw}) && !Net::DRI::Util::xml_is_normalizedstring($ra->{pw})); ## Nothing checked for disclose Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub as_string { my ($self,$sep)=@_; $sep='|' unless (defined($sep) && $sep); my $st=$self->street(); my @v=grep { defined } ($self->srid(),$self->name(),$self->org(),defined($st)? join(' // ',@$st) : undef,$self->city(),$self->sp(),$self->pc(),$self->cc(),$self->voice(),$self->fax(),$self->email()); my @ot=grep { ! /^(?:name|org|street|city|sp|pc|cc|email|voice|fax|loid|roid|srid|auth|disclose)$/ } sort(keys(%$self)); foreach my $ot (@ot) ## extra attributes defined in subclasses { my $v=$self->$ot(); next unless defined($v); if (ref($v) eq 'HASH') { my @iv=sort(keys(%$v)); my @r; foreach my $k (@iv) { push @r,sprintf('%s.%s=%s',$ot,$k,defined($v->{$k})? $v->{$k} : ''); } push @v,join(' ',@r); } else { push @v,$ot.'='.$v; } } my $c=ref($self); $c=~s/^Net::DRI::Data:://; return '('.$c.') '.join($sep,@v); } sub clone { my ($self)=@_; my $new=Net::DRI::Util::deepcopy($self); return $new; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/0002755000175000017500000000000011352534417016653 5ustar patrickpatrickNet-DRI-0.96/lib/Net/DRI/Data/Contact/AT.pm0000644000175000017500000001174611352534377017531 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .AT ## Contributed by Michael Braunoeder from NIC.AT ## ## Copyright (c) 2006,2008-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::AT; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(type)); =pod =head1 NAME Net::DRI::Data::Contact::AT - Handle .AT contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .AT specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 type() type of contact : privateperson, organisation or role (mandatory) ; the registry may also return unspecified =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; if (!$change) { Net::DRI::Exception::usererr_insufficient_parameters('Invalid contact information: name/city/cc/email/auth/srid mandatory') unless (scalar(($self->name())[1]) && scalar(($self->city())[1]) && scalar(($self->cc())[1]) && $self->email() && $self->auth() && $self->srid()); push @errs,'srid' unless Net::DRI::Util::xml_is_token($self->srid(),3,16); Net::DRI::Exception::usererr_insufficient_parameters('Invalid contact information: type mandatory') unless ($self->type()); } push @errs,'srid' if ($self->srid() && $self->srid()!~m/^\w{1,80}-\w{1,8}$/ && $self->srid()!~m/^AUTO$/i); ## \w includes _ in Perl push @errs,'name' if ($self->name() && !Net::DRI::Util::xml_is_normalizedstring(($self->name())[1],1,255)); push @errs,'org' if ($self->org() && !Net::DRI::Util::xml_is_normalizedstring(($self->org())[1],undef,255)); my @rs=($self->street()); if ($rs[1]) { push @errs,'street' if ((ref($rs[1]) ne 'ARRAY') || (@{$rs[1]} > 3) || (grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } @{$rs[1]})); } push @errs,'city' if ($self->city() && !Net::DRI::Util::xml_is_normalizedstring(($self->city())[1],1,255)); push @errs,'sp' if ($self->sp() && !Net::DRI::Util::xml_is_normalizedstring(($self->sp())[1],undef,255)); push @errs,'pc' if ($self->pc() && !Net::DRI::Util::xml_is_token(($self->pc())[1],1,16)); push @errs,'cc' if ($self->cc() && !Net::DRI::Util::xml_is_token(($self->cc())[1],2,2)); push @errs,'cc' if ($self->cc() && grep { !exists($Net::DRI::Util::CCA2{uc($_)}) } ($self->cc())); push @errs,'voice' if ($self->voice() && (!Net::DRI::Util::xml_is_token($self->voice(),undef,17) || $self->voice()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/)); push @errs,'fax' if ($self->fax() && (!Net::DRI::Util::xml_is_token($self->fax(),undef,16) || $self->fax()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/)); push @errs,'email' if ($self->email() && (!Net::DRI::Util::xml_is_token($self->email(),1,undef) || !Email::Valid->rfc822($self->email()))); my $ra=$self->auth(); push @errs,'auth' if ($ra && (ref($ra) eq 'HASH') && exists($ra->{pw}) && !Net::DRI::Util::xml_is_normalizedstring($ra->{pw})); push @errs,'type' if ($self->type() && $self->type()!~m/^(?:privateperson|organisation|role)$/); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { my $a=$self->auth(); $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); ## Mandatory in EPP, not used by .AT $self->srid('auto') unless defined($self->srid()); ## we can not choose the ID } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/PL.pm0000644000175000017500000000557011352534377017536 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .PL ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::PL; use strict; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(individual consent_for_publishing)); =pod =head1 NAME Net::DRI::Data::Contact::PL - Handle .PL contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .PL specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 individual() 1 if the object represents a private person, 0 otherwise =head2 consent_for_publishing() 1 if this person gave its assent for publishing personal details in WHOIS database, 0 otherwise. This element has no meaning for a contact which does not represent a private person. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem push @errs,'individual' if (defined($self->individual()) && $self->individual()!~m/^(?:0|1)$/); push @errs,'consent_for_publishing' if (defined($self->consent_for_publishing()) && $self->consent_for_publishing()!~m/^(?:0|1)$/); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/US.pm0000644000175000017500000000575311352534377017555 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .US ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::US; use strict; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(application_purpose nexus_category)); =pod =head1 NAME Net::DRI::Data::Contact::US - Handle .US contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .US specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. They are needed only for registrant contacts. =head2 application_purpose() intended usage for the domain name =head2 nexus_category() the nexus cateogry =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem if (defined($self->application_purpose())) { push @errs,'application_purpose' unless ($self->application_purpose()=~m/^P[1-5]$/ || ($change && ($self->application_purpose() eq ''))); } if (defined($self->nexus_category())) { push @errs,'nexus_category' unless ($self->nexus_category()=~m!^C(?:1[12]|21|3[12]/([A-Z][A-Z]))$! || ($change && ($self->nexus_category() eq ''))); push @errs,'nexus_category' if ($1 && !exists($Net::DRI::Util::CCA2{$1})); } Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/FCCN.pm0000644000175000017500000000650711352534377017735 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .PT ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::FCCN; use strict; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(type identification mobile)); =pod =head1 NAME Net::DRI::Data::Contact::FCCN - Handle FCCN (.PT) contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .PT specific data. =head1 METHODS The following mutators can be called in chain, as they all return the object itself. =head2 type() type of contact (individual or organization) =head2 identification() formal identification of the contact =head2 mobile() mobile number of the contact =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem if (!$change) { Net::DRI::Exception::usererr_insufficient_parameters('type is mandatory') unless $self->type(); Net::DRI::Exception::usererr_insufficient_parameters('identification is mandatory') unless ($self->identification() && Net::DRI::Util::has_key($self->identification(),'type') && Net::DRI::Util::has_key($self->identification(),'value')); } push @errs,'type' if ($self->type() && $self->type()!~m/^(?:individual|organization)$/); push @errs,'identification' if ($self->identification() && (($self->identification()->{type}!~m/^(?:010|020|030|040|110)$/) || (! Net::DRI::Util::xml_is_token($self->identification()->{value},1,20)))); push @errs,'mobile' if ($self->mobile() && !Net::DRI::Util::xml_is_token($self->mobile(),undef,17) && $self->mobile()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/AERO.pm0000644000175000017500000000415211352534377017744 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .AERO ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::AERO; use strict; use base qw/Net::DRI::Data::Contact/; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(ens)); =pod =head1 NAME Net::DRI::Data::Contact::AERO - Handle .AERO contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .AERO specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 ens() stores extended ENS contact information, as a ref hash =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/ARNES.pm0000644000175000017500000000533611352534377020073 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .SI ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::ARNES; use strict; use base qw/Net::DRI::Data::Contact/; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(maticna emso)); =pod =head1 NAME Net::DRI::Data::Contact::ARNES - Handle .SI contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .SI specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 maticna() stores maticna stevilka (organization id) =head2 emso() stores EMSO (individual id) =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem push @errs,'maticna' if ($self->maticna() && $self->maticna()!~m/^\d{10}$/); push @errs,'emso' if ($self->emso() && $self->emso()!~m/^\d{13}$/); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { $self->srid('auto') unless defined($self->srid()); ## we can not choose the ID } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/NO.pm0000644000175000017500000002470111352534377017534 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .NO ## ## Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, ## Trond Haugen Einfo@norid.noE. ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ############################################################################### package Net::DRI::Data::Contact::NO; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Email::Valid; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION = do { my @r = ( q$Revision: 1.5 $ =~ /\d+/gmx ); sprintf( "%d" . ".%02d" x $#r, @r ); }; __PACKAGE__->register_attributes(qw(type identity mobilephone organization rolecontact xemail xdisclose facets)); =pod =head1 NAME Net::DRI::Data::Contact::NO - Handle .NO contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .NO specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 type() Mandatory, must be set for all contacts. Specify what type of contact to register. Value must be one of: 'person', 'organization' or 'role'. Example: $co->type('organization') =head2 identity() Currently valid for type='organization' only. Must then be set to specify the organization number in Brønnøysund, the Norwegian Business Register. Example: $co->identity({type=>'organizationNumber', value=>'987654321'}); =head2 mobilephone() Optional. Set a mobile phone number for the contact. Example: $co->mobilephone('+47.123456780') =head2 organization() Optional. Set one or more organization-elements which specify organizations which the contact belongs to. The value should be the local contact id of an organization object. This element can only be used for role and person contacts. $co->organization('EFA12O'); =head2 rolecontact() Optional. Set one or more roleContact-elements which specify persons which belongs to a role contact. The value should be the local contact id of a person object. This element can only be used for role contacts. Example: $co->rolecontact(['JD12P', 'JD13P']); =head2 xemail() Optional. Set one or more email-elements which specify email addresses in addition to the mandatory email element in the standard contact create command. Example: $co->xemail(['xtra1@example.no', 'xtra2@example.no']); =head2 xdisclose() Optional. A disclose-element which must contain the child element mobilePhone. This element notes the clients preference to allow or restrict disclosure of the mobile phone number. If not present, the servers stated data collection policy is used. Example: $co->xdisclose({mobilePhone=>0}); =head2 facets() Facets are some special control attributes that can be used to implement a super registrar (admin registrar). A super registrar can suppress certain checks and perform actions on behalf of a normal registrar. Facets are key/values pairs. Net::DRI will not try to enforce what key/value pairs that are possible, but let the registry decide their validity. Example: $co->facets( { 'skip-manual-review' => 1, 'ignores-exceptions' => 'reg123'} ); =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Trond Haugen, Einfo@norid.noE. =head1 COPYRIGHT Copyright (c) 2008-2010 UNINETT Norid AS, Ehttp://www.norid.noE, Trond Haugen Einfo@norid.noE. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ( $self, $change ) = @_; $change ||= 0; my @errs; if ( !$change ) { Net::DRI::Exception::usererr_insufficient_parameters( 'Invalid contact information: name/city/cc/email/auth/srid mandatory' ) unless $self->name() && $self->city() && $self->cc() && $self->email() && $self->auth() && $self->srid(); Net::DRI::Exception::usererr_insufficient_parameters( 'Invalid contact information: org is not allowed for .NO') if ( $self->org() ); Net::DRI::Exception::usererr_insufficient_parameters( 'Invalid contact information: type mandatory') unless ( $self->type() ); } push @errs,'srid' if ($self->srid() && ! Net::DRI::Util::xml_is_token($self->srid(),3,16)); push @errs, 'name' if ( $self->name() && grep { !Net::DRI::Util::xml_is_normalizedstring( $_, 1, 255 ) } ( $self->name() ) ); push @errs, 'org' if ( $self->org() && grep { !Net::DRI::Util::xml_is_normalizedstring( $_, undef, 255 ) } ( $self->org() ) ); my @rs = ( $self->street() ); foreach my $i ( 0, 1 ) { next unless $rs[$i]; push @errs, 'street' if ( ( ref( $rs[$i] ) ne 'ARRAY' ) || ( @{ $rs[$i] } > 3 ) || ( grep { !Net::DRI::Util::xml_is_normalizedstring( $_, undef, 255 ) } @{ $rs[$i] } ) ); } push @errs, 'city' if ( $self->city() && grep { !Net::DRI::Util::xml_is_normalizedstring( $_, 1, 255 ) } ( $self->city() ) ); push @errs, 'sp' if ( $self->sp() && grep { !Net::DRI::Util::xml_is_normalizedstring( $_, undef, 255 ) } ( $self->sp() ) ); push @errs, 'pc' if ( $self->pc() && grep { !Net::DRI::Util::xml_is_token( $_, undef, 16 ) } ( $self->pc() ) ); push @errs, 'cc' if ( $self->cc() && grep { !Net::DRI::Util::xml_is_token( $_, 2, 2 ) } ( $self->cc() ) ); push @errs, 'cc' if ( $self->cc() && grep { !exists( $Net::DRI::Util::CCA2{ uc($_) } ) } ( $self->cc() ) ); push @errs, 'voice' if ( $self->voice() && !Net::DRI::Util::xml_is_token( $self->voice(), undef, 17 ) && $self->voice() !~ m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/mx ); push @errs, 'fax' if ( $self->fax() && !Net::DRI::Util::xml_is_token( $self->fax(), undef, 17 ) && $self->fax() !~ m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/mx ); push @errs, 'email' if ( $self->email() && !( Net::DRI::Util::xml_is_token( $self->email(), 1, undef ) && Email::Valid->rfc822( $self->email() ) ) ); my $ra = $self->auth(); push @errs, 'auth' if ( $ra && ( ref($ra) eq 'HASH' ) && exists( $ra->{pw} ) && !Net::DRI::Util::xml_is_normalizedstring( $ra->{pw} ) ); # .NO my $t = $self->type(); push @errs, 'type' if ( $t && $t !~ m/^(?:person|organization|role)$/mx ); $t = $self->identity(); if ($t) { my $ty = $t->{type}; my $va = $t->{value}; push @errs, 'identity type' if ( $ty && $ty !~ m/^(?:organizationNumber|localIdentity|nationalIdentityNumber)$/mx ); # let the server handle further validation of what identity syntax # and values are legal } $t = $self->mobilephone(); push @errs, 'mobilephone' if ( $t && !Net::DRI::Util::xml_is_token( $t, undef, 17 ) && $t !~ m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/mx ); # foreach my $el ( 'organization', 'rolecontact', 'xemail' ) { if ( $t = $self->$el() ) { # option, as scalar or array my @em; my $er; if ($change) { if ( ref($t) eq 'HASH' ) { foreach my $s ( 'add', 'del' ) { my $e = $t->{$s}; if ( ref($e) eq 'ARRAY' ) { push @em, @$e if (@$e); } else { push @em, $e if ($e); } } } else { $er .= ":update needs an add/del hash:"; } } else { if ( ref($t) eq 'ARRAY' ) { push @em, @$t if (@$t); } else { push @em, $t if ($t); } } foreach my $e (@em) { if ( $el eq 'xemail' ) { $er .= " $e " if ( $e && !( Net::DRI::Util::xml_is_token( $e, 1, undef ) && Email::Valid->rfc822($e) ) ); } else { $er .= " $e " if ( $e && !Net::DRI::Util::xml_is_token( $e, 3, 16 ) ); } push @errs, "xemail:$er" if ($er); } } } ## Check that xdisclose only contains mobilePhone if ( my $d = $self->xdisclose() ) { unless ( $d && ( ref($d) eq 'HASH' ) && ( scalar( keys(%$d) ) == 1 ) && ( $d->{mobilePhone} == 1 || $d->{mobilePhone} == 0 ) ) { push @errs, 'xdisclose'; } } Net::DRI::Exception::usererr_invalid_parameters( 'Invalid contact information: ' . join( '/', @errs ) ) if @errs; return 1; ## everything ok. } sub init { my ( $self, $what, $ndr ) = @_; if ( $what eq 'create' ) { my $a = $self->auth(); $self->auth( { pw => '' } ) unless ( $a && ( ref($a) eq 'HASH' ) && exists( $a->{pw} ) ) ; ## Mandatory in EPP $self->srid('auto') unless defined( $self->srid() ); ## we can not choose the ID } return; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/COOP.pm0000644000175000017500000000677711352534377017775 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .COOP ## ## Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::COOP; use strict; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(sponsors state lang mailing_list)); =pod =head1 NAME Net::DRI::Data::Contact::COOP - Handle .COOP contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .COOP specific data. Organizations must have names and phone numbers. Contact ids must begin with a prefix given by the registry (tied to the registrar account). If you specify a localized version for data, you need the internationalized version also (see documentation of Net::DRI::Data::Contact and its loc2int method) ; you can however specify just internationalized data, without a localized version. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 sponsors() list of sponsors as registry contact ids (mandatory for registrants, at least 2) =head2 state() verification state : verified, pendingVerification, ableToApeal, underInvestigation, refused =head2 lang() language of contact =head2 mailing_list() boolean showing opt-in status of contact for .COOP newsletters =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem if ($self->sponsors()) { foreach my $id (ref($self->sponsors())? @{$self->sponsors()} : ($self->sponsors())) { next if Net::DRI::Util::xml_is_token($id,3,16); ## clIDType push @errs,'sponsors'; last; } } push @errs,'lang' if ($self->lang() && !Net::DRI::Util::xml_is_language($self->lang())); push @errs,'mailing_list' if ($self->mailing_list() && !Net::DRI::Util::xml_is_boolean($self->mailing_list())); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/CAT.pm0000644000175000017500000000627611352534377017636 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .CAT ## ## Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::CAT; use strict; use base qw/Net::DRI::Data::Contact/; use Email::Valid; use Net::DRI::Util; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(lang email_sponsor maintainer)); =pod =head1 NAME Net::DRI::Data::Contact::CAT - Handle .CAT contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .CAT specific data. .CAT uses only localized data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 lang() optional language of contact, according to RFC3066 =head2 maintainer() optional free-form element that is published in whois =head2 email_sponsor() e-mail address to use when participating in the community sponsoring model of the puntCAT registry ; may be identical to the primary e-mail address =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem push @errs,'lang' if ($self->lang() && !Net::DRI::Util::xml_is_language($self->lang())); push @errs,'maintainer' if ($self->maintainer() && !Net::DRI::Util::xml_is_token($self->maintainer(),undef,128)); push @errs,'email_sponsor' if ($self->email_sponsor() && !Net::DRI::Util::xml_is_token($self->email_sponsor(),1,undef) && !Email::Valid->rfc822($self->email_sponsor())); push @errs,'srid' if ($self->srid() && $self->srid()=~m/^REG-/); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/Nominet.pm0000644000175000017500000001135011352534377020625 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for Nominet (.UK) ## ## Copyright (c) 2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::Nominet; use strict; use base qw(Net::DRI::Data::Contact); use Email::Valid; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(type co_no opt_out mobile)); =pod =head1 NAME Net::DRI::Data::Contact::Nominet - Handle .UK contact data for Net::DRI =head1 DESCRIPTION Please refer to Net::DRI::Data::Contact for core methods and http://www.nominet.org.uk/registrars/systems/data/fields/ for registry extra data =head1 METHODS =head2 type() (registrant contact only) describes what type of organisation the domain name has been registered for ; see http://www.nominet.org.uk/registrars/systems/data/regtype/ =head2 co_no() (registrant contact only) registered number of the company or organisation =head2 opt_out() (registrant contact only) do not display address details in whois if yes (Y) =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub roid { return shift->srid(@_); } sub validate { my ($self,$change)=@_; $change||=0; my @errs; if (!$change) { Net::DRI::Exception::usererr_insufficient_parameters('Invalid contact information: name mandatory') unless ($self->name()); } push @errs,'srid' if (defined($self->srid()) && $change && $self->srid()!~m/^C?\d+(?:-UK)?$/); ## C for contacts, nothing for registrant/account push @errs,'name' if (defined($self->name()) && !Net::DRI::Util::xml_is_token($self->name(),1,255)); push @errs,'org' if (defined($self->org()) && !Net::DRI::Util::xml_is_token($self->org(),1,255)); ## See http://www.nominet.org.uk/registrars/systems/data/regtype/ push @errs,'type' if (defined($self->type()) && $self->type()!~m/^(?:LTD|PLC|IND|FIND|RCHAR|SCH|LLP|STRA|PTNR|GOV|CRC|STAT|FCORP|IP|FOTHER|OTHER|UNKNOWN)$/); push @errs,'co_no' if (defined($self->co_no()) && !Net::DRI::Util::xml_is_token($self->co_no(),undef,255)); ## TO FIX : co_no is mandatory for registrations in .net, .ltd and .plc SLDs push @errs,'opt_out' if (defined($self->opt_out()) && $self->opt_out()!~m/^[YN]$/i); push @errs,'voice' if (defined($self->voice()) && !Net::DRI::Util::xml_is_token($self->voice(),undef,17) && $self->voice()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/); push @errs,'fax' if (defined($self->fax()) && !Net::DRI::Util::xml_is_token($self->fax(),undef,17) && $self->fax()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/); push @errs,'mobile' if (defined($self->mobile()) && !Net::DRI::Util::xml_is_token($self->mobile(),undef,17) && $self->mobile()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/); ## Defined in schema, but not in .UK EPP documentation ! push @errs,'email' if (defined($self->email()) && !Net::DRI::Util::xml_is_token($self->email(),1,undef) && !Email::Valid->rfc822($self->email())); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; if (defined($self->type()) && defined($self->opt_out())) { Net::DRI::Exception::usererr_invalid_parameters('opt_out must be N if type is not IND or FIND') if ($self->type()!~m/^(?:IND|FIND)$/ && lc($self->opt_out()) ne 'n'); } Net::DRI::Exception::usererr_invalid_parameters('co_no must be defined if type is SCH') if (defined($self->type()) && $self->type() eq 'SCH' && !defined($self->co_no())); return 1; ## everything ok. } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/SWITCH.pm0000644000175000017500000001102111352534377020210 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .CH/.LI ## ## Copyright (c) 2008,2009 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::SWITCH; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; use Net::DRI::Util; use Email::Valid; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Data::Contact::SWITCH - Handle .CH/.LI contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .CH/.LI specific data. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://oss.bsdprojects.net/projects/netdri/ or http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Tonnerre Lombard, Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; if (!$change) { Net::DRI::Exception::usererr_insufficient_parameters('Invalid contact information: name/city/cc/email/srid mandatory') unless (scalar(($self->name())[1]) && scalar(($self->city())[1]) && scalar(($self->cc())[1]) && $self->email() && $self->srid()); push @errs,'srid' unless Net::DRI::Util::xml_is_token($self->srid(),3,16); } push @errs,'srid' if ($self->srid() && $self->srid()!~m/^\w{1,80}-\w{1,8}$/); ## \w includes _ in Perl push @errs,'name' if ($self->name() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->name())); push @errs,'org' if ($self->org() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } ($self->org())); my @rs=($self->street()); foreach my $i (0,1) { next unless $rs[$i]; push @errs,'street' if ((ref($rs[$i]) ne 'ARRAY') || (@{$rs[$i]} > 3) || (grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } @{$rs[$i]})); } push @errs,'city' if ($self->city() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->city())); push @errs,'sp' if ($self->sp() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } ($self->sp())); push @errs,'pc' if ($self->pc() && grep { !Net::DRI::Util::xml_is_token($_,undef,16) } ($self->pc())); push @errs,'cc' if ($self->cc() && grep { !Net::DRI::Util::xml_is_token($_,2,2) } ($self->cc())); push @errs,'cc' if ($self->cc() && grep { !exists($Net::DRI::Util::CCA2{uc($_)}) } ($self->cc())); push @errs,'voice' if ($self->voice() && !Net::DRI::Util::xml_is_token($self->voice(),undef,17) && $self->voice()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/); push @errs,'fax' if ($self->fax() && !Net::DRI::Util::xml_is_token($self->fax(),undef,17) && $self->fax()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/); push @errs,'email' if ($self->email() && !Net::DRI::Util::xml_is_token($self->email(),1,undef) && !Email::Valid->rfc822($self->email())); $self->auth({pw => ''}); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { my $a=$self->auth(); $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); ## Mandatory in EPP, not used by .CH/.LI $self->srid('auto') unless defined($self->srid()); ## we can not choose the ID } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/SE.pm0000644000175000017500000000621511352534377017527 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .SE ## Contributed by Elias Sidenbladh and Ulrich Wisser from NIC SE ## ## Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::SE; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(orgno vatno)); =pod =head1 NAME Net::DRI::Data::Contact::SE - Handle .SE contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .SE specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. The class also have all the accessors/mutators Net::DRI::Data::Contact has. =head2 orgno() Organization registration number for companies or social security number for individuals on the form [] where is the country code and is the organization registration number or the social security number (mandatory) =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; # call parent validate, will trigger an Exception if problem $self->SUPER::validate($change); ## will trigger an Exception if problem # validate our extensions push @errs, 'orgno' if ( $self->orgno() && $self->orgno() !~ m/^\[[A-Z]{2}\]/ ); # throw exception if errors detected Net::DRI::Exception::usererr_invalid_parameters( 'Invalid contact information: ' . join( '/', @errs ) ) if @errs; # done, everything ok return 1; } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { my $a=$self->auth(); $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/JOBS.pm0000644000175000017500000000522011352534377017750 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .JOBS ## ## Copyright (c) 2008 Tonnerre Lombard . ## All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::JOBS; use strict; use base qw/Net::DRI::Data::Contact/; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(jobinfo)); =pod =head1 NAME Net::DRI::Data::Contact::JOBS - Handle .JOBS contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .JOBS specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 jobinfo() Stores the additional .JOBS information. This is a hash possibly containing: =over 4 =item title - The title of the person. =item website - The web site of the company this contact belongs to. =item industry - The type of industry the contact works in; see the .JOBS registrar documentation for possible values. =item admin - Boolean flag to indicate whether or not the contact is administrative. =item member - Boolean flag to indicate whether or not the contact is an association member. =back =head1 SUPPORT For now, support questions should be sent to: Edevelopment@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ or http://oss.bsdprojects.net/projects/netdri/ =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/IT.pm0000644000175000017500000000371311352534377017534 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .IT ## ## Copyright (C) 2009-2010 Tower Technologies. All rights reserved. ## ## This program free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License v2. # # # package Net::DRI::Data::Contact::IT; use strict; use warnings; use base qw / Net::DRI::Data::Contact /; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw/ consent_for_publishing entity_type nationality_code reg_code /); =pod =head1 NAME Net::DRI::Data::Contact::IT - Handle .IT contact data for Net::DRI =head1 SUPPORT For now, support questions should be sent to: Enoc@towertech.itE Please also see the SUPPORT file in the distribution. =head1 AUTHOR Alessandro Zummo, Ea.zummo@towertech.itE =head1 COPYRIGHT Copyright (C) 2009-2010 Tower Technologies. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License v2 as published by the Free Software Foundation. See the LICENSE file that comes with this distribution for more details. =cut sub validate { my ($self, $change) = @_; $change ||= 0; my @errs; $self->SUPER::validate($change); push @errs, 'consent_for_publishing' if defined $self->consent_for_publishing and $self->consent_for_publishing !~m/^(?:0|1)$/; push @errs, 'nationality_code' if defined $self->nationality_code and $self->nationality_code !~m/^[a-zA-Z]{2}$/; push @errs, 'entity_type' if defined $self->entity_type and $self->entity_type !~m/^[1-7]$/; Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: ' . join('/', @errs)) if scalar @errs; return 1; } 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/OpenSRS.pm0000644000175000017500000000603711352534377020513 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for OpenSRS ## ## Copyright (c) 2009 Richard Siddall . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::OpenSRS; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(firstname url)); =pod =head1 NAME Net::DRI::Data::Contact::OpenSRS - Handle OpenSRS contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for OpenSRS specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 firstname() Please note that for OpenSRS data, the name() must be only the lastname, hence this extra firstname() method =head2 lastname() Alias for name() =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Richard Siddall, Enetdri@elirion.net =head1 COPYRIGHT Copyright (c) 2009 Richard Siddall . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem push @errs,'firstname' if ($self->firstname() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->firstname())); push @errs,'voice' if ($self->voice() && !Net::DRI::Util::xml_is_token($self->voice(),undef,17) && $self->voice()!~m/^\+[0-9]{1,3}\.[0-9]{1,12}(?:x\d{1,4})?$/); push @errs,'fax' if ($self->fax() && !Net::DRI::Util::xml_is_token($self->fax(),undef,17) && $self->fax()!~m/^\+[0-9]{1,3}\.[0-9]{1,12}(?:x\d{1.4})?$/); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub lastname { my ($self, $change) = @_; return $self->name($change); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/EURid.pm0000644000175000017500000001061211352534377020164 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for EURid ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::EURid; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Net::DRI::DRD::EURid; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.10 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(type vat lang onhold monitoring_status)); =pod =head1 NAME Net::DRI::Data::Contact::EURid - Handle EURid contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for EURid specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 type() type of contact : billing, tech, registrant or onsite (mandatory) =head2 vat() vat number of contact =head2 lang() language of contact, must be in Europe (mandatory) =head2 onhold() returned by registry during a contact:info operation =head2 monitoring_status() returned by registry during a contact:info operation =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem if (!$change) { Net::DRI::Exception::usererr_insufficient_parameters('Invalid contact information: voice/type/lang mandatory') unless ($self->voice() && $self->type() && $self->lang()); } ## Lower limits than in EPP (other checks already done in superclass) push @errs,'name' if ($self->name() && grep { length($_) > 50 } ($self->name())); push @errs,'org' if ($self->org() && grep { length($_) > 100 } ($self->org())); push @errs,'type' if ($self->type() && $self->type()!~m/^(?:billing|tech|registrant|onsite)$/); push @errs,'vat' if ($self->vat() && !Net::DRI::Util::xml_is_token($self->vat(),1,20)); push @errs,'lang' if ($self->lang() && !exists($Net::DRI::DRD::EURid::LANGA2_EU{lc($self->lang())})); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; ## if eurid:type is billing or tech, contact:org is mandatory Net::DRI::Exception::usererr_insufficient_parameters('Org is mandatory for billing or tech contacts') if ($self->type() && $self->type()=~m/^(?:type|billing)$/ && !$self->org()); Net::DRI::Exception::usererr_insufficient_parameters('Fax is mandatory for billing contacts') if (defined($self->type()) && ($self->type() eq 'billing') && !$self->fax()); ## For registrants, country must be in EU Net::DRI::Exception::usererr_invalid_parameters('Registrant contact must be in EU') if ($self->type() && ($self->type() eq 'registrant') && !exists($Net::DRI::DRD::EURid::CCA2_EU{uc($self->cc())})); return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { my $a=$self->auth(); $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); $self->srid('ABCD') unless defined $self->srid(); ## we can not choose the ID } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/DENIC.pm0000644000175000017500000001072311352534377020041 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .DE ## ## Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::DENIC; use strict; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; use Net::DRI::Util; use Email::Valid; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(type sip remarks)); =pod =head1 NAME Net::DRI::Data::Contact::DENIC - Handle .DE contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .DE specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 type() The type of the contact (Person, Organization, whatever). =head2 sip() The SIP telephone number of the contact. =head2 remarks() Remarks regarding the contact. =head1 SUPPORT For now, support questions should be sent to: Etonnerre.lombard@sygroup.chE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://oss.bsdprojects.net/projects/netdri/ =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate ## See DENIC-11 { my ($self, $change) = @_; $change ||= 0; my @errs; if (!$change) { Net::DRI::Exception::usererr_insufficient_parameters('Invalid contact information: name/city/cc/srid mandatory') unless (scalar($self->name()) && scalar($self->city()) && scalar($self->cc()) && $self->srid()); push @errs,'srid' unless Net::DRI::Util::xml_is_token($self->srid(), 3, 32); } ## TODO: convert that to a test on srid(), testing roid() is useless ## \w includes _ in Perl push(@errs,'roid') if ($self->roid() && $self->roid() !~ m/^\w{1,80}-\w{1,8}$/); push(@errs,'name') if ($self->name() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->name())); push(@errs,'org') if ($self->org() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,255) } ($self->org())); my @rs = ($self->street()); foreach my $i (0,1) { next unless $rs[$i]; push(@errs,'street') if ((ref($rs[$i]) ne 'ARRAY') || (@{$rs[$i]} > 3) || (grep { !Net::DRI::Util::xml_is_normalizedstring($_, undef,255) } @{$rs[$i]})); } push(@errs,'city') if ($self->city() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,1,255) } ($self->city())); push(@errs,'pc') if ($self->pc() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,undef,16) } ($self->pc())); push(@errs,'cc') if ($self->cc() && grep { !Net::DRI::Util::xml_is_normalizedstring($_,2,2) } ($self->cc())); push(@errs,'cc') if ($self->cc() && grep { !exists($Net::DRI::Util::CCA2{uc($_)}) } ($self->cc())); push(@errs,'voice') if ($self->voice() && !Net::DRI::Util::xml_is_token($self->voice(),undef,17) && $self->voice() !~ m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/); push(@errs,'fax') if ($self->fax() && !Net::DRI::Util::xml_is_token($self->fax(),undef,17) && $self->fax() !~ m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/); push(@errs,'email') if ($self->email() && !Net::DRI::Util::xml_is_token($self->email(),1,undef) && !Email::Valid->rfc822($self->email())); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: ' . join('/', @errs)) if (@errs); return 1; ## everything ok. } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/SIDN.pm0000644000175000017500000000711111352534377017751 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for SIDN ## ## Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::SIDN; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(legal_form legal_id limited)); #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; $self->SUPER::validate(1); ## will trigger an Exception if problem if (!$change) { my @missing=grep { my $r=scalar $self->$_(); (defined $r && length $r)? 0 : 1 } qw/legal_form/; Net::DRI::Exception::usererr_insufficient_parameters('Mandatory contact information missing: '.join('/',@missing)) if @missing; } my @errs; push @errs,'legal_form' if (defined $self->legal_form() && $self->legal_form()!~m!^(?:ANDERS|BEG|BRO|BV|BVI/O|COOP|CV|EENMANSZAAK|EESV|KERK|MAATSCHAP|NV|OWM|PERSOON|REDR|STICHTING|VERENIGING|VOF)$!o); ## Changes from core EPP push @errs,'pc' if (defined $self->cc() && $self->cc() eq 'NL' && ! $self->pc()); push @errs,'voice' if (!$change && ! $self->voice()); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { my $a=$self->auth(); $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); ## authInfo is not used $self->srid('ABCD') unless defined $self->srid(); ## we can not choose the ID } } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Data::Contact::SIDN - Handle SIDN contact data for Net::DRI =head1 VERSION This documentation refers to Net::DRI::Contact::SIDN version 1.01 =head1 SYNOPSIS This module is not used directly, but objects will be created in this class automatically when needed. =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for SIDN specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 legal_form() legal form =head2 legal_id() legal form registration number =head2 limited() SIDN status limited, set by registry =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Data/Contact/AFNIC.pm0000644000175000017500000002062711352534377020043 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for AFNIC ## ## Copyright (c) 2006,2008,2009,2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::AFNIC; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Email::Valid; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(firstname legal_form legal_form_other legal_id jo trademark key birth vat id_status)); =pod =head1 NAME Net::DRI::Data::Contact::AFNIC - Handle AFNIC contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for AFNIC specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 firstname() Please note that for AFNIC data, the name() must be only the lastname, hence this extra firstname() method needed for contacts being individuals =head2 legal_form() for an organization, either 'A' or 'association' for non profit organization, 'S' or 'company' for company or 'other' for other types; this must be set for contacts being moral entities =head2 legal_form_other() type of organization for other types =head2 legal_id() French SIREN/SIRET of organization =head2 jo() reference to an hash with 4 keys storing details about «Journal Officiel» : date_declaration (Declaration date), date_publication (Publication date), number (Announce number) and page (Announce page) a waldec key can also be present for the waldec id =head2 trademark() for trademarks, its number =head2 vat() vat number (not used by registry for now) =head2 key() registrant invariant key =head2 birth() reference to an hash with 2 keys storing details about birth of contact : date (Date of birth) and place (Place of birth) =head2 id_status() set by registry, the current identication status of the contact =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009,2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### our $LETTRES=qr(A-Z\x{C0}\x{C2}\x{C7}\x{C8}\x{C9}\x{CA}\x{CB}\x{CE}\x{CF}\x{D4}\x{D9}\x{DB}\x{DC}\x{178}\x{C6}\x{152}a-z\x{E0}\x{E2}\x{E7}\x{E8}\x{E9}\x{EA}\x{EB}\x{EE}\x{EF}\x{F4}\x{F9}\x{FB}\x{FC}\x{FF}\x{E6}\x{153}); our $NOM_LIBRE_ITEM=qr{[${LETTRES}0-9\(\)\.\[\]\?\+\*#&/!\@',><":-]+}; our $NOM_PROPRE_ITEM=qr{[${LETTRES}]+(('?(?:[${LETTRES}]+(?:\-?[${LETTRES}]+)?)+)|(?:\.?))}; our $NOM_PROPRE=qr{${NOM_PROPRE_ITEM}( +${NOM_PROPRE_ITEM})*}; our $ADRESSE_ITEM=qr{[${LETTRES}0-9\(\)\./',"#-]+}; our $NOM_COMMUNE_ITEM=qr{[${LETTRES}]+(?:['-]?[${LETTRES}]+)*}; sub is_nom_libre { return shift=~m/^(?:${NOM_LIBRE_ITEM} *)*[${LETTRES}0-9]+(?: *${NOM_LIBRE_ITEM}*)*$/; } sub is_adresse { return shift=~m/^(?:${ADRESSE_ITEM} *)*[${LETTRES}]+(?: *${ADRESSE_ITEM})*$/; } sub is_commune { return shift=~m/^${NOM_COMMUNE_ITEM}(?:(?:(?: *\/ *)|(?: +))${NOM_COMMUNE_ITEM})*(?: +(?:[cC][eE][dD][eE][xX]|[cC][dD][xX])(?: +[0-9]+)?)?$/; } sub is_code_fr { return shift=~m/^(?:FR|RE|MQ|GP|GF|TF|NC|PF|WF|PM|YT)$/; } sub is_dep_fr { return shift=~m/^(?:0[1-9])|(?:[1345678][0-9])|(?:2[1-9ABab])|(?:9[0-5])|(?:97[1-5])|(?:98[5-8])$/; } sub validate { my ($self,$change)=@_; $change||=0; $self->SUPER::validate(1); ## will trigger an Exception if problem my @errs; push @errs,'srid' if ($self->srid() && $self->srid()!~m/^[A-Z]+(?:[1-9][0-9]*)?(?:-FRNIC)?$/i); push @errs,'name' if ($self->name() && ($self->name()!~m/^${NOM_PROPRE}$/ || ! is_nom_libre($self->name()))); push @errs,'firstname' if ($self->firstname() && $self->firstname()!~m/^${NOM_PROPRE}$/); push @errs,'org' if ($self->org() && ! is_nom_libre($self->org())); push @errs,'legal_form' if ($self->legal_form() && $self->legal_form()!~m/^(?:A|S|company|association|other)$/); ## AS for email, the rest for EPP push @errs,'legal_form_other' if ($self->legal_form_other() && ! is_nom_libre($self->legal_form_other())); push @errs,'legal_id' if ($self->legal_id() && $self->legal_id()!~m/^[0-9]{9}(?:[0-9]{5})?$/); my $jo=$self->jo(); if ($jo) { if ((ref($jo) eq 'HASH') && exists($jo->{date_declaration}) && exists($jo->{date_publication}) && exists($jo->{number}) && exists ($jo->{page})) { push @errs,'jo' unless ($jo->{date_declaration}=~m!^[0-9]{2}/[0-9]{2}/[0-9]{4}$! || $jo->{date_declaration}=~m!^[0-9]{4}-[0-9]{2}-[0-9]{2}$!); push @errs,'jo' unless ($jo->{date_publication}=~m!^[0-9]{2}/[0-9]{2}/[0-9]{4}$! || $jo->{date_publication}=~m!^[0-9]{4}-[0-9]{2}-[0-9]{2}$!); push @errs,'jo' unless $jo->{number}=~m/^[1-9][0-9]*$/; push @errs,'jo' unless $jo->{page}=~m/^[1-9][0-9]*$/; } else { push @errs,'jo'; } } push @errs,'vat' if ($self->vat() && !Net::DRI::Util::xml_is_token($self->vat())); push @errs,'trademark' if ($self->trademark() && $self->trademark()!~m/^[0-9]*[A-Za-z]*[0-9]+$/); push @errs,'key' if ($self->key() && $self->key()!~m/^[A-Za-z]{8}-[1-9][0-9]{2}$/); my $birth=$self->birth(); if ($birth) { if ((ref($birth) eq 'HASH') && exists($birth->{date}) && exists($birth->{place})) { push @errs,'birth' unless ((ref($birth->{date}) eq 'DateTime') || $birth->{date}=~m!^[0-9]{4}-[0-9]{2}-[0-9]{2}$! || $birth->{date}=~m!^[0-9]{2}/[0-9]{2}/[0-9]{4}$!); push @errs,'birth' unless (($birth->{place}=~m/^[A-Za-z]{2}$/ && ! is_code_fr($birth->{place})) || ($birth->{place}=~m/^(?:[0-9]{5}|) *, *(.+)$/ && is_commune($1))); } else { push @errs,'birth'; } } my $isccfr=$self->cc()? is_code_fr(uc($self->cc())) : 0; ## Not same checks as AFNIC, but we will translate to their format when needed, better to standardize on EPP if ($self->voice()) { push @errs,'voice' if $self->voice()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/; push @errs,'voice' if ($isccfr && $self->voice()!~m/^\+33\./); } if ($self->fax()) { push @errs,'fax' if $self->fax()!~m/^\+[0-9]{1,3}\.[0-9]{1,14}(?:x\d+)?$/; push @errs,'fax' if ($isccfr && $self->fax()!~m/^\+33\./); } push @errs,'email' if ($self->email() && !Email::Valid->rfc822($self->email())); ## Maintainer is not tied to contact push @errs,'disclose' if ($self->disclose() && $self->disclose()!~m/^[ONY]$/i); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub validate_registrant { my $self=shift; my @errs; my $rs=$self->street(); push @errs,'street' if ($rs && ((ref($rs) ne 'ARRAY') || (@$rs > 3) || (grep { ! is_adresse($_) } @$rs))); push @errs,'city' if ($self->city() && ! is_commune($self->city())); my $cc=$self->cc(); my $isccfr=0; if ($cc) { push @errs,'cc' if !exists($Net::DRI::Util::CCA2{uc($cc)}); $isccfr=is_code_fr(uc($cc)); } my $pc=$self->pc(); if ($pc) { if ($isccfr) { push @errs,'pc' unless $pc=~m/^[0-9]{5}$/; } else { push @errs,'pc' unless $pc=~m/^[-0-9A-Za-z ]+$/; } } Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; my $pn=$ndr->protocol()->name(); if ($what eq 'create' && $pn eq 'EPP') { $self->srid('AUTO') unless defined($self->srid()); ## we can not choose the ID } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/BE.pm0000644000175000017500000001007111352534377017501 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .BE ## ## Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::BE; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(vat lang)); =pod =head1 NAME Net::DRI::Data::Contact::BE - Handle .BE contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .BE specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 type() type of contact : billing, tech, registrant, onsite or accmgr (mandatory) registrant is called licensee by the registry : you can use both names when setting value, but you will get back only registrant when getting. =head2 vat() vat number of contact =head2 lang() language of contact, either fr, nl or en =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2006,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem if (!$change) { Net::DRI::Exception::usererr_insufficient_parameters('Invalid contact information: voice/type mandatory') unless ($self->voice() && $self->type()); } ## Lower limits than in EPP (other checks already done in superclass) push @errs,'name' if ($self->name() && grep { length($_) > 50 } ($self->name())); push @errs,'org' if ($self->org() && grep { length($_) > 100 } ($self->org())); ## docs says only that it will be truncated if more than 100 characters push @errs,'type' if ($self->type() && $self->type()!~m/^(?:billing|tech|registrant|onsite|accmgr)$/); ## licensee is translated to registrant ! push @errs,'vat' if ($self->vat() && !Net::DRI::Util::xml_is_token($self->vat(),1,20)); push @errs,'lang' if ($self->lang() && $self->lang()!~m/^(?:fr|nl|en)$/); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; Net::DRI::Exception::usererr_insufficient_parameters('Org is mandatory for billing, tech or accmgr contacts') if ($self->type() && $self->type()=~m/^(?:type|billing|accmgr)$/ && !$self->org()); return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { my $a=$self->auth(); $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); $self->srid('ABCD') unless defined $self->srid(); ## we can not choose the ID } } sub type { my ($self,$what)=@_; if (defined $what && $what) { $what='registrant' if $what eq 'licensee'; $self->{type}=$what; return $self; } return $self->{type}; } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/BR.pm0000644000175000017500000000561311352534377017524 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for BR ## ## Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::BR; use strict; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(orgid type associated_contacts associated_domains responsible proxy)); =pod =head1 NAME Net::DRI::Data::Contact::BR - Handle BR contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for BR specific data. =head1 METHODS The following mutators can be called in chain, as they all return the object itself. =head2 orgid() organization id =head2 type() type of contact (admin, billing or member) =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem if (!$change) { ## Net::DRI::Exception::usererr_insufficient_parameters('orgid is mandatory') unless $self->orgid(); } push @errs,'orgid' if ($self->orgid() && !Net::DRI::Util::xml_is_token($self->orgid(),1,30)); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { $self->srid('auto') unless defined($self->srid()); ## we can not choose the ID for pure contacts (but we can for brorg creations it seems) } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/ASIA.pm0000644000175000017500000000504611352534377017736 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for .ASIA ## ## Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::ASIA; use strict; use base qw/Net::DRI::Data::Contact/; our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(cedcc cedsp cedcity cedetype cediform cedinum cedothertype cedoiform)); =pod =head1 NAME Net::DRI::Data::Contact::ASIA - Handle .ASIA contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .AERO specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 cedcc() Stores the CED Country Code. =head2 cedsp() Stores the CED State/Province. =head2 cedcity() Stores the CED City. =head2 cedetype() Stores the CED Legal Entity Type. =head2 cediform() Stores the CED Identification Form. =head2 cedinum() Stores the CED Identification Number. =head2 cedothertype() Stores the CED other legal entity type. =head2 cedoiform() Stores the CED other identification form. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Tonnerre Lombard Etonnerre.lombard@sygroup.chE =head1 COPYRIGHT Copyright (c) 2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Contact/CIRA.pm0000644000175000017500000001132111352534377017730 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for CIRA ## ## Copyright (c) 2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Contact::CIRA; use strict; use warnings; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(legal_form lang is_individual ip_address agreement reseller_id whois_display)); #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; $self->SUPER::validate(1); ## will trigger an Exception if problem my @errs; if (!$change) { my @missing=grep { my $r=scalar $self->$_(); (defined $r && length $r)? 0 : 1 } qw/name cc lang srid auth/; Net::DRI::Exception::usererr_insufficient_parameters('Mandatory contact information missing: '.join('/',@missing)) if @missing; push @errs,'srid' unless Net::DRI::Util::xml_is_token($self->srid(),3,16); } push @errs,'sp' if (defined $self->sp() && defined $self->cc() && $self->cc() eq 'CA' && $self->sp()!~m/^(?:AB|BC|MB|NB|NL|NT|NS|NU|ON|PE|QC|SK|YT)$/); push @errs,'legal_form' if (defined $self->legal_form() && $self->legal_form()!~m!^(?:CCO|CCT|RES|GOV|EDU|ASS|HOP|PRT|TDM|TRD|PLT|LAM|TRS|ABO|INB|LGR|OMK|MAJ)$!); push @errs,'lang' if (defined $self->lang() && $self->lang()!~m/^(?:fr|en)$/o); push @errs,'ip_address' if (defined $self->ip_address() && !Net::DRI::Util::is_ipv4($self->ip_address(),1) && !Net::DRI::Util::is_ipv6($self->ip_address(),1)); if (defined $self->agreement()) { my $ra=$self->agreement(); push @errs,'agreement' if (ref($ra) ne 'HASH' || 2!=keys(%$ra) || !exists($ra->{version}) || !exists($ra->{signed}) || length($ra->{version}) > 4 || $ra->{signed}!~m/^(?:0|1)$/); } push @errs,'reseller_id' if (defined $self->reseller_id() && length($self->reseller_id()) > 255); push @errs,'whois_display' if (defined $self->whois_display() && $self->whois_display()!~m/^(?:FULL|PRIVATE)$/o); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { my $a=$self->auth(); $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); ## authInfo is not used } } #################################################################################################### 1; __END__ =pod =head1 NAME Net::DRI::Data::Contact::CIRA - Handle CIRA (.CA) contact data for Net::DRI =head1 VERSION This documentation refers to Net::DRI::Contact::CIRA version 1.01 =head1 SYNOPSIS This module is not used directly, but objects will be created in this class automatically when needed. =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for CIRA specific data. =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 legal_form() legal form (see registry list of possible CPR values), mandatory for registrant contacts, otherwise optional =head2 lang() contact prefered language, either 'fr' or 'en' =head2 ip_address() (optional) registrant originating IP address (v4 or v6) =head2 agreement() ref hash with keys version and signed (value being 1 or 0); optional for non registrant contacts registry also adds a third key, 'timestamp' =head2 reseller_id() (optional) ID of the registrar reseller =head2 whois_display() for registrant contacts, either FULL or PRIVATE =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut Net-DRI-0.96/lib/Net/DRI/Data/Contact/LU.pm0000644000175000017500000000646611352534377017550 0ustar patrickpatrick## Domain Registry Interface, Handling of contact data for LU ## ## Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Contact::LU; use strict; use base qw/Net::DRI::Data::Contact/; use Net::DRI::Exception; use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; __PACKAGE__->register_attributes(qw(type)); =pod =head1 NAME Net::DRI::Data::Contact::LU - Handle .LU contact data for Net::DRI =head1 DESCRIPTION This subclass of Net::DRI::Data::Contact adds accessors and validation for .LU specific data. This registry uses only localized data with characters in US-ASCII and ISO-LATIN-1 =head1 METHODS The following accessors/mutators can be called in chain, as they all return the object itself. =head2 type() type of contact : holder_org, holder_pers (for contact objects used as holders) or contact =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub validate { my ($self,$change)=@_; $change||=0; my @errs; $self->SUPER::validate($change); ## will trigger an Exception if problem if (!$change) { Net::DRI::Exception::usererr_insufficient_parameters('Invalid contact information: pc mandatory') unless (scalar($self->pc())); } push @errs,'sp' if $self->sp(); ## not allowed push @errs,'type' if ($self->type() && $self->type()!~m/^(?:holder_org|holder_pers|contact)/); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information: '.join('/',@errs)) if @errs; if ($self->type() && ($self->type() ne 'contact')) { push @errs,'voice' if $self->voice(); push @errs,'fax' if $self->fax(); push @errs,'org' if $self->org(); Net::DRI::Exception::usererr_invalid_parameters('Invalid contact information (not allowed for holders): '.join('/',@errs)) if @errs; } return 1; ## everything ok. } sub init { my ($self,$what,$ndr)=@_; if ($what eq 'create') { my $a=$self->auth(); $self->auth({pw=>''}) unless ($a && (ref($a) eq 'HASH') && exists($a->{pw})); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/StatusList.pm0000644000175000017500000001445111352534377017745 0ustar patrickpatrick## Domain Registry Interface, Handling of statuses list (order is irrelevant) (base class) ## ## Copyright (c) 2005,2006,2007,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::StatusList; use strict; use Net::DRI::Exception; our $VERSION=do { my @r=(q$Revision: 1.10 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Data::StatusList - Handle a collection of statuses for an object, in a registry independent fashion for Net::DRI =head1 DESCRIPTION You should never have to use this class directly, but you may get back objects that are instances of subclasses of this class. An object of this class can store the statuses' names, with a message for each and a language tag, and any other stuff, depending on registry. =head1 METHODS =head2 is_active() returns 1 if these statuses enable an object to be active =head2 is_published() returns 1 if these statuses enable the object to be published on registry DNS servers =head2 is_pending() returns 1 if these statuses are for an object that is pending some action at registry =head2 is_linked() returns 1 if these statuses are for an object that is linked to another one at registry =head2 can_update() returns 1 if these statuses allow to update the object at registry =head2 can_transfer() returns 1 if these statuses allow to transfer the object at registry =head2 can_delete() returns 1 if these statuses allow to delete the object at registry =head2 can_renew() returns 1 if these statuses allow to renew the object at registry =head2 possible_no() returns an array with the list of available status to use in the no() call =head2 no() can be used to build a status, which will be added to the list. Must be given three parameters: a status (from list given by C), a message (optional), a lang (optional, default to 'en') =head1 INTERNAL METHODS You may also use the following methods, but they should be less useful as the purpose of the module is to give an abstract view of the underlying statuses. =head2 list_status() to get only the statuses' names, as an array of sorted names =head2 status_details() to get an hash ref with all status information =head2 has_any() returns 1 if the object has any of the statuses given as arguments =head2 has_not() returns 1 if the object has none of the statuses given as arguments =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $pname=shift || '?'; my $pversion=shift || '?'; my $self={ proto_name => $pname, proto_version => $pversion, sl => {}, ## statusname => { lang => lc(lang), msg => '', other per class } }; bless($self,$class); $self->add(@_) if (@_); return $self; } sub _register_pno { my ($self,$rs)=@_; $self->{possible_no}=$rs; } sub add { my $self=shift; my $rs=$self->{sl}; foreach my $el (@_) { if (ref($el)) { my %tmp=%{$el}; my $name=$tmp{name}; delete($tmp{name}); $rs->{$name}=\%tmp; } else { $rs->{$el}={}; } } return $self; } sub rem { my ($self,$status)=@_; my $rs=$self->{sl}; delete($rs->{$status}) if exists($rs->{$status}); return $self; } sub list_status { my $self=shift; return sort(keys(%{$self->{sl}})); } sub status_details { my $self=shift; return $self->{sl}; } sub is_empty { my $self=shift; my @a=$self->list_status(); return (@a > 0)? 0 : 1; } sub has_any { my $self=shift; my %tmp=map { uc($_) => 1 } $self->list_status(); foreach my $el (@_) { return 1 if exists($tmp{uc($el)}); } return 0; } sub has_not { my $self=shift; my %tmp=map { uc($_) => 1 } $self->list_status(); foreach my $el (@_) { return 0 if exists($tmp{uc($el)}); } return 1; } sub possible_no { my $self=shift; return sort(keys(%{$self->{possible_no}})); } sub no { my ($self,$what,$msg,$lang)=@_; my $rs=$self->{possible_no}; return $self unless (defined($what) && exists($rs->{$what})); if (defined($msg) && $msg) { $self->add({name=>$rs->{$what},msg=>$msg,lang=>(defined($lang) && $lang)? $lang : 'en'}); } else { $self->add($rs->{$what}); } return $self; } #################################################################################################### ## Methods that must be defined in subclasses sub is_active { Net::DRI::Exception::err_method_not_implemented('is_active in '.ref($_[0])); } sub is_published { Net::DRI::Exception::err_method_not_implemented('is_published in '.ref($_[0])); } sub is_pending { Net::DRI::Exception::err_method_not_implemented('is_pending in '.ref($_[0])); } sub is_linked { Net::DRI::Exception::err_method_not_implemented('is_linked in '.ref($_[0])); } sub can_update { Net::DRI::Exception::err_method_not_implemented('can_update in '.ref($_[0])); } sub can_transfer { Net::DRI::Exception::err_method_not_implemented('can_transfer in '.ref($_[0])); } sub can_delete { Net::DRI::Exception::err_method_not_implemented('can_delete in '.ref($_[0])); } sub can_renew { Net::DRI::Exception::err_method_not_implemented('can_renew in '.ref($_[0])); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Changes.pm0000644000175000017500000000665411352534377017204 0ustar patrickpatrick## Domain Registry Interface, Handle bundle of changes ## ## Copyright (c) 2005,2008 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Changes; use strict; our $VERSION=do { my @r=(q$Revision: 1.8 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Data::Changes - Bundle of changes in Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2008 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ############################################################################################################################## sub new { my ($proto,$type,$op,$el)=@_; my $class=ref($proto) || $proto; my $self={}; ## { 'type' => [ toadd, todel, toset ] } type=host,ip,status,contact,etc... bless($self,$class); if (defined($type) && defined($op) && defined($el)) { $self->{$type}=[]; $self->{$type}->[0]=$el if ($op=~m/^(?:0|add)$/); $self->{$type}->[1]=$el if ($op=~m/^(?:1|del)$/); $self->{$type}->[2]=$el if ($op=~m/^(?:2|set)$/); } return $self; } sub new_add { return shift->new(shift,'add',shift); } sub new_del { return shift->new(shift,'del',shift); } sub new_set { return shift->new(shift,'set',shift); } sub types { my ($self,$type)=@_; return sort(keys(%$self)) unless defined($type); my @r; return @r unless (exists($self->{$type}) && defined($self->{$type})); push @r,'add' if (defined($self->{$type}->[0])); push @r,'del' if (defined($self->{$type}->[1])); push @r,'set' if (defined($self->{$type}->[2])); return @r; } sub _el { my ($self,$pos,$type,$new)=@_; unless (defined($new)) { return unless (exists($self->{$type}) && defined($self->{$type})); return $self->{$type}->[$pos]; } $self->{$type}=[] unless (exists($self->{$type})); $self->{$type}->[$pos]=$new; return $self; } sub add { return shift->_el(0,shift,shift); } sub del { return shift->_el(1,shift,shift); } sub set { return shift->_el(2,shift,shift); } sub all_defined { my ($self,$type)=@_; return () unless (defined($type) && $type && exists($self->{$type}) && defined($self->{$type})); return (grep { defined } @{$self->{$type}}); } sub is_empty { my $self=shift; my @o=map { $self->all_defined($_) } $self->types(); return @o? 0 : 1; } ############################################################################################################################## 1; Net-DRI-0.96/lib/Net/DRI/Data/RegistryObject.pm0000644000175000017500000000761111352534377020565 0ustar patrickpatrick## Domain Registry Interface, RegistryObject ## ## Copyright (c) 2005 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::RegistryObject; use strict; use Net::DRI::Exception; our $AUTOLOAD; our $VERSION=do { my @r=(q$Revision: 1.7 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Data::RegistryObject - Additional API for Net::DRI operations =head1 SYNOPSYS my $dri=Net::DRI->new(); my $nsg=$dri->remote_object('nsgroup'); $nsg->create(...); $nsg->update(...); $nsg->whatever(...); Also: my $nsg=$dri->remote_object('nsgroup','name'); =head1 DESCRIPTION For objects other than domains, hosts, or contacts, Net::DRI::Data::RegistryObject can be used to apply actions. Net::DRI::remote_object is used to create a new Net::DRI::Data::RegistryObject with either only one parameter (the object type) or two parameters (the object type and the object name) If the object name is not passed at creation it will need to be passed for all later actions as first parameter. All calls are handled by an AUTOLOAD, except target() which is the same as in Net::DRI. All calls need either two array references (protocol parameters and transport parameters) or a list (protocol parameters only). =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut ########################################################################################################### sub new { my $proto=shift; my $class=ref($proto) || $proto; my ($p,$type,$name)=@_; ## $name (object name) not necessarily defined Net::DRI::Exception::err_invalid_parameters() unless (defined($p) && ((ref($p) eq 'Net::DRI') || (ref($p) eq 'Net::DRI::Registry'))); Net::DRI::Exception::err_insufficient_parameters() unless (defined($type) && $type); my $self={ p => $p, type => $type, name => $name, }; bless($self,$class); return $self; } sub target { my $self=shift; $self->{p}->target(@_); return $self; } sub AUTOLOAD { my $self=shift; my $attr=$AUTOLOAD; ## this is the action wanted on the object $attr=~s/.*:://; return unless $attr=~m/[^A-Z]/; ## skip DESTROY and all-cap methods my $name=$self->{name}; my ($rp,$rt); if (@_==2 && (ref($_[0]) eq 'ARRAY') && (ref($_[1]) eq 'ARRAY')) { $rp=$_[0]; $rp=[ $self->{name}, @$rp ] if (defined($name) && $name); $rt=$_[1]; } else { $rp=(defined($name) && $name)? [ $name, @_ ] : [ @_ ]; $rt=[]; } my $p=$self->{p}; if (ref($p) eq 'Net::DRI::Registry') { return $p->process($self->{type},$attr,$rp,$rt); } elsif (ref($p) eq 'Net::DRI') { my $c=$self->{type}.'_'.$attr; return $p->$c->(@$rp); } else { Net::DRI::Exception::err_assert('case not handled: '.ref($p)); } } ########################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Hosts.pm0000644000175000017500000002016011352534377016720 0ustar patrickpatrick## Domain Registry Interface, Implements a list of host (names+ip) with order preserved ## ## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI::Data::Hosts; use strict; use warnings; use base qw(Class::Accessor::Chained::Fast); __PACKAGE__->mk_accessors(qw(name loid)); use Net::DRI::Util; our $VERSION=do { my @r=(q$Revision: 1.18 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Data::Hosts - Handle ordered list of nameservers (name, IPv4 addresses, IPv6 addresses) for Net::DRI =head1 SYNOPSIS use Net::DRI::Data::Hosts; my $dh=Net::DRI::Data::Hosts->new(); $dh->add('ns.example.foo',['1.2.3.4','1.2.3.5']); $dh->add('ns2.example.foo',['10.1.1.1']); ## Third element can be an array ref of IPv6 addresses ## ->add() returns the object itself, and thus can be chained ## Number of nameservers print $dh->count(); ## Gives 2 ## List of names, either all without arguments, or the amount given by the argument my @a=$dh->get_names(2); ## Gives ('ns.example.foo','ns2.example.foo') ## Details for the nth nameserver (the list starts at 1 !) my @d=$dh->get_details(2); ## Gives ('ns2.example.foo',['10.1.1.1']) ## Details by name is possible also my @d=$dh->get_details('ns2.example.foo'); =head1 DESCRIPTION Order of nameservers is preserved. Order of IP addresses is preserved, but no duplicate IP is allowed. If you try to add a nameserver that is already in the list, the IP addresses provided will be added to the existing IP addresses (without duplicates) Hostnames are verified before being used with Net::DRI::Util::is_hostname(). IP addresses are verified with Net::DRI::Util::is_ipv4() and Net::DRI::Util::is_ipv6(). =head1 METHODS =head2 new(...) creates a new instance ; if parameters are given, add() is called with them all at once =head2 new_set(...) creates a new instance ; if parameters are given, add() is called once for each parameter =head2 clear() clears the current list of nameservers =head2 set(...) clears the current list of nameservers, and call add() once for each parameter passed =head2 add(name,[ipv4],[ipv6]) adds a new nameserver with the given name and lists of IPv4 and IPv6 addresses =head2 name() name of this object (for example for registries having the notion of host groups) ; this has nothing to do with the name(s) of the nameservers inside this object =head2 loid() local id of this object =head2 get_names(limit) returns a list of nameservers' names included in this object ; if limit is provided we return only the number of names asked =head2 count() returns the number of nameservers currently stored in this object =head2 is_empty() returns 0 if this object has nameservers, 1 otherwise =head2 get_details(pos_or_name) given an integer (position in the list, we start to count at 1) or a name, we return all details as a 3 element array in list context or only the first element (the name) in scalar context for the nameserver stored at the given position or with the given name ; returns undef if nothing found at the position/with the name given. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO http://www.dotandco.com/services/software/Net-DRI/ =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my $self={ list => [] }; ## list=>[['',[ipv4],[ipv6],{}]+],options=>{} bless $self,$class; $self->add(@_) if (@_); return $self; } sub new_set { my $s=shift->new(); foreach (@_) { $s->add($_); } return $s; } sub clear { my $s=shift; $s->{list}=[]; } sub set { my $s=shift; $s->{list}=[]; foreach (@_) { $s->add($_); } return $s; } sub add { my ($self,$in,$e1,$e2,$ipall,$rextra)=@_; ($ipall,$rextra)=(undef,$ipall) if (defined($ipall) && ref($ipall)); return unless (defined($in) && $in); if (ref $in eq 'ARRAY') { return $self->add(@$in); } if (defined $e2 && $e2) { $self->_push($in,$e1,$e2,$ipall,$rextra); return $self; } if (defined $e1 && $e1) { $self->_push($in,_separate_ips($e1,$ipall),$ipall,$rextra); return $self; } $self->_push($in,[],[],1,$rextra); return $self; } sub _separate_ips { my (@ip4,@ip6); my $ipall=pop(@_); $ipall=0 unless defined($ipall); foreach my $ip (map {ref($_)? @{$_} : $_} @_) { ## We keep only the public ips push @ip4,$ip if Net::DRI::Util::is_ipv4($ip,1-$ipall); push @ip6,$ip if Net::DRI::Util::is_ipv6($ip,1-$ipall); } return (\@ip4,\@ip6); } sub _push { my ($self,$name,$ipv4,$ipv6,$ipall,$rextra)=@_; $ipall=0 unless defined $ipall; chop($name) if (defined $name && $name && $name=~m/\.$/); return unless Net::DRI::Util::is_hostname($name); $name=lc($name); ## by default, hostnames are case insensitive ## We keep only the public ips my @ipv4=grep { Net::DRI::Util::is_ipv4($_,1-$ipall) } ref $ipv4 ? @$ipv4 : ($ipv4); my @ipv6=grep { Net::DRI::Util::is_ipv6($_,1-$ipall) } ref $ipv6 ? @$ipv6 : ($ipv6); if ($self->count() && defined $self->get_details($name)) ## name already here, we append IP { foreach my $el (@{$self->{list}}) { next unless ($el->[0] eq $name); unshift @ipv4,@{$el->[1]}; unshift @ipv6,@{$el->[2]}; $el->[1]=_remove_dups_ip(\@ipv4); $el->[2]=_remove_dups_ip(\@ipv6); if (defined $el->[3] || defined $rextra) { $el->[3]={ defined $el->[3] ? %{$el->[3]} : (), (defined $rextra && ref $rextra eq 'HASH')? %$rextra : () }; } last; } } else { push @{$self->{list}},[$name,_remove_dups_ip(\@ipv4),_remove_dups_ip(\@ipv6),$rextra]; } } sub _remove_dups_ip { my $ip=shift; my @a; my %tmp; @a=ref($ip)? grep { ! $tmp{$_}++ } @$ip : ($ip) if defined $ip; return \@a; } ## Give back an array of all hostnames, or up to a limit if provided sub get_names { my ($self,$limit)=@_; return unless (defined $self && ref $self); my $c=$self->count(); $c=$limit if ($limit && ($limit <= $c)); my @r; foreach (0..($c-1)) { push @r,$self->{list}->[$_]->[0]; } return @r; } sub count { my $self=shift; return unless (defined $self && ref $self); return scalar(@{$self->{list}}); } sub is_empty { my $self=shift; my $c=$self->count(); return (defined $c && ($c > 0))? 0 : 1; } sub get_details { my ($self,$pos)=@_; return unless (defined $self && ref $self && defined $pos && $pos); my $c=$self->count(); if ($pos=~m/^\d+$/) { return unless ($c && ($pos <= $c)); my $el=$self->{list}->[$pos-1]; return wantarray()? @$el : $el->[0]; } else { $pos=lc($pos); foreach my $el (@{$self->{list}}) { next unless ($el->[0] eq $pos); return wantarray()? @$el : $el->[0]; } return; } } # Do not use this method for anything else than debugging. The output format is not guaranteed to remain stable sub as_string { my ($self)=shift; my @s; foreach my $el (@{$self->{list}}) { my $s=$el->[0]; my $ips=join(',',@{$el->[1]},@{$el->[2]}); $s.=' ['.$ips.']' if $ips; $s.=' {'.join(' ',map { $_.'='.$el->[3]->{$_} } keys(%{$el->[3]})).'}' if (defined $el->[3] && %{$el->[3]}); push @s,$s; } return join(' ',@s); } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI/Data/Raw.pm0000644000175000017500000000706111352534377016356 0ustar patrickpatrick## Domain Registry Interface, Encapsulating raw data ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # ######################################################################################### package Net::DRI::Data::Raw; use strict; use warnings; use Data::Dumper (); use Net::DRI::Exception; use base qw(Class::Accessor::Fast); __PACKAGE__->mk_ro_accessors(qw(type data hint)); our $VERSION=do { my @r=(q$Revision: 1.11 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; =pod =head1 NAME Net::DRI::Data::Raw - Encapsulating raw data for Net::DRI =head1 DESCRIPTION Please see the README file for details. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO Ehttp://www.dotandco.com/services/software/Net-DRI/E =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my ($type,$data,$hint)=@_; ## type=1, data=ref to array ## type=2, data=string ## type=3, data=ref to string NOTIMPL ## type=4, data=path to local file NOTIMPL ## type=5, data=object with a as_string method ## type=6, data=complex object in a ref array my $self={type => $type, data => $data, hint => $hint || '', }; bless($self,$class); return $self; } sub new_from_array { my $class=shift; my @a=map { my $f=$_; $f=~s/[\r\n\s]+$//; $f; } (ref($_[0]))? @{$_[0]} : @_; return $class->new(1,\@a); } sub new_from_string { return shift->new(2,@_); } sub new_from_xmlstring { return shift->new(2,$_[0],'xml'); } sub new_from_object { return shift->new(5,@_); } #################################################################################################### sub as_string { my $self=shift; my $data=$self->data(); if ($self->type()==1) { return join("\n",@$data)."\n"; } if ($self->type()==2) { $data=~s/\r\n/\n/g; return $data; } if ($self->type()==5) { Net::DRI::Exception::err_method_not_implemented('as_string in '.ref($data)) unless $data->can('as_string'); return $data->as_string(); } if ($self->type()==6) { return Data::Dumper->new($data)->Indent(2)->Varname('')->Quotekeys(0)->Sortkeys(1)->Dump(); } } sub last_line { my $self=shift; if ($self->type()==1) { my $data=$self->data(); return $data->[$#$data]; ## see above } if ($self->type()==2) { my @a=$self->as_array(); return $a[-1]; } } sub as_array { my $self=shift; if ($self->type()==1) { return @{$self->data()}; } if ($self->type()==2) { return split(/\r?\n/,$self->data()); } } #################################################################################################### 1; Net-DRI-0.96/lib/Net/DRI.pm0000644000175000017500000003274411352534377014762 0ustar patrickpatrick## Domain Registry Interface, Main entry point ## ## Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. ## ## This file is part of Net::DRI ## ## Net::DRI is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## See the LICENSE file that comes with this distribution for more details. # # # #################################################################################################### package Net::DRI; use strict; use warnings; require UNIVERSAL::require; use Net::DRI::Cache; use Net::DRI::Registry; use Net::DRI::Util; use Net::DRI::Exception; use base qw(Class::Accessor::Chained::Fast Net::DRI::BaseClass); __PACKAGE__->mk_ro_accessors(qw/trid_factory logging cache/); our $AUTOLOAD; our $VERSION='0.96'; our $CVS_REVISION=do { my @r=(q$Revision: 1.38 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; our $RUNNING_POE=(exists($INC{'POE.pm'}))? $POE::Kernel::poe_kernel : undef; =pod =head1 NAME Net::DRI - Interface to Domain Name Registries/Registrars/Resellers =head1 VERSION This documentation refers to Net::DRI version 0.95 =head1 SYNOPSIS use Net::DRI; my $dri=Net::DRI->new({ cache_ttl => 10, trid_factory => ..., logging => .... }); ... various operations ... $dri->end(); =head1 DESCRIPTION Net::DRI is a Perl library to access services offered by domain name providers, such as registries or registrars. DRI stands for Domain Registration Interface and it aims to be for domain name registries/registrars/resellers what DBI is for databases: an abstraction over multiple providers, with multiple policies, transports and protocols all used through a uniform API. It is an object-oriented framework implementing RRP (RFC 2832/3632), EPP (core EPP in RFC 5730/5731/5732/5733/5734 aka STD69, extensions in RFC 3915/4114/4310/5076 and various extensions of ccTLDs/gTLDs - currently more than 30 TLDs are directly supported with extensions), RRI (.DE registration protocol), Whois, DAS (Domain Availability Service used by .BE, .EU, .AU, .NL), IRIS (RFC3981) DCHK (RFC5144) over LWZ (RFC4993) for .DE currently and XCP (RFC4992), .FR/.RE email and webservices interface, and resellers interface of some registrars (Gandi, OpenSRS, etc.). It has transports for connecting with UDP/TCP/TLS, HTTP/HTTPS, Web Services (XML-RPC and SOAP with/without WSDL), or SMTP-based registries/registrars. It is not limited to handling of domain names, it can be easily extended. For example, it supports ENUM registrations and validations, or DNSSEC provisioning. A shell is included for easy prototyping and debugging, see L. Caching and logging features are also included by default. Please see the included README file for full details. =head1 EXAMPLES Please see the C subdirectory of the distribution, it contains various examples. Please also see all unit tests under C, they show all parts of the API. =head1 SUBROUTINES/METHODS After having used Net::DRI (which is the only module you should need to C from this distribution), you create an object as instance of this class, and every operation will be carried through it. =head2 trid_factory() This is an accessor to the trid factory (code reference) used to generate client transaction identificators, that are useful for logging and asynchronous operations. During the C call, a C is initialized to a default safe value (being Net::DRI::Util::create_trid_1). You need to call this method only if you wish to use another function to generate transaction identificators. All other objects (registry profiles and transports) created after that will inherit this value. If you call again C the change will only apply to new objects (registry profiles and transports) created after the change, it will not apply to already existing objects (registry profiles and transports). =head2 logging() This is an accessor to the underlying Logging object. During the C call you can provide the object, or just a string ("null", "stderr", "files" or "syslog" which are the current logging modules available in Net::DRI), or a reference to an array with the first parameter a string (same as previously) and the second parameter a reference to an hash with data needed by the logging class used (see for example L). If you want to log the application data (what is exchanged with remote server, such as EPP XML streams), you need to use logging level of 'notice', or higher. =head2 cache() This is an accessor to the underlying Cache object. See L. This object has a C method to access and change the current time to live for cached data. =head1 SUPPORT For now, support questions should be sent to: Enetdri@dotandco.comE Please also see the SUPPORT file in the distribution. =head1 SEE ALSO L =head1 AUTHOR Patrick Mevzek, Enetdri@dotandco.comE and various contributors (see Changes file and web page above) =head1 COPYRIGHT Copyright (c) 2005-2010 Patrick Mevzek . All rights reserved. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. See the LICENSE file that comes with this distribution for more details. =cut #################################################################################################### sub new { my $class=shift; my ($cachettl,$globaltimeout)=@_; ## old API and $globaltimeout never used my $rh=(defined $cachettl && ( ref $cachettl eq 'HASH'))? $cachettl : { cache_ttl => $cachettl }; my $self={ cache => Net::DRI::Cache->new((exists $rh->{cache_ttl} && defined $rh->{cache_ttl})? $rh->{cache_ttl} : 0), global_timeout => $globaltimeout, current_registry => undef, ## registry name (key of following hash) registries => {}, ## registry name => Net::DRI::Registry object tlds => {}, ## tld => [ registries name ] time_created => time(), trid_factory => (exists $rh->{trid_factory} && (ref $rh->{trid_factory} eq 'CODE'))? $rh->{trid_factory} : \&Net::DRI::Util::create_trid_1, }; my ($logname,@logdata); if (exists $rh->{logging}) { if (ref $rh->{logging} eq 'ARRAY') { ($logname,@logdata)=@{$rh->{logging}}; } else { $logname=$rh->{logging}; } } else { $logname='null'; } if ($logname !~ m/::/) { $logname='Net::DRI::Logging::'.ucfirst($logname); } $logname->require() or Net::DRI::Exception::err_failed_load_module('DRI',$logname,$@); $self->{logging}=$logname->new(@logdata); bless($self,$class); $self->logging()->setup_channel(__PACKAGE__,'core'); $self->log_output('notice','core','Successfully created Net::DRI object with logging='.$logname); return $self; } sub add_current_registry { my ($self,@p)=@_; $self->add_registry(@p); my $reg=$p[0]; $reg='Net::DRI::DRD::'.$reg unless ($reg=~m/::/); $self->target($reg->name()); return $self; } sub add_registry { my ($self,$reg,@data)=@_; Net::DRI::Exception::usererr_insufficient_parameters('add_registry needs a registry name') unless Net::DRI::Util::all_valid($reg); $reg='Net::DRI::DRD::'.$reg unless ($reg=~m/::/); $reg->require() or Net::DRI::Exception::err_failed_load_module('DRI',$reg,$@); my $drd=$reg->new(@data); Net::DRI::Exception->die(1,'DRI',9,'Failed to initialize registry '.$reg) unless ($drd && ref($drd)); Net::DRI::Exception::err_method_not_implemented('name() in '.$reg) unless $drd->can('name'); my $regname=$drd->name(); Net::DRI::Exception->die(1,'DRI',10,'No dot allowed in registry name: '.$regname) unless (index($regname,'.')==-1); Net::DRI::Exception->die(1,'DRI',11,'New registry name already in use') if (exists($self->{registries}->{$regname})); my $ndr=Net::DRI::Registry->new($regname,$drd,$self->{cache},$self->{trid_factory},$self->{logging}); $self->{registries}->{$regname}=$ndr; Net::DRI::Exception::err_method_not_implemented('tlds() in '.$reg) unless $drd->can('tlds'); foreach my $tld ($drd->tlds()) { $tld=lc($tld); $self->{tlds}->{$tld}=[] unless exists($self->{tlds}->{$tld}); push @{$self->{tlds}->{$tld}},$regname; } $self->log_output('notice','core','Successfully added registry "'.$regname.'"'); return $self; } sub del_registry { my ($self,$name)=@_; if (defined($name)) { err_registry_name_does_not_exist($name) unless (exists($self->{registries}->{$name})); } else { err_no_current_registry() unless (defined($self->{current_registry})); $name=$self->{current_registry}; } $self->{registries}->{$name}->end(); delete($self->{registries}->{$name}); $self->{current_registry}=undef if ($self->{current_registry} eq $name); $self->log_output('notice','core','Successfully deleted registry "'.$name.'"'); return $self; } #################################################################################################### sub err_no_current_registry { Net::DRI::Exception->die(0,'DRI',1,'No current registry available'); } sub err_registry_name_does_not_exist { Net::DRI::Exception->die(0,'DRI',2,'Registry name '.$_[0].' does not exist'); } #################################################################################################### ## Accessor functions sub available_registries { return sort(keys(%{shift->{registries}})); } sub available_registries_profiles { my ($self,$full)=@_; my %r; foreach my $reg (keys(%{$self->{registries}})) { $r{$reg}=[ $self->{registries}->{$reg}->available_profiles($full) ]; } return \%r; } sub registry_name { return shift->{current_registry}; } sub registry { my ($self)=@_; my $regname=$self->registry_name(); err_no_current_registry() unless (defined($regname) && $regname); err_registry_name_does_not_exist($regname) unless (exists($self->{registries}->{$regname})); my $ndr=$self->{registries}->{$regname}; return wantarray? ($regname,$ndr) : $ndr; } sub tld2reg { my ($self,$tld)=@_; return unless defined($tld) && $tld; $tld=lc($tld); $tld=$1 if ($tld=~m/\.([a-z0-9]+)$/); return unless exists($self->{tlds}->{$tld}); my @t=@{$self->{tlds}->{$tld}}; return @t; } sub installed_registries { return qw/AdamsNames AERO AFNIC AG ARNES ASIA AT AU BE BIZ BookMyName BR BZ CAT CentralNic CIRA CoCCA COOP CZ DENIC EURid Gandi GL HN IENUMAT IM INFO IRegistry IT LC LU ME MN MOBI NAME Nominet NO NU OpenSRS ORG OVH PL PRO PT SC SE SIDN SWITCH TRAVEL US VC VNDS WS/; } #################################################################################################### sub target { my ($self,$driver,$profile)=@_; ## Try to convert if given a domain name or a tld instead of a driver's name if (defined($driver) && !exists($self->{registries}->{$driver})) { my @t=$self->tld2reg($driver); Net::DRI::Exception->die(0,'DRI',7,'Registry not found for domain name/TLD '.$driver) unless (@t==1); $driver=$t[0]; } $driver=$self->registry_name() unless defined($driver); err_registry_name_does_not_exist($driver) unless defined($driver) && $driver; if (defined($profile)) { $self->{registries}->{$driver}->target($profile); } $self->{current_registry}=$driver; return $self; } #################################################################################################### ## The meat of everything ## See Cookbook, page 468 sub AUTOLOAD { my $self=shift; my $attr=$AUTOLOAD; $attr=~s/.*:://; return unless $attr=~m/[^A-Z]/; ## skip DESTROY and all-cap methods my ($name,$ndr)=$self->registry(); Net::DRI::Exception::err_method_not_implemented($attr.' in '.$ndr) unless (ref($ndr) && $ndr->can($attr)); $self->log_output('debug','core','Calling '.$attr.' from Net::DRI'); return $ndr->$attr(@_); ## is goto beter here ? } sub end { my $self=shift; while(my ($name,$v)=each(%{$self->{registries}})) { $v->end() if (ref($v) && $v->can('end')); $self->log_output('notice','core','Successfully ended registry "'.$name.'"'); $v={}; } $self->{tlds}={}; $self->{registries}={}; $self->{current_registry}=undef; if (defined $self->{logging}) { $self->log_output('notice','core','Successfully ended Net::DRI object'); $self->{logging}=undef; } } sub DESTROY { my $self=shift; $self->end(); } #################################################################################################### package Net::DRI::TrapExceptions; use base qw/Net::DRI/; our $AUTOLOAD; ## Some methods may die in Net::DRI, we specifically trap them sub add_registry { my $r; eval { $r=shift->SUPER::add_registry(@_); }; return $r unless $@; die(ref($@)? $@->as_string() : $@); } sub del_registry { my $r; eval { $r=shift->SUPER::del_registry(@_); }; return $r unless $@; die(ref($@)? $@->as_string() : $@); } sub registry { my @r; eval { @r=shift->SUPER::registry(@_); }; if (! $@) { return wantarray? @r : $r[0]; } die(ref($@)? $@->as_string() : $@); } sub target { my $r; eval { $r=shift->SUPER::target(@_); }; return $r unless $@; die(ref($@)? $@->as_string() : $@); } sub end { my $r; eval { $r=shift->SUPER::end(@_); }; return $r unless $@; die(ref($@)? $@->as_string() : $@); } sub AUTOLOAD { my $self=shift; my @r; $Net::DRI::AUTOLOAD=$AUTOLOAD; eval { @r=$self->SUPER::AUTOLOAD(@_); }; die(ref($@)? $@->as_string() : $@) if $@; return wantarray? @r : $r[0]; } #################################################################################################### 1; Net-DRI-0.96/README0000644000175000017500000005767411350050334013363 0ustar patrickpatrickNet::DRI is Copyright (C) 2005-2010, Patrick Mevzek Official website for Net::DRI information and download: http://www.dotandco.com/services/software/Net-DRI/index.en Net::DRI ======== A Perl library to access Domain Name Registries/Registrars: DRI stands for Domain Registration Interface and aims to be, for domain name registries/registrars/resellers what Perl DBI is for databases. Net::DRI offers a uniform API to access services. It can be used by registrars to access registries. It can be used by clients to access registrars and/or resellers. It can be used by anonyone to do whois, DAS or IRIS DCHK queries. It is an OO framework that can be easily extended to handle various protocols (RRP, EPP, custom protocols) and various transports methods (TCP, TLS, SOAP, email, etc...). Specific policies for each registry are handled in a Net::DRI::DRD subclass, DRD standing for Domain Registry Driver with registry being used broadly to describe a service offering domain names and related things, which can be provided by a true domain name registry, a registrar or a reseller at any level in the chain. Net::DRI standardizes as much as possible on EPP which is the current standard for domain name activities, for example for status codes. Net::DRI has been used to help conduct IETF interoperability tests, and is used in production by various organizations with success. Currently Net::DRI ships with: - a full RRP implementation (RFC 2832 & 3632) - a full EPP implementation (STD 69 aka RFC 5730/5731/5732/5733/5734/3735 ), including registry notifications - many EPP extensions: * GracePeriod (RFC 3915) * E164 for ENUM (RFC 4114) * Enum Validation (RFC 5076) * SecDNS for DNSSEC (RFC 4310) * Infrastructure ENUM in Austria * NSgroup (used by .BE and .EU) * CentralNic extensions: Release, TTL, WebForwarding * Domain/Contact/Host and other extensions needed for extra services in various TLD: .EU .COM .NET .MOBI .AERO .CAT .US .PL .SE .BE .AT .COOP .LU .ASIA .AU .NAME .ORG .UK .DE .CH .LI .HN .SC .VC .AG .BZ .LC .MN .ME .CZ .TRAVEL .NO .BR .JOBS .PRO .FR .PT .CX .GS .TL .KI .MS .MU .NF .HT .IM .SI .NG .NA .IT .NL .CA - a full DAS (Domain Availability Service) implementation for .BE .EU .NL .AU - a full Whois implementation (RFC 3912) for thin and thick registries : support included for domain names in .COM .NET .ORG .BIZ .INFO .AERO .EU .MOBI .NAME .LU .WS .SE .CAT .AT .TRAVEL .US .PT - an IRIS (RFC3981) implementation with LWZ transport (RFC4993) for DCHK (5144): currently only DENIC registry (.DE) provide this service XCP transport (RFC4992) is also available - an UDP/TCP/TLS socket transport - an HTTP/HTTPS transport - various SOAP transports over HTTP/HTTPS - an SMTP transport - Net::DRI::DRD::* modules for : .EU .COM .NET .TV .CC .WS .SE .PL .US .CAT .FR .BE .MOBI .INFO .ORG .AT .LU .BIZ .NAME .NU .UK .AU .AERO .ASIA .COOP IENUMAT .DE .CH .LI .HN .SC .VC .AG .BZ .LC .MN .ME .CZ .TRAVEL .PT .NO .BR .PRO CoCCA CentralNic .IM .SI .CO.CZ .IT AdamsNames .AU .GL .NL .CA - a Net::DRI::DRD::AFNIC covering AFNIC registry for .FR (only domain_check through web services and all operations by email or EPP) - Net::DRI::DRD::* modules to use registrars API for Gandi, OVH, BookMyName, OpenSRS - a shell (Net::DRI::Shell) providing autocompletion, logging and batch operations to be able to leverage all Net::DRI power without writing any line of code (see Net::DRI::Shell module documentation for all details) If you are a registry/registrar/reseller, we would welcome the opportunity to be able to test Net::DRI against your system. Please drop a note to the authors of Net::DRI and do not hesitate to provide this framework to your clients (see license file). If you are already using Net::DRI or planning to do so, please let us also know. Do not hesitate to let others know and if you want, you are welcome to make a link back to our website at Perl modules needed ------------------- Make sure to use at least Perl 5.8.4 as earlier versions have issues with utf8 handling which will cause errors for EPP. You also need the following modules: Carp (*) DateTime DateTime::Duration DateTime::Format::Strptime DateTime::Format::ISO8601 (>=0.06) DateTime::TimeZone Class::Accessor Class::Accessor::Chained Time::HiRes Email::Valid IO::Socket::INET (*) IO::Socket::SSL (>=0.90) XML::LibXML (>=1.61) UNIVERSAL::require SOAP::Lite (needed only for AFNIC, BookMyName, OVH, Gandi webservices) SOAP::WSDL (needed only for OVH webservices) MIME::Entity (needed only for AFNIC emails) Net::SMTP (needed only for AFNIC emails) LWP::UserAgent (needed only for OpenSRS, .PL and .IT) Digest::MD5 (needed only for OpenSRS) Net::DNS (needed only for .DE IRIS DCHK queries) IO::Uncompress::RawInflate (needed only for .DE IRIS DCHK queries) (*) All dates and durations exchanged with Net::DRI should be DateTime and DateTime::Duration objects Modules marked (*) are core Perl modules. Install ------- Use the standard procedure: perl Makefile.PL ; make ; make test ; make install Or just copy the content of the lib/ directory somewhere in your path. You can use tests available in t/ to make sure everything is well. (all tests are done locally and do not require a network connection; those who require a network connection are not enabled by default) LICENSE INFORMATION ------------------- This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. See the accompanying LICENSE file for all details. Some parts of this library have been contributed by other authors, and are copyrighted to them. See each specific module documentation. How to use ---------- You can find examples in the eg subdirectory: afnic_ws.pl : as AFNIC member, to use AFNIC web services afnic_email.pl : as AFNIC member, to use the email robot ws_rrp.pl : as registrar, to connect to .WS using RRP eurid_epp.pl : as registrar, connect to EURid test systems cat_epp.pl : as registrar, connect to .CAT test systems coop_epp.pl : as registrar, connect to .COOP test systems epp_client_no.pl (+ xmlfilter.pl) : as registrar, do operations with the .NO registry das.pl : for anyone, to check domain availability in various TLDs whois.pl : for anyone, to do whois queries for some TLDs. iris_dchk.pl : for anyone, to do IRIS DCHK queries for some .DE domain names In the t subdirectory, the test files can also be studied for insight of all the API available. All errors trigger an exception using die and a specific class (Net::DRI::Exception). Thus all calls to Net::DRI methods should be put in an eval() to easily trap exceptions. Please see Net::DRI::Exception for details about information available when an exception is raised. Net::DRI uses an internal cache (in the future many different backends will be available for this service), and you can provide the global time to live of objects in it when you create the Net::DRI object. A negative ttl means no cache at all. It is recommended not to completely disable the cache, and to have a ttl of at least of few seconds: it will cut down the use of checks and related verifications done at registry, especially for complex operations. Typical use of this library would be like the following (but please not that parts of this documentation may be outdated, and you should double check inside the Changes file as well as the examples described above and the test files): - $dri=Net::DRI->new(...) to create the global object. Save the result, everything will be done with methods applied on this object. You can choose the logging you wish (among base modules provided: no logging at all, all logging to STDERR and logging into files, one per registry+profile) and the cache time to live. See Net::DRI module documentation for more information on caching and logging. - $dri->add_registry(...) to add a new registry driver First argument is the registry class name (Net::DRI::DRD:: will be added if no :: is found), second argument is an hash ref setting information : you should have at least a clid key whose value is the client identifier at this registry for the client connecting (this is needed for the various _is_mine() methods - see below) You can attach as many registry drivers as you need to a single Net::DRI object this would enable you to easily operate on multiple registries at the same time Use $dri->target('registry name') to set the current registry, the one which will receive all future calls. The target method returns the $dri object, thus can be chained with other calls. Besides the registry name you can also pass a domain name or a TLD, and the library will try to find the correct registry. This will work only if you have no overlap between your TLDs among various registries - $dri->add_profile('profilename','profiletype',{transport params},{protocol params}) (or add_current_profile with same parameters as in add_profile and it will also set the default profile to the one being created) to use registry driver default for profiletype (see transport_protocol_default in each DRD modules) for transport & protocol classes. Each registry driver is used through a specific profile. Each driver can have at the same time as many profiles as needed. A profile is: - a name - a transport, with specific parameters - a protocol, with specific parameters This enables you to be connected to the same registries with different credentials at the same time, or through different transports, if the registry provides for example access by email and by TCP at the same time. You switch profile using the $dri->target('registry name','profile name') call. add_profile() and add_current_profile() return a Net::DRI::Protocol::ResultStatus in all cases, and this should be tested with ->is_success() to be sure the profile has been created correctly. They may also die for some other internal errors. Optionnally, you can use an auto target function: by providing details about which profile to use for each given action, Net::DRI can switch to the profile needed automatically, thus you will not need anymore to call target() by yourself. To do that, you will need to provide information by calling: $dri->set_auto_target('profile','type','action') Profile is the profile name to use when doing action 'action' (check, info, create, etc...) on object type 'type' (domain, host, contact). The profile must exist before calling set_auto_target() A default profile can be specified when type and/or action is undef. - after registries and profiles have been created (others can be added at any time), you can apply many methods (see below) to the $dri object You can change the current registry and/or current profile at any time using $dri->target(...,...) You get back for most of the calls an object representing the status. It is an instance of Net::DRI::Protocol::ResultStatus, please see its documentation. Through it you can access all details about the operation that has been done, including raw data, using the get_data() and get_data_collection() methods (see module documentation). As long as you keep the object, the data is there, and will not be deleted, while data in cache (and accessed through $dri->get_info()) will be deleted after its time to live has elapsed. You can also always use: result_is_success() result_code() result_native_code() result_message() result_lang() result_is_pending() result_trid() methods to get back the same information (if not given by the methods or if you want to discard output) Information that has been sent by registry will also be available through $dri->get_info(...) with a specific key. The key to use depends on the operation, but should be mostly registry-independent. get_info() gives back information related to the latest operation. If you use target() and later get_info() you will get information related to the latest operation for the registry/profile specified in the target() call. See below the list of methods you can call, and information available after each in get_info() - when you are finished, call $dri->end() to deallocate ressources and close any open connections. If using the Socket transport, you can make sure the connection is still open by using the ping() method, such as : $dri->transport()->ping() It will return 1 if the connection is still there, 0 otherwise. If you pass a true value to ping(), it will automatically reconnect if the connection is broken. Available API ------------- Please see the included tests (directory t/) and examples (directory eg/) for many examples of use and full API coverage. * has_object($type) gives 1 if the registry manages objects of type $type (domain, ns, contact, etc...) * periods() gives the list of all registration periods allowed by the current registry. Periods are given as DateTime::Duration objects. * is_my_tld() with a domain name as argument, returns 1 if the current registry handles this domain name (TLD of domain name is handled by registry) * cache_clear() completely delete cache for current registry and current profile * verify_name_domain() verify_name_host() gives 0 if the given argument is a correct name for a domain name or an hostname at the current registry. * verify_duration_create() verify_duration_renew() verify_duration_transfer() called internally at various stages in Net::DRI to verify that we can add/renew/transfer a domain name * domain_create() Create a domain name and associated operations (except if pure creation is asked) at the current registry and current profile. A domain name and an hash ref should be provided. The hash ref can have a "duration" key with its value being a DateTime::Duration object, and a "ns" key with its value being a Net::DRI::Data::Hosts object. The following operations are done (if pure creation is asked, only step 4 is done): 0) we do a domain_check operation and stop if the domain exists already 1) we separate nameservers : those being inside domain name being created, those being outside 2) we test outside nameservers for existence at registry, and if it fails, we try to create them 3) we create all needed contacts, for thick registries 4) we create domain 5) we create nameservers that are inside domain (in-bailiwick nameservers) 6) we update domain to add nameservers created at step 5. 7) if a status key exists in hash ref given, we try to change status of newly created domain name You get back a ResultStatus that may contain all results chained, see this module documentation. You may use get_info with the following keys to get more information: - exDate : for the current expiration date (a DateTime object) - status : for the current status of domain name * domain_delete() Delete a domain and associated opeations (except if a pure deletion is askedt) at the current registry and current profile. A domain name should be provided. The following operations are done (if pure delete is asked, only step 3 is done): 1) we find the current list of nameservers for this domain 2) we remove all nameservers from this domain 3) we delete the domain name (which can fail if some nameservers use the domain name in their FQDN, we should try to rename them first, it is planned for later) See domain_create() for information on what you get back. * domain_info() Ask for all information on a given domain name at the current registry and current profile. A second optional parameter is an hash ref. It can include an auth key, for EPP registries for example. You may use get_info or ResultStatus::get_data with the following keys to get more information: - ns : a Net::DRI::Data::Hosts object representing the nameservers of the domain - status : a Net::DRI::Data::StatusList object representing the current status list of the domain queried - exDate, crDate, upDate, trDate : DateTime objects representing the expiration, creation, last update, and transfer date for the domain queried - clID, crID, upID : (strings) local registry ID of the current sponsoring registrar, the registrar having created, and the registrar (or registry) having last modified the domain queried * domain_check() Check if a domain name exists or not at the current registry and current profile. $dri->get_info('exist') returns 0 or 1 * domain_check_multi() Check if the given list of domain names exist or not at the current registry and current profile. $dri->get_info('exist','domain',$domain) returns 0 or 1 for the given domain name in $domain (the cache ttl must be positive and large enough (few seconds) for that to work) ; you can also use $rc->get_data('domain',$domain,'exist') - please note the different API - which will always have data, independently from cache. * domain_exist() Same as previous, but we get back 0 or 1 if the domain does not exist/exist or undef if we do not know. * domain_update() Update the domain name given as argument at the current registry and current profile. Most of the time you should use the following more specific methods. * domain_update_ns() Update nameservers of the domain name given as argument at the current registry and current profile. Most of the time you should use the following more specific methods. * domain_update_ns_add() For the given domain name as first argument, add the nameservers given as second argument (being a Net::DRI::Data::Hosts object). * domain_update_ns_del() Same as previous to delete nameservers * domain_update_ns_set() Same as previous to set the current list of nameservers, irrespective to what they are now. * domain_update_status() Update statuses of the domain name given as argument at the current registry and current profile. Most of the time you should use the following more specific methods. * domain_update_status_add() For the given domain name as first argument, add the statuses given as second argument. To create the second argument, call $dri->create_status()->no() with up to three parameters : - first one is a string among renew, update, transfer, publish, delete (choices depending on the registry), which sets what is forbidden, - second (optional) one is a message (ex: Payment overdue), - third (optional, default to 'en') is the language of the previous message. The call to ->create_status() creates a new object from a class which is a subclass of Net::DRI::Data::StatusList, that can be used in all functions related to statuses. * domain_update_status_del() Same as previous to delete statuses. * domain_update_status_set() Same as previous to set the current list of status, irrespective to what they are now. * domain_update_contact() Update contacts of the domain name given as argument at the current registry and current profile. Most of the time you should use the following more specific methods. * domain_update_contact_add() For the given domain name as first argument, add the contacts given as second argument which is a Net::DRI::Data::ContactSet instance. * domain_update_contact_del() Same as previous to delete contacts. * domain_update_contact_set() Same as previous to set the current list of contacts, irrespective to what they are now. * domain_renew() Renew the domain name provided as first argument, with optionnally a ref hash, with keys duration and current_expiration. You may use get_info() to retrieve the same information as after domain_create() * domain_transfer() Various operations related to transfers of domain names. Most of the time you should use the following more specific methods. * domain_transfer_start() Start the transfer of the given domain name as first argument. A second optional argument is an hash ref that can include for example an auth key for authorization information. * domain_transfer_stop() Stop the transfer of the given domain name as first argument (used by the registrar having started the transfer). A second optional argument is an hash ref that can include for example an auth key for authorization information. * domain_transfer_query() Query the state of the ongoing transfer for the given domain name as first argument. A second optional argument is an hash ref that can include for example an auth key for authorization information. * domain_transfer_accept() Accept the transfer of the given domain name as first argument (used by the registrar currently sponsoring the domain name). A second optional argument is an hash ref that can include for example an auth key for authorization information. * domain_transfer_refuse() Refuse the transfer of the given domain name as first argument (used by the registrar currently sponsoring the domain name). A second optional argument is an hash ref that can include for example an auth key for authorization information. * domain_can() For the domain name given as first argument, and for the operation given as second (being either 'renew','update','delete' or 'tranfer'), returns 1 if we can do the requested operation at the current registry and current profile. We check the domain name status, and if possible who sponsors currently the domain name, and if the action requested needs sponsorship. * domain_status_allows() Check if the current status of the domain name given as first argument allows for a specific operation. Most of the time you should use the following more specific methods. * domain_status_allows_delete() Returns 1 if we can delete the domain name given as first argument at the current registry and current profile. Else, 0. * domain_status_allows_update() Same for update. * domain_status_allows_renew() Same for renew. * domain_status_allows_transfer() Same for transfer. * domain_current_status() Returns the status of the domain name given as first argument at the current registry and current profile. (status is a Net::DRI::Data::StatusList or subclass object) * domain_is_mine() Returns 1 if we are the current sponsor of the domain name given as first argument at the current registry and current profile. Else, 0. * host_create() Create a new nameserver. The first argument should be a Net::DRI::Data::Hosts object. Some registries may require or permit a second argument, used in the same way as in domain_create() * host_delete() Delete a nameserver. The first and only argument should be a Net::DRI::Data::Hosts object or a string. * host_info() Retrieve information about a namserver. The first and only argument should be a Net::DRI::Data::Hosts object or a string. You may use get_info with the following keys to get more information: - self : a Net::DRI::Data::Hosts for the nameserver itself (name + IP addresses) - exDate, crDate, upDate, trDate, clID, crID, upID : see domain_info() * host_check() * host_check_multi() * host_exist() * host_update() * host_update_ip() * host_update_ip_add() * host_update_ip_del() * host_update_ip_set() * host_update_status() * host_update_status_add() * host_update_status_del() * host_update_status_set() * host_update_name_set() * host_current_status() * host_is_mine() See corresponding domain_* methods. * contact_create() Create a new contact at registry. The first and only argument should be a Net::DRI::Data::Contact object (or one of its subclasses). * contact_delete() * contact_info() * contact_check() * contact_check_multi() * contact_exist() * contact_update() * contact_update_status() * contact_update_status_add() * contact_update_status_del() * contact_update_status_set() * contact_transfer() * contact_transfer_start() * contact_transfer_stop() * contact_transfer_query() * contact_transfer_accept() * contact_transfer_refuse() * contact_is_mine() See above methods. * message_retrieve() message_delete() message_waiting() message_count() : to handle registry messages (see t/601vnds_epp.t) Net-DRI-0.96/INSTALL0000644000175000017500000000621510336171402013520 0ustar patrickpatrickDocumentation contributed by Tom van der Geer ============================================= Most of this installation instruction is basic CPAN shell installation practice, but hey... If you think you don't need it, don't read it :o) A) Install required OS libraries (make sure you have a working development environment: make, gcc, etc.) Download latest SSL library (www.openssl.org), unpack, build and install B) Install Net::DRI dependencies 1. open the CPAN shell: perl -MCPAN -e shell If this is the first time, it will run the CPAN shell setup procedure. You can usually get away by accepting all the default values. Be aware that it should find most of the required binaries (tar, make, wget, etc.) 2. On the CPAN shell commandline install the dependencies which are listed in the README of the Net::DRI tarbal. Just type: install in this case can be e.g. DateTime (mind lower- and uppercase characters) It can also be a 'sub'-module like SOAP::Lite (also include the '::'!) Whenever you install a module that is listed as dependency in the README it might depend on other modules as well. This will typically look something like: ---- Unsatisfied dependencies detected during [J/JH/JHOBLITT/DateTime-Format-ISO8601-0.0403.tar.gz] ----- DateTime::Format::Builder Shall I follow them and prepend them to the queue of modules we are processing right now? [yes] Just accept prepending them to the queue. (default) My experience was that not all dependencies are properly detected like the example above. This can lead to those nasty errors during the test-phase of a module installation. E.g. during the installation of DateTime: t/07compare.............ok 17/26Can't locate Class/Singleton.pm in @INC The way I deal with them is: Scroll back in the modules testing log and locate the missing module. In this case "Class/Singleton.pm" which is part of module Class::Singleton. (not hard to figure that out, right?) Now first do: install Class::Singleton and after you've succesfuly installed this missing module, you can resume installing the module you wanted to install. In this case just type the installation line again: install DateTime NOTE. I found during the installtion of the Net::DRI dependency modules that I needed to additionally install the following modules. (yes, that's on top of all the official dependencies listed): File::Find::Rule Test::Pod Class::Singleton Net::SSLeay MIME::Parser So you might want to install these "just in case" before you run into errors. It won't harm your system if you do this without ever needing them. As a last resort, when there seem to be no more missing dependencies but the test still lists errors, you might choose to do a 'forced' install: force install SOAP::Lite Only do this when you made sure there are no missing dependencies! (Uhum.... I had to do this for one or two modules..... But hey, it works now) C) Install the Net::DRI module Finally we can install Net::DRI smoothly: install Net::DRI If the installation exits with "/usr/bin/make install -- OK" there's nothing more standing between you and using the Net::DRI module. (Go treat yourself a beer)