Net::DRI::Shell - Command Line Shell for Net::DRI, with batch features and autocompletion support
Index
Code Index:
NAME
Net::DRI::Shell - Command Line Shell for Net::DRI, with batch features and autocompletion support
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
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.
AVAILABLE COMMANDS
After having started this shell, the available commands are the following.
SESSION COMMANDS
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.
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 !
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.
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.
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).
show tlds
Show the list of TLDs handled by the currently selected registry.
show periods
Show the list of allowed periods (domain name durations) for the currently selected registry.
show objects
Show the list of managed objects types at the currently selected registry.
show types
Show the list of profile types at the currently selected registry
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).
show config
This will show all current config options. See set command below for the list of config options.
set OPTION=VALUE
The set command can be used to change some options inside the shell.
The current list of available options is:
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.
target REGISTRYNAME PROFILENAME
Switch to registry REGISTRYNAME (from currently available registries) and profile PROFILENAME (from currently available
profiles in registry REGISTRYNAME).
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.
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.
!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.
help
Returns a succinct list of available commands.
quit
DOMAIN COMMANDS
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.
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.
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.
domain_exist DOMAIN
A kind of simpler domain_check, just reply by YES or NO for the given domain name.
domain_transfer_start DOMAIN auth=AUTHCODE [duration=PERIOD]
domain_transfer_stop DOMAIN [auth=AUTHCODE]
domain_transfer_query DOMAIN [auth=AUTHCODE]
domain_transfer_accept DOMAIN [auth=AUTHCODE]
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).
domain_update_ns_set DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
domain_update_ns_add DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
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.
domain_update_status_set DOMAIN STATUS1 STATUS2 ...
domain_update_status_add DOMAIN STATUS1 STATUS2 ...
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).
domain_update_contact_set DOMAIN SRVID1 SRVID2 ...
domain_update_contact_add DOMAIN SRVID2 SRVID2 ...
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.
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.
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.
domain_delete DOMAIN
Delete the given domain name.
HOST COMMANDS
For registries handling nameservers as separate objects.
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.
host_delete HOSTNAME
host_info HOSTNAME
host_check HOSTNAME
Various operations on host objects.
host_update_ip_set HOSTNAME IP1 IP2 ...
host_update_ip_add HOSTNAME IP1 IP2 ...
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.
host_update_status_set HOSTNAME STATUS1 STATUS2 ...
host_update_status_add HOSTNAME STATUS1 STATUS2 ...
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).
host_update HOSTNAME +ip=IP1 +ip=IP2 -ip=IP3 +status=STATUS1 -status=STATUS2 name=NEWNAME
Combines the previous operations.
host_update_name_set HOSTNAME NEWNAME
Change the current name of host objects from HOSTNAME to NEWNAME.
For registries handling contacts as separate objects.
Various operations on contacts.
Start, or stop an incoming transfer, query status of a current running transfer, accept or refuse an outgoing contact transfer.
MESSAGE COMMANDS
For registries handling messages, like EPP poll features.
message_retrieve [ID]
Retrieve a message waiting at registry.
message_delete [ID]
Delete a message waiting at registry.
message_waiting
Notifies if messages are waiting at registry.
message_count
Get the numbers of messages waiting at the registry.
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.
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).
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.
SUPPORT
For now, support questions should be sent to:
<netdri@dotandco.com>
Please also see the SUPPORT file in the distribution.
SEE ALSO
<http://www.dotandco.com/services/software/Net-DRI/>
AUTHOR
Patrick Mevzek, <netdri@dotandco.com>
COPYRIGHT
Copyright (c) 2008-2010 Patrick Mevzek <netdri@dotandco.com>.
All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
See the LICENSE file that comes with this distribution for more details.
## Domain Registry Interface, Shell interface
##
## Copyright (c) 2008-2010 Patrick Mevzek <netdri@dotandco.com>. All rights reserved.
##
## This file is part of Net::DRI
##
## Net::DRI is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of 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 :-)
####################################################################################################
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=<<EOF;
Available commands (parameters after the first one can be in any order):
help
add registry=REGISTRYNAME type=TYPE [cLID=YOURLOGIN]
add_registry registry=REGISTRYNAME [clID=YOURLOGIN]
add_current_profile name=PROFILENAME type=TYPE defer=0 client_login=YOURLOGIN client_password=YOURPASSWORD
get_info_all
show profiles
show tlds
show periods
show objects
show status
show config
set P=X
target X Y
run FILENAME
record FILENAME
quit
domain_create DOMAIN [duration=X] [ns=HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...] [admin=SRID1] [registrant=SRID2] [billing=SRID3] [tech=SRID4] [auth=X]
domain_info DOMAIN
domain_check DOMAIN
domain_exist DOMAIN
domain_transfer_start DOMAIN auth=AUTHCODE [duration=PERIOD]
domain_transfer_stop DOMAIN [auth=AUTHCODE]
domain_transfer_query DOMAIN [auth=AUTHCODE]
domain_transfer_accept DOMAIN [auth=AUTHCODE]
domain_transfer_refuse DOMAIN [auth=AUTHCODE]
domain_update_ns_set DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
domain_update_ns_add DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
domain_update_ns_del DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
domain_update_status_set DOMAIN STATUS1 STATUS2 ...
domain_update_status_add DOMAIN STATUS1 STATUS2 ...
domain_update_status_del DOMAIN STATUS1 STATUS2 ...
domain_update_contact_set DOMAIN SRVID1 SRVID2 ...
domain_update_contact_add DOMAIN SRVID2 SRVID2 ...
domain_update_contact_del DOMAIN SRVID1 SRVID2 ...
domain_update DOMAIN +status=S1 -status=S2 +admin=C1 -tech=C2 -billing=C3 registrant=C4 auth=A +ns=... -ns=...
domain_renew DOMAIN [duration=X] [current_expiration=YYYY-MM-DD]
domain_delete DOMAIN
host_create HOSTNAME IP1 IP2 ...
host_delete HOSTNAME
host_info HOSTNAME
host_check HOSTNAME
host_update_ip_set HOSTNAME IP1 IP2 ...
host_update_ip_add HOSTNAME IP1 IP2 ...
host_update_ip_del HOSTNAME IP1 IP2 ...
host_update_status_set HOSTNAME STATUS1 STATUS2 ...
host_update_status_add HOSTNAME STATUS1 STATUS2 ...
host_update_status_del HOSTNAME STATUS1 STATUS2 ...
host_update_name_set HOSTNAME NEWNAME
host_update HOSTNAME +ip=IP1 +ip=IP2 -ip=IP3 +status=STATUS1 -status=STATUS2 name=NEWNAME ...
contact_create name=X org=Y street=Z1 street=Z2 email=A voice=B ...
contact_delete SRID
contact_info SRID
contact_check SRID
contact_update_status_set SRID STATUS1 STATUS2 ...
contact_update_status_add SRID STATUS1 STATUS2 ...
contact_update_status_del SRID STATUS1 STATUS2 ...
contact_update SRID name=X org=Y ... +status=... -status=...
contact_transfer_start SRID
contact_transfer_stop SRID
contact_transfer_query SRID
contact_transfer_accept SRID
contact_transfer_refuse SRID
message_retrieve [ID]
message_delete [ID]
message_waiting
message_count
EOF
return (undef,$m);
}
sub record
{
my ($ctx,$n)=@_;
my $m='';
## Need to stop the current one in all cases ! (true record stop or a new record start)
if (defined($ctx->{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 '<undef>' 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;