File Coverage

blib/lib/Net/DRI/Shell.pm
Criterion Covered Total %
statement 30 852 3.5
branch 0 454 0.0
condition 0 166 0.0
subroutine 10 59 16.9
pod 3 45 6.6
total 43 1576 2.7


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Shell interface
2             ##
3             ## Copyright (c) 2008-2014,2016 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             ####################################################################################################
14              
15             package Net::DRI::Shell;
16              
17 1     1   1406 use strict;
  1         1  
  1         23  
18 1     1   3 use warnings;
  1         1  
  1         21  
19              
20 1     1   3 use Exporter qw(import);
  1         1  
  1         31  
21             our @EXPORT_OK=qw(run);
22              
23 1     1   3 use Net::DRI;
  1         1  
  1         5  
24 1     1   19 use Net::DRI::Util;
  1         1  
  1         14  
25 1     1   2 use Net::DRI::Protocol::ResultStatus;
  1         1  
  1         5  
26 1     1   531 use Term::ReadLine; ## see also Term::Shell
  1         1932  
  1         41  
27 1     1   4 use Time::HiRes ();
  1         1  
  1         12  
28 1     1   4 use IO::Handle ();
  1         1  
  1         3815  
29              
30             our $HISTORY=(exists $ENV{HOME} && defined $ENV{HOME} && length $ENV{HOME})? $ENV{HOME}.'/.drish_history' : undef;
31              
32             exit __PACKAGE__->run(@ARGV) if (!caller() || caller() eq 'PAR'); ## This is a modulino :-)
33              
34             =pod
35              
36             =head1 NAME
37              
38             Net::DRI::Shell - Command Line Shell for Net::DRI, with batch features and autocompletion support
39              
40             =head1 SYNOPSYS
41              
42             perl -I../../ ./Shell.pm
43             or
44             perl -MNet::DRI::Shell -e run
45             or
46             perl -MNet::DRI::Shell -e 'Net::DRI::Shell->run()'
47             or in your programs:
48             use Net::DRI::Shell;
49             Net::DRI::Shell->run();
50              
51             Welcome to Net::DRI $version shell, pid $pid
52             Net::DRI object created with a cache TTL of 10 seconds and logging into files in current directory
53              
54             NetDRI> add_registry registry=EURid client_id=YOURID
55             NetDRI(EURid)> add_current_profile name=profile1 type=epp client_login=YOURLOGIN client_password=YOURPASSWORD
56             Profile profile1 added successfully (1000/COMMAND_SUCCESSFUL) SUCCESS
57             NetDRI(EURid,profile1)> domain_info example.eu
58             Command completed successfully (1000/1000) SUCCESS
59             NetDRI(EURid,profile1)> get_info_all
60              
61             ... all data related to the domain name queried ...
62              
63             NetDRI(EURid,profile1)> domain_check whatever.eu
64             Command completed successfully (1000/1000) SUCCESS
65             NetDRI(EURid,profile1)> get_info_all
66              
67             ... all data related to the domain name queried ...
68              
69             NetDRI(EURid,profile1)> show profiles
70             EURid: profile1
71             NetDRI(EURid,profile1)> quit
72              
73              
74             =head1 DESCRIPTION
75              
76             This is a shell to be able to use Net::DRI without writing any code.
77              
78             Most of the time commands are the name of methods to use on the Net::DRI object,
79             with some extra ones and some variations in API to make passing parameters simpler.
80              
81             =head1 AVAILABLE COMMANDS
82              
83             After having started this shell, the available commands are the following.
84              
85             =head2 SESSION COMMANDS
86              
87             =head3 add_registry registry=REGISTRYNAME client_id=YOURID
88              
89             Replace REGISTRYNAME with the Net::DRI::DRD module you want to use, and YOURID
90             with your client identification for this registry (may be the same as the login used
91             to connect, or not).
92              
93             =head3 add_current_profile name=profile1 type=epp client_login=YOURLOGIN client_password=YOURPASSWORD
94              
95             This will really connect to the registry, replace YOURLOGIN by your client login at registry,
96             and YOURPASSWORD by the associated password. You may have to add parameters remote_host= and remote_port=
97             to connect to other endpoints than the hardcoded default which is most of the time the registry OT&E server,
98             and not the production one !
99              
100             =head3 add registry=REGISTRYNAME client_id=YOURID name=profile1 type=epp client_login=YOURLOGIN client_password=YOURPASSWORD
101              
102             This is a shortcut, doing the equivalent of add_registry, and then add_current_profile.
103              
104             =head3 get_info_all
105              
106             After each call to the registry, like domain_info or domain_check, this will list all available data
107             retrieved from registry. Things are pretty-printed as much as possible. You should call get_info_all
108             right after your domain_something call otherwise if you do another operation previous information
109             is lost. This is done automatically for you on the relevant commands, but you can also use it
110             manually at any time.
111              
112             =head3 show profiles
113              
114             Show the list of registries and associated profiles currently in use (opened in this shell with
115             add_registry + add_current_profile, or add).
116              
117             =head3 show tlds
118              
119             Show the list of TLDs handled by the currently selected registry.
120              
121             =head3 show periods
122              
123             Show the list of allowed periods (domain name durations) for the currently selected registry.
124              
125             =head3 show objects
126              
127             Show the list of managed objects types at the currently selected registry.
128              
129             =head3 show types
130              
131             Show the list of profile types at the currently selected registry
132              
133             =head3 show status
134              
135             Show the list of available status for the currently selected registry, to use
136             as status name in some commands below (domain_update_status_* domain_update
137             host_update_status_* host_update contact_update_status_* contact_update).
138              
139             =head3 show config
140              
141             This will show all current config options. See C command below for the list of config options.
142              
143             =head3 set OPTION=VALUE
144              
145             The set command can be used to change some options inside the shell.
146              
147             The current list of available options is:
148              
149             =head4 verbose
150              
151             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
152             all displaying raw data exchanged with registry.
153              
154             =head3 target REGISTRYNAME PROFILENAME
155              
156             Switch to registry REGISTRYNAME (from currently available registries) and profile PROFILENAME (from currently available
157             profiles in registry REGISTRYNAME).
158              
159             =head3 run FILENAME
160              
161             Will open the local FILENAME and read in it commands and execute all of them; you can also
162             start your shell with a filename as argument and its commands will be run at beginning of
163             session before giving the control back. They will be displayed (username and password will be
164             masked) with their results.
165              
166             =head3 record FILENAME
167              
168             If called with a filename argument, all subsequent commands, and their results will be printed in the filename given.
169             If called without argument, it stops a current recording session.
170              
171             =head3 !cmd
172              
173             All command line starting with a bang (!) will be treated as local commands to run through the local underlying OS shell.
174              
175             Example: !ls -l
176             will display the content of the current directory.
177              
178             =head3 help
179              
180             Returns a succinct list of available commands.
181              
182             =head3 quit
183              
184             Leave the shell.
185              
186             =head2 DOMAIN COMMANDS
187              
188             =head3 domain_create DOMAIN [duration=X] [ns=HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...] [admin=SRID1] [registrant=SRID2] [billing=SRID3] [tech=SRID4] [auth=X]
189              
190             Create the given domain name. See above for the duration format to use. Admin, registrant, billing and tech
191             contact ids are mandatory or optional depending on the registry. They may be repeated (except registrant)
192             for registries allowing multiple contacts per role.
193              
194             =head3 domain_info DOMAIN
195              
196             Do a domain_info call to the registry for the domain YOURDOMAIN ; most of the the registries
197             prohibit getting information on domain names you do not sponsor.
198              
199             =head3 domain_check DOMAIN
200              
201             Do a domain_check call to the registry for the domain ANYDOMAIN ; you can check any domain,
202             existing or not, if you are the sponsoring registrar or not.
203              
204             =head3 domain_exist DOMAIN
205              
206             A kind of simpler domain_check, just reply by YES or NO for the given domain name.
207              
208             =head3 domain_transfer_start DOMAIN auth=AUTHCODE [duration=PERIOD]
209              
210             =head3 domain_transfer_stop DOMAIN [auth=AUTHCODE]
211              
212             =head3 domain_transfer_query DOMAIN [auth=AUTHCODE]
213              
214             =head3 domain_transfer_accept DOMAIN [auth=AUTHCODE]
215              
216             =head3 domain_transfer_refuse DOMAIN [auth=AUTHCODE]
217              
218             Start, or stop an incoming transfer, query status of a current running transfer, accept or refuse an outgoing domain name transfer.
219              
220             The AUTHCODE is mandatory or optional, depending on the registry.
221              
222             The duration is optional and can be specified (the allowed values depend on the registry) as Ayears or Bmonths
223             where A and B are integers for the number of years or months (this can be abbreviated as Ay or Bm).
224              
225             =head3 domain_update_ns_set DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
226              
227             =head3 domain_update_ns_add DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
228              
229             =head3 domain_update_ns_del DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
230              
231             Set the current list of nameservers associated to this DOMAIN, add to the current list or delete from the current list.
232              
233             =head3 domain_update_status_set DOMAIN STATUS1 STATUS2 ...
234              
235             =head3 domain_update_status_add DOMAIN STATUS1 STATUS2 ...
236              
237             =head3 domain_update_status_del DOMAIN STATUS1 STATUS2 ...
238              
239             Set the current list of status associated to this DOMAIN, add to the current
240             list or delete from the current list. First parameter is the domain name, then status names,
241             as needed.
242              
243             The status names are those in the list given back by the show status command (see above).
244              
245             =head3 domain_update_contact_set DOMAIN SRVID1 SRVID2 ...
246              
247             =head3 domain_update_contact_add DOMAIN SRVID2 SRVID2 ...
248              
249             =head3 domain_update_contact_del DOMAIN SRVID1 SRVID2 ...
250              
251             Set the current list of contacts associated to this DOMAIN, add to the current list or delete from the current list
252             by providing the contact server ids.
253              
254             =head3 domain_update DOMAIN +status=S1 -status=S2 +admin=C1 -tech=C2 -billing=C3 registrant=C4 auth=A +ns=... -ns=...
255              
256             Combination of the previous methods, plus ability to change authInfo and other parameters depending on registry.
257              
258             =head3 domain_renew DOMAIN [duration=X] [current_expiration=YYYY-MM-DD]
259              
260             Renew the given domain name. Duration and current expiration are optional. See above for the duration format to use.
261              
262             =head3 domain_delete DOMAIN
263              
264             Delete the given domain name.
265              
266              
267             =head2 HOST COMMANDS
268              
269             For registries handling nameservers as separate objects.
270              
271             =head3 host_create HOSTNAME IP1 IP2 ...
272              
273             Create the host named HOSTNAME at the registry with the list of IP (IPv4 and IPv6
274             depending on registry support) given.
275              
276             =head3 host_delete HOSTNAME
277              
278             =head3 host_info HOSTNAME
279              
280             =head3 host_check HOSTNAME
281              
282             Various operations on host objects.
283              
284             =head3 host_update_ip_set HOSTNAME IP1 IP2 ...
285              
286             =head3 host_update_ip_add HOSTNAME IP1 IP2 ...
287              
288             =head3 host_update_ip_del HOSTNAME IP1 IP2 ...
289              
290             Set the current list of IP addresses associated to this HOSTNAME, add to the current
291             list or delete from the current list. First parameter is the nameserver hostname, then IP addresses,
292             as needed.
293              
294             =head3 host_update_status_set HOSTNAME STATUS1 STATUS2 ...
295              
296             =head3 host_update_status_add HOSTNAME STATUS1 STATUS2 ...
297              
298             =head3 host_update_status_del HOSTNAME STATUS1 STATUS2 ...
299              
300             Set the current list of status associated to this HOSTNAME, add to the current
301             list or delete from the current list. First parameter is the nameserver hostname, then status names,
302             as needed.
303              
304             The status names are those in the list given back by the show status command (see above).
305              
306             =head3 host_update HOSTNAME +ip=IP1 +ip=IP2 -ip=IP3 +status=STATUS1 -status=STATUS2 name=NEWNAME
307              
308             Combines the previous operations.
309              
310             =head3 host_update_name_set HOSTNAME NEWNAME
311              
312             Change the current name of host objects from HOSTNAME to NEWNAME.
313              
314              
315             =head2 CONTACT COMMANDS
316              
317             For registries handling contacts as separate objects.
318              
319             =head3 contact_create name=X org=Y street=Z1 street=Z2 email=A voice=B ...
320              
321             Create a new contact object.
322              
323             The list of mandatory attributes depend on the registry. Some attributes (like street) may appear multiple times.
324              
325             Some registry allow setting an ID (using srid=yourchoice), others create the ID, in which case you need
326             to do a get_info_all after contact_create to retrieve the given server ID.
327              
328             =head3 contact_delete SRID
329              
330             =head3 contact_info SRID
331              
332             =head3 contact_check SRID
333              
334             Various operations on contacts.
335              
336             =head3 contact_update_status_set SRID STATUS1 STATUS2 ...
337              
338             =head3 contact_update_status_add SRID STATUS1 STATUS2 ...
339              
340             =head3 contact_update_status_del SRID STATUS1 STATUS2 ...
341              
342             Set the current list of status associated to this contact SRID, add to the current
343             list or delete from the current list. First parameter is the contact server ID, then status names,
344             as needed.
345              
346             The status names are those in the list given back by the show status command (see above).
347              
348             =head3 contact_update SRID name=X org=Y ... +status=... -status=...
349              
350             Change some contacts attributes, as well as statuses.
351              
352             =head3 contact_transfer_start SRID
353              
354             =head3 contact_transfer_stop SRID
355              
356             =head3 contact_transfer_query SRID
357              
358             =head3 contact_transfer_accept SRID
359              
360             =head3 contact_transfer_refuse SRID
361              
362             Start, or stop an incoming transfer, query status of a current running transfer, accept or refuse an outgoing contact transfer.
363              
364              
365             =head2 MESSAGE COMMANDS
366              
367             For registries handling messages, like EPP poll features.
368              
369             =head3 message_retrieve [ID]
370              
371             Retrieve a message waiting at registry.
372              
373             =head3 message_delete [ID]
374              
375             Delete a message waiting at registry.
376              
377             =head3 message_waiting
378              
379             Notifies if messages are waiting at registry.
380              
381             =head3 message_count
382              
383             Get the numbers of messages waiting at the registry.
384              
385             =head1 COMPLETION
386              
387             If Term::Readline::Gnu or Term::Readline::Perl are installed, it will be automatically used by this shell
388             to provide standard shell autocompletion for commands and parameters.
389              
390             All commands described above will be available through autocompletion. As you use them,
391             all parameters (domain names, contacts, hostnames, local files) will also be stored
392             and provided to later autocompletion calls (with the [TAB] key).
393              
394             It will also autocomplete registry= and type= parameters during add/add_registry, from
395             a basic default set of values: registry= values are taken from a basic Net::DRI install
396             without taking into account any private DRD module, and type= values are a default set,
397             not checked against registry= value.
398             Same for target calls, where registry and/or profile name will be autocompleted as possible.
399              
400             It will even autocomplete TLD on domain names for your current registry after your typed
401             the first label and a dot (and eventually some other characters), during any domain name operation.
402             Same for durations and status values.
403              
404             Contacts and nameservers will also be autocompleted when used in any domain_* operation.
405              
406             Contacts attributes will be autocompleted during contact_create based on the current registry & profile.
407              
408             Information retrieved with domain_info calls will also be used in later autocompletion tries,
409             regarding contact ids and hostnames. During a contact creation, the registry returned contact id
410             is also added for later autocompletion tries.
411              
412             For autocompletion, contacts are specific to each registry. Hostnames are common to all registries,
413             as are domain names, but domain names are checked against the available TLDs of the current registry when used
414             for autocompletion.
415              
416             =head1 LOGGING
417              
418             By default, all operations will have some logging information done in files stored in
419             the working directory. There will be a core.log file for all operations and then one
420             file per tuple (registry,profile).
421              
422             =head1 BATCH OPERATIONS
423              
424             Batch operations are available for some domain name commands: domain_create,
425             domain_delete, domain_renew, domain_check, domain_info, domain_transfer and
426             all domain_update commands. It can be used on a list of domain names for which
427             all other parameters needed by the command are the same.
428              
429             To do that, just use the command normally as outlined above, but instead of the
430             domain name, put a file path, with at least one / (so for a file "batch.txt" in the
431             current directory, use "./batch.txt").
432              
433             If you use backticks such as `command` for the domain name, the command will
434             be started locally and its output will be used just like a file.
435              
436             The shell will then apply the command and its parameters on the domain names
437             listed in the specified file: you should have one domain name per line, blank
438             lines and lines starting with # are ignored.
439              
440             At the same place a new file is created with a name derived from the given name
441             in which the result of each domain name command will be written. If "input" is
442             the filename used, the results will be written to "input.PID.TIME.results"
443             where PID is the program id of the running shell for these commands and TIME the
444             Unix epoch when the batch started.
445              
446             As output the shell will give a summary of the number of operations done
447             for each possible outcome (success or error), as well as time statistics.
448              
449             =head1 SUPPORT
450              
451             For now, support questions should be sent to:
452              
453             Enetdri@dotandco.comE
454              
455             Please also see the SUPPORT file in the distribution.
456              
457             =head1 SEE ALSO
458              
459             Ehttp://www.dotandco.com/services/software/Net-DRI/E
460              
461             =head1 AUTHOR
462              
463             Patrick Mevzek, Enetdri@dotandco.comE
464              
465             =head1 COPYRIGHT
466              
467             Copyright (c) 2008-2014,2016 Patrick Mevzek .
468             All rights reserved.
469              
470             This program is free software; you can redistribute it and/or modify
471             it under the terms of the GNU General Public License as published by
472             the Free Software Foundation; either version 2 of the License, or
473             (at your option) any later version.
474              
475             See the LICENSE file that comes with this distribution for more details.
476              
477             =cut
478              
479             ####################################################################################################
480              
481             sub run
482             {
483 0     0 1   my (@args)=@_;
484 0           my $term=Term::ReadLine->new('Net::DRI shell');
485 0           $term->MinLine(undef); # disable implicit add_history call()
486 0   0       my $ctx={ term => $term,
487             term_features => $term->Features(),
488             term_attribs => $term->Attribs(),
489             dprompt => 'NetDRI',
490             output => $term->OUT() || \*STDOUT,
491             record_filename => undef,
492             record_filehandle => undef,
493             config => { verbose => 0 },
494             completion => { domains => {}, contacts => {}, hosts => {}, files => {} },
495             };
496 0 0         if (exists $ctx->{term_features}->{ornaments}) { $term->ornaments(1); }
  0            
497 0     0     $ctx->{term_attribs}->{completion_function}=sub { return complete($ctx,@_); };
  0            
498 0           $ctx->{prompt}=$ctx->{dprompt};
499              
500 0           output($ctx,"Welcome to Net::DRI ${Net::DRI::VERSION} shell, pid $$\n");
501              
502 0           $ctx->{dri}=Net::DRI->new({cache_ttl => 10,logging=>['files',{level => 'info',sanitize_data => {session_password => 0}}]});
503 0           output($ctx,"Net::DRI object created with a cache TTL of 10 seconds and logging into files in current directory\n\n");
504              
505 0 0 0       if (exists $ctx->{term_features}->{readHistory} && defined $HISTORY)
506             {
507 0           $term->ReadHistory($HISTORY);
508             }
509              
510 0           $ctx->{file_quit}=0;
511 0 0 0       shift(@args) if (@args && $args[0] eq 'Net::DRI::Shell');
512 0 0         handle_line($ctx,'run '.$args[0]) if (@args);
513              
514 0 0         unless ($ctx->{file_quit})
515             {
516 0           delete($ctx->{file_quit});
517 0           while (defined(my $l=$ctx->{term}->readline($ctx->{prompt}.'> ')))
518             {
519 0 0         last if handle_line($ctx,$l);
520             }
521             }
522              
523 0 0 0       if (exists $ctx->{term_features}->{writeHistory} && defined $HISTORY)
524             {
525 0           $term->WriteHistory($HISTORY);
526             }
527              
528 0           $ctx->{dri}->end();
529 0           return 0; ## TODO : should reflect true result of last command ?
530             }
531              
532             sub output
533             {
534 0     0 0   my (@args)=@_;
535 0           my $ctx=shift;
536 0           print { $ctx->{output} } @args;
  0            
537 0           output_record($ctx,@args);
538 0           return;
539             }
540              
541             sub output_record
542             {
543 0     0 0   my ($ctx,@args)=@_;
544 0 0         return unless defined($ctx->{record_filehandle});
545 0 0 0       return if (@args==1 && ($args[0] eq '.' || $args[0] eq "\n"));
      0        
546 0           my $l=$ctx->{last_line};
547 0 0         print { $ctx->{record_filehandle} } scalar(localtime(time)),"\n\n",(defined($l)? ($l,"\n\n") : ('')),@args,"\n\n";
  0            
548 0           $ctx->{last_line}=undef;
549 0           return;
550             }
551              
552             sub handle_file
553             {
554 0     0 0   my ($ctx,$file)=@_;
555 0           output($ctx,'Executing commands from file '.$file." :\n");
556 0           $ctx->{completion}->{files}->{$file}=time();
557 0 0         open(my $ch,'<',$file) or die "Unable to open $file : $!"; ## no critic (InputOutput::RequireBriefOpen)
558 0           while(defined(my $l=<$ch>))
559             {
560 0           chomp($l);
561 0 0 0       next if ($l=~m/^\s*$/ || $l=~m/^#/);
562 0           my $pl=$l;
563 0           $pl=~s/(client_id|client_login|client_password)=\S+/$1=********/g;
564 0           output($ctx,$pl."\n");
565 0 0         if (handle_line($ctx,$l))
566             {
567 0           $ctx->{file_quit}=1;
568 0           last;
569             }
570             }
571 0 0         close($ch) or die $!;
572 0           return;
573             }
574              
575             sub handle_line
576             {
577 0     0 0   my ($ctx,$l)=@_;
578 0 0         return 0 if ($l=~m/^\s*$/);
579              
580 0           $l=~s/^\s*//;
581 0           $l=~s/\s*$//;
582              
583 0 0 0       return 1 if ($l eq 'quit' || $l eq 'q' || $l eq 'exit');
      0        
584              
585 0           my ($rc,$msg);
586              
587             my $ok=eval
588 0           {
589 0           ($rc,$msg)=process($ctx,$l);
590 0 0 0       $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));
      0        
591 0           1;
592             };
593 0           $ctx->{last_line}=$l;
594 0 0         if (! $ok)
595             {
596 0           my $err=$@;
597 0 0         $err='XML error: '.$err->as_string() if ref $err eq 'XML::LibXML::Error';
598 0 0         output($ctx,"An error happened:\n",ref $err ? $err->msg() : $err,"\n");
599             } else
600             {
601 0           my @r;
602 0 0         if (defined($rc))
603             {
604 0           push @r,scalar $rc->as_string(1),"\n";
605             }
606 0 0         push @r,$msg if (defined($msg));
607 0 0 0       if (defined($rc) && $rc->is_closing() && $ctx->{dri}->transport()->has_state())
      0        
608             {
609 0           $ctx->{dri}->transport()->current_state(0);
610 0           push @r,'Server connection closed, will try to reconnect during next command.'; ## TODO : this is triggered also for type=das, but shouldn't !
611             }
612 0           output($ctx,@r,"\n");
613             }
614              
615 0           $ctx->{term}->addhistory($l);
616 0           $ctx->{last_line}=undef;
617 0           return 0;
618             }
619              
620             sub complete
621             {
622 0     0 0   my ($ctx,$text,$line,$start)=@_; ## $text is last space separated word, $line the whole line, $start the position of the cursor in the line
623              
624             ## Command completion
625 0 0         if ($start==0) ## command completion
626             {
627 0           my @r=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/;
  0            
  0            
628 0           return @r;
629             }
630              
631             ## Parameter completion
632 0           my ($cmd)=($line=~m/^(\S+)\s/);
633 0 0         if ($cmd eq 'show') { my @r=sort { $a cmp $b } grep { /^$text/ } qw/profiles tlds periods objects types status config/; return @r; }
  0            
  0            
  0            
  0            
634 0 0         if ($cmd eq 'set') { return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } keys(%{$ctx->{config}}); }
  0            
  0            
  0            
  0            
  0            
635 0 0 0       if ($cmd eq 'run' || $cmd eq 'record') { my @r=sort { $ctx->{completion}->{files}->{$b} <=> $ctx->{completion}->{files}->{$a} || $a cmp $b } grep { /^$text/ } keys(%{$ctx->{completion}->{files}}); return @r; }
  0 0          
  0            
  0            
  0            
  0            
636              
637 0 0 0       if ($cmd eq 'add' || $cmd eq 'add_registry' || $cmd eq 'add_current_profile' || $cmd eq 'add_profile')
      0        
      0        
638             {
639 0 0         if (substr($line,$start-9,9) eq 'registry=')
    0          
640             {
641 0           my ($reg)=($text=~m/registry=(\S*)/);
642 0   0       $reg||='';
643 0           my @r=sort { $a cmp $b } grep { /^$reg/ } $ctx->{dri}->installed_registries();
  0            
  0            
644 0           return @r;
645             } elsif (substr($line,$start-5,5) eq 'type=')
646             {
647 0           my ($type)=($text=~m/type=(\S*)/);
648 0   0       $type||='';
649 0 0         my @r=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/);
  0            
  0            
650 0           return @r;
651             } else
652             {
653 0           my @p;
654 0 0         @p=qw/registry client_id/ if $cmd eq 'add_registry';
655 0 0         @p=qw/type name/ if ($cmd=~m/^add_(?:current_)?profile$/);
656 0 0         @p=qw/registry client_id type name/ if $cmd eq 'add';
657 0           return map { $_.'=' } grep { /^$text/ } @p;
  0            
  0            
658             }
659             }
660              
661 0 0         if ($cmd eq 'target')
662             {
663 0           my $regs=$ctx->{dri}->available_registries_profiles(0);
664 0 0         if (my ($reg)=($line=~m/^target\s+(\S+)\s+\S*$/))
    0          
665             {
666 0 0         my @r=sort { $a cmp $b } grep { /^$text/ } (exists $regs->{$reg} ? @{$regs->{$reg}} : ());
  0            
  0            
  0            
667 0           return @r;
668             } elsif ($line=~m/^target\s+\S*$/)
669             {
670 0           my @r=sort { $a cmp $b } grep { /^$text/ } keys(%$regs);
  0            
  0            
671 0           return @r;
672             }
673             }
674              
675 0 0         if (substr($line,$start-9,9) eq 'duration=')
676             {
677 0 0         return () unless defined $ctx->{dri}->registry_name();
678 0           my ($p)=($text=~m/duration=(\S*)/);
679 0   0       $p||='';
680 0           my %p;
681 0           foreach my $pd ($ctx->{dri}->registry()->driver()->periods())
682             {
683 0           my $d=$pd->in_units('years');
684 0 0         if ($d > 0) { $p{$d.'Y'}=12*$d; next; }
  0            
  0            
685 0           $d=$pd->in_units('months');
686 0 0         if ($d > 0) { $p{$d.'M'}=$d; next; }
  0            
  0            
687             }
688 0           my @r=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
  0            
  0            
689 0           return @r;
690             }
691              
692 0 0         if ($line=~m/^domain_\S+\s+\S*$/)
693             {
694 0           my @p=sort { $a cmp $b } grep { /^$text/ } keys(%{$ctx->{completion}->{domains}});
  0            
  0            
  0            
695 0 0         if (defined $ctx->{dri}->registry())
696             {
697 0           my @tlds=$ctx->{dri}->registry()->driver()->tlds();
698 0           my $tlds=join('|',map { quotemeta($_) } @tlds);
  0            
699 0           @p=grep { /\.(?:$tlds)$/i } @p;
  0            
700 0           my $idx=index($text,'.');
701 0 0         if ( $idx >= 0 )
702             {
703 0           my $base=substr($text,0,$idx);
704 0           push @p,map { $base.'.'.$_ } @tlds;
  0            
705             }
706             }
707 0 0 0       my @r=sort { ( $ctx->{completion}->{domains}->{$b} || 0) <=> ( $ctx->{completion}->{domains}->{$a} || 0 ) || $a cmp $b } @p;
  0   0        
708 0           return @r;
709             }
710              
711 0           my @ct=qw/registrant admin tech billing/; ## How to retrieve non core contact types ?
712 0           my $capa;
713 0 0 0       if ($ctx->{dri}->registry_name() && $ctx->{dri}->available_profile() && $ctx->{dri}->protocol())
      0        
714             {
715 0 0         @ct=('registrant',$ctx->{dri}->protocol()->core_contact_types()) if $ctx->{dri}->protocol()->can('core_contact_types');
716 0           $capa=$ctx->{dri}->protocol()->capabilities();
717             }
718 0           my $ctre=join('|',@ct);
719              
720 0 0         if ($cmd eq 'domain_create') ## If we are here, we are sure the domain name has been completed already, due to previous test block
721             {
722 0 0         if (substr($line,$start-3,3) eq 'ns=')
    0          
723             {
724 0           my ($ns)=($text=~m/ns=(\S*)/);
725 0   0       $ns||='';
726 0           return _complete_hosts($ctx,$ns);
727 0           } elsif (grep { substr($line,$start-(1+length($_)),1+length($_)) eq $_.'=' } @ct)
728             {
729 0           my ($c)=($text=~m/(?:${ctre})=(\S*)/);
730 0   0       $c||='';
731 0           return _complete_contacts($ctx,$c);
732             } else
733             {
734 0           return map { $_.'=' } grep { /^$text/ } (qw/duration ns auth/,@ct);
  0            
  0            
735             }
736             }
737              
738 0 0         if ($cmd eq 'domain_update') ## see previous comment
739             {
740 0 0         if (substr($line,$start-4,4)=~m/^[-+]ns=$/)
    0          
    0          
741             {
742 0           my ($ns)=($text=~m/ns=(\S*)/);
743 0   0       $ns||='';
744 0           return _complete_hosts($ctx,$ns);
745 0           } elsif (grep { substr($line,$start-(1+length($_)),1+length($_)) eq $_.'=' } @ct) #####
746             {
747 0           my ($c)=($text=~m/(?:${ctre})=(\S*)/);
748 0   0       $c||='';
749 0           return _complete_contacts($ctx,$c);
750             } elsif (substr($line,$start-8,8)=~m/^[-+]status=$/)
751             {
752 0           my $o=$ctx->{dri}->local_object('status');
753 0 0         if (! defined $o) { return (); }
  0            
754 0           my ($s)=($text=~m/status=(\S*)/);
755 0   0       $s||='';
756 0           my @r=sort { $a cmp $b } grep { /^$s/ } map { 'no'.$_ } $o->possible_no();
  0            
  0            
  0            
757 0           return @r;
758             } else
759             {
760 0           $text=~s/\+/[+]/g;
761 0 0         return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } (map { if (/^([+-])contact$/) { map { $1.$_ } @ct } else { $_; } } _complete_capa2list($capa,'domain_update'));
  0            
  0            
  0            
  0            
  0            
  0            
  0            
762             }
763             }
764              
765 0 0         if ($line=~m/^domain_update_ns_\S+\s+\S+\s+\S*/) { return _complete_hosts($ctx,$text); }
  0            
766              
767 0 0         if ($line=~m/^(?:domain|host|contact)_update_status_\S+\s+\S+\s+\S*/)
768             {
769 0           my $o=$ctx->{dri}->local_object('status');
770 0 0         if (! defined $o) { return (); }
  0            
771 0           my @r=sort { $a cmp $b } grep { /^$text/ } map { 'no'.$_ } $o->possible_no();
  0            
  0            
  0            
772 0           return @r;
773             }
774              
775 0 0         if ($line=~m/^domain_update_contact_\S+\s+\S+\s+\S*/) { return _complete_contacts($ctx,$text); }
  0            
776              
777 0 0         if (my ($trans)=($line=~m/^domain_transfer_(\S+)\s+\S+\s+\S*/))
778             {
779 0           my @p=qw/auth/;
780 0 0         push @p,'duration' if $trans eq 'start';
781 0           return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } @p;
  0            
  0            
  0            
782             }
783              
784 0 0         if ($cmd eq 'contact_create')
785             {
786 0 0 0       return () unless (defined $ctx->{dri}->registry_name() && defined $ctx->{dri}->profile());
787 0           my $c=$ctx->{dri}->local_object('contact');
788 0 0         if (! defined $c) { return (); }
  0            
789 0           return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } $c->attributes();
  0            
  0            
  0            
790             }
791              
792 0 0         if ($line=~m/^contact_\S+\s+\S*$/) { return _complete_contacts($ctx,$text); }
  0            
793              
794 0 0         if ($cmd eq 'contact_update')
795             {
796 0 0 0       return () unless (defined $ctx->{dri}->registry_name() && defined $ctx->{dri}->profile());
797 0           my $c=$ctx->{dri}->local_object('contact');
798 0           $text=~s/\+/[+]/g;
799 0 0         return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } (defined $c ? $c->attributes() : (),_complete_capa2list($capa,'contact_update'));
  0            
  0            
  0            
800             }
801              
802 0 0         if ($line=~m/^host_\S+\s+\S*$/) { return _complete_hosts($ctx,$text); }
  0            
803 0 0         if (my ($h)=($line=~m/^host_update_name_set\s+\S+\s+(\S*)$/)) { return _complete_hosts($ctx,$h); }
  0            
804 0 0         if ($cmd eq 'host_update')
805             {
806 0 0         if (substr($line,$start-5,5) eq 'name=')
    0          
807             {
808 0           my ($ns)=($text=~m/name=(\S*)/);
809 0   0       $ns||='';
810 0           return _complete_hosts($ctx,$ns);
811             } elsif ( substr($line,$start-8,8)=~m/^[-+]status=$/ )
812             {
813 0           my $o=$ctx->{dri}->local_object('status');
814 0 0         if (! defined $o) { return (); }
  0            
815 0           my ($s)=($text=~m/status=(\S*)/);
816 0   0       $s||='';
817 0           my @r=sort { $a cmp $b } grep { /^$s/ } map { 'no'.$_ } $o->possible_no();
  0            
  0            
  0            
818 0           return @r;
819             } else
820             {
821 0           $text=~s/\+/[+]/g;
822 0           return map { $_.'=' } sort { $a cmp $b } grep { /^$text/ } (_complete_capa2list($capa,'host_update'));
  0            
  0            
  0            
823             }
824             }
825              
826 0           return ();
827             }
828              
829             sub _complete_capa2list
830             {
831 0     0     my ($capa,$what)=@_;
832 0 0 0       return () unless (defined $capa && exists($capa->{$what}));
833 0           my @r;
834 0           while(my ($k,$ra)=each(%{$capa->{$what}}))
  0            
835             {
836 0           foreach my $t (@$ra)
837             {
838 0 0         if ($t eq 'add') { push @r,'+'.$k; } elsif ($t eq 'del') { push @r,'-'.$k; } elsif ($t eq 'set') { push @r,$k; }
  0 0          
  0 0          
  0            
839             }
840             }
841 0           return @r;
842             }
843              
844 0 0   0     sub _complete_hosts { my ($ctx,$text)=@_; my @r=sort { $ctx->{completion}->{hosts}->{$b} <=> $ctx->{completion}->{hosts}->{$a} || $a cmp $b } grep { /^$text/ } keys(%{$ctx->{completion}->{hosts}}); return @r; }
  0            
  0            
  0            
  0            
  0            
845             sub _complete_contacts
846             {
847 0     0     my ($ctx,$text)=@_;
848 0           my @c=grep { /^$text/ } keys(%{$ctx->{completion}->{contacts}});
  0            
  0            
849 0           my $creg=$ctx->{dri}->registry_name();
850 0 0         if (defined $creg) { @c=grep { defined $ctx->{completion}->{contacts}->{$_}->[1] && $ctx->{completion}->{contacts}->{$_}->[1] eq $creg } @c; } ## Filtering per registry
  0 0          
  0            
851 0 0         my @r=sort { $ctx->{completion}->{contacts}->{$b}->[0] <=> $ctx->{completion}->{contacts}->{$a}->[0] || $a cmp $b } @c;
  0            
852 0           return @r;
853             }
854              
855             sub process
856             {
857 0     0 0   my ($ctx,$wl)=@_;
858 0           my ($rc,$m);
859              
860 0           my ($cmd,$params)=split(/\s+/,$wl,2);
861 0 0         $params='' unless defined($params);
862 0           my @p=split(/\s+/,$params);
863 0           my %p;
864 0           my @g=($params=~m/\s*([^= ]+)=(\S.*?)(?:\s(?=\s*\S+=)|\s*$)/g);
865 0           while (@g)
866             {
867 0           my $n=shift(@g);
868 0           my $v=shift(@g);
869 0 0         if (exists($p{$n}))
870             {
871 0 0         $p{$n}=[$p{$n}] unless (ref($p{$n}) eq 'ARRAY');
872 0           push @{$p{$n}},$v;
  0            
873             } else
874             {
875 0           $p{$n}=$v;
876             }
877             }
878              
879 0           foreach my $k (sort { $a cmp $b } grep { /\./ } keys %p)
  0            
  0            
880             {
881 0           my ($tk,$sk)=split(/\./,$k,2);
882 0 0         $p{$tk}={} unless exists($p{$tk});
883 0           $p{$tk}->{$sk}=$p{$k};
884 0           delete($p{$k});
885             }
886              
887 0 0         return do_local($ctx,$cmd,\@p,\%p) if ($cmd=~m/^!/);
888 0 0         return help($ctx,$cmd,\@p,\%p) if ($cmd eq 'help');
889 0 0         return handle_file($ctx,$p[0]) if ($cmd eq 'run');
890 0 0         return record($ctx,$p[0]) if ($cmd eq 'record');
891 0 0 0       return do_dri($ctx,$cmd,\@p,\%p) if ($cmd=~m/^message_(?:retrieve|delete)$/ || $cmd eq 'ping');
892 0 0         return do_domain($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_(?:check)$/);
893 0 0         return do_domain_transfer($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_transfer_(?:start|stop|query|accept|refuse)$/);
894 0 0         return do_domain_update($ctx,$cmd,\@p,\%p) if ($cmd eq 'domain_update');
895 0 0         return do_domain_update_ns($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_update_ns_(?:add|del|set)$/);
896 0 0         return do_domain_update_status($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_update_status_(?:add|del|set)$/);
897 0 0         return do_domain_update_contact($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_update_contact_(?:add|del|set)$/);
898              
899 0 0         if ($cmd eq 'domain_info')
900             {
901 0           my @r=do_domain($ctx,$cmd,\@p,\%p);
902 0 0 0       if (defined $r[0] && $r[0]->is_success())
903             {
904 0           my $ns=$ctx->{dri}->get_info('ns');
905 0 0         if (defined $ns) { foreach my $name ($ns->get_names()) { $ctx->{completion}->{hosts}->{$name}=time(); } }
  0            
  0            
906 0           $ns=$ctx->{dri}->get_info('host');
907 0 0         if (defined $ns) { foreach my $name ($ns->get_names()) { $ctx->{completion}->{hosts}->{$name}=time(); } }
  0            
  0            
908 0           my $cs=$ctx->{dri}->get_info('contact');
909 0 0         if (defined $cs)
910             {
911 0           foreach my $t ($cs->types())
912             {
913 0           foreach my $cc ($cs->get($t)) { $ctx->{completion}->{contacts}->{$cc->srid()}=[time(),$ctx->{dri}->registry_name()]; }
  0            
914             }
915             }
916             }
917 0           return @r;
918             }
919              
920 0 0         if ($cmd=~m/^host_(?:create|delete|info|check|update|update_(?:ip|status|name)_(?:add|del|set))$/)
921             {
922 0 0         return (undef,'Registry does not support host objects') unless $ctx->{dri}->has_object('ns');
923 0           return do_host($ctx,$cmd,\@p,\%p);
924             }
925              
926 0 0         if ($cmd=~m/^contact_(?:create|delete|info|check|update|update_status_(?:add|del|set)|transfer_(?:start|stop|query|accept|refuse))$/)
927             {
928 0 0         return (undef,'Registry does not support contact objects') unless $ctx->{dri}->has_object('contact');
929 0           my @r=do_contact($ctx,$cmd,\@p,\%p);
930 0 0 0       if ($cmd eq 'contact_create' && defined $r[0] && $r[0]->is_success())
      0        
931             {
932 0           my $id=$ctx->{dri}->get_info('id');
933 0 0         if (defined $id) { $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()]; }
  0            
934             }
935 0           return @r;
936             }
937              
938             {
939 1     1   4 no strict 'refs'; ## no critic (ProhibitNoStrict)
  1         2  
  1         4475  
  0            
940 0           my $sub='do_'.$cmd;
941 0 0         return $sub->($ctx,$cmd,\@p,\%p) if (exists(&$sub));
942             }
943              
944             ## Fallback for all domain extension commands
945 0 0         return do_domain_extension($ctx,$cmd,\@p,\%p) if ($cmd=~m/^domain_\S+/);
946              
947 0           return (undef,'Unknown command '.$cmd);
948             }
949              
950             sub do_local
951             {
952 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
953 0           $cmd=~s/^!//;
954 0           my $s=$cmd.' '.join(' ',@$ra);
955 0           my $out=qx($s);
956 0 0         return (undef,defined($out)? $out : 'Local command failed: '.$!);
957             }
958              
959             sub help
960             {
961 0     0 1   my ($ctx,$cmd,$ra,$rh)=@_;
962 0           my $m=<
963             Available commands (parameters after the first one can be in any order):
964              
965             help
966             add registry=REGISTRYNAME type=TYPE [client_id=YOURLOGIN]
967             add_registry registry=REGISTRYNAME [client_id=YOURLOGIN]
968             add_current_profile name=PROFILENAME type=TYPE client_login=YOURLOGIN client_password=YOURPASSWORD
969             get_info_all
970             show profiles
971             show tlds
972             show periods
973             show objects
974             show status
975             show config
976             set P=X
977             target X Y
978             run FILENAME
979             record FILENAME
980             quit
981             domain_create DOMAIN [duration=X] [ns=HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...] [admin=SRID1] [registrant=SRID2] [billing=SRID3] [tech=SRID4] [auth=X]
982             domain_info DOMAIN
983             domain_check DOMAIN
984             domain_exist DOMAIN
985             domain_transfer_start DOMAIN auth=AUTHCODE [duration=PERIOD]
986             domain_transfer_stop DOMAIN [auth=AUTHCODE]
987             domain_transfer_query DOMAIN [auth=AUTHCODE]
988             domain_transfer_accept DOMAIN [auth=AUTHCODE]
989             domain_transfer_refuse DOMAIN [auth=AUTHCODE]
990             domain_update_ns_set DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
991             domain_update_ns_add DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
992             domain_update_ns_del DOMAIN HOSTNAMEA IPA1 IPA2 ... HOSTNAMEB IPB1 IPB2 ...
993             domain_update_status_set DOMAIN STATUS1 STATUS2 ...
994             domain_update_status_add DOMAIN STATUS1 STATUS2 ...
995             domain_update_status_del DOMAIN STATUS1 STATUS2 ...
996             domain_update_contact_set DOMAIN SRVID1 SRVID2 ...
997             domain_update_contact_add DOMAIN SRVID2 SRVID2 ...
998             domain_update_contact_del DOMAIN SRVID1 SRVID2 ...
999             domain_update DOMAIN +status=S1 -status=S2 +admin=C1 -tech=C2 -billing=C3 registrant=C4 auth=A +ns=... -ns=...
1000             domain_renew DOMAIN [duration=X] [current_expiration=YYYY-MM-DD]
1001             domain_delete DOMAIN
1002             host_create HOSTNAME IP1 IP2 ...
1003             host_delete HOSTNAME
1004             host_info HOSTNAME
1005             host_check HOSTNAME
1006             host_update_ip_set HOSTNAME IP1 IP2 ...
1007             host_update_ip_add HOSTNAME IP1 IP2 ...
1008             host_update_ip_del HOSTNAME IP1 IP2 ...
1009             host_update_status_set HOSTNAME STATUS1 STATUS2 ...
1010             host_update_status_add HOSTNAME STATUS1 STATUS2 ...
1011             host_update_status_del HOSTNAME STATUS1 STATUS2 ...
1012             host_update_name_set HOSTNAME NEWNAME
1013             host_update HOSTNAME +ip=IP1 +ip=IP2 -ip=IP3 +status=STATUS1 -status=STATUS2 name=NEWNAME ...
1014             contact_create name=X org=Y street=Z1 street=Z2 email=A voice=B ...
1015             contact_delete SRID
1016             contact_info SRID
1017             contact_check SRID
1018             contact_update_status_set SRID STATUS1 STATUS2 ...
1019             contact_update_status_add SRID STATUS1 STATUS2 ...
1020             contact_update_status_del SRID STATUS1 STATUS2 ...
1021             contact_update SRID name=X org=Y ... +status=... -status=...
1022             contact_transfer_start SRID
1023             contact_transfer_stop SRID
1024             contact_transfer_query SRID
1025             contact_transfer_accept SRID
1026             contact_transfer_refuse SRID
1027             message_retrieve [ID]
1028             message_delete [ID]
1029             message_waiting
1030             message_count
1031             ping
1032             EOF
1033 0           return (undef,$m);
1034             }
1035              
1036             sub record
1037             {
1038 0     0 1   my ($ctx,$n)=@_;
1039 0           my $m='';
1040              
1041             ## Need to stop the current one in all cases ! (true record stop or a new record start)
1042 0 0         if (defined($ctx->{record_filehandle}))
1043             {
1044 0           close($ctx->{record_filehandle});
1045 0           $ctx->{record_filehandle}=undef;
1046 0           $m='Stopped recording session to '.$ctx->{record_filename}."\n";
1047             }
1048              
1049 0 0 0       if (defined($n) && $n)
1050             {
1051 0           $ctx->{completion}->{files}->{$n}=time();
1052 0 0         open(my $fh,'>',$n) or return (undef,$m.'Unable to write local file '.$n.' : '.$!); ## no critic (InputOutput::RequireBriefOpen)
1053 0           $fh->autoflush(1); ## this is thanks to IO::Handle
1054 0           $ctx->{record_filehandle}=$fh;
1055 0           $ctx->{record_filename}=$n;
1056 0           $m.='Started recording session to '.$ctx->{record_filename};
1057             }
1058 0 0         return (undef,$m? $m : 'Usage: record FILENAME (to start recording session to local FILENAME) or record (to stop current recording)');
1059             }
1060              
1061             ## For local options, like verbose
1062             sub do_set
1063             {
1064 0     0 0   my($ctx,$cmd,$ra,$rh)=@_;
1065 0           $ctx->{config}={ %{$ctx->{config}},%$rh };
  0            
1066 0           return;
1067             }
1068              
1069             sub do_add
1070             {
1071 0     0 0   my($ctx,$cmd,$ra,$rh)=@_;
1072 0 0 0       return (undef,'Usage: add registry=REGISTRYNAME type=PROTOCOLTYPE [client_id=ID] [name=PROFILENAME] [...]') unless (Net::DRI::Util::has_key($rh,'registry') && Net::DRI::Util::has_key($rh,'type'));
1073 0           my %r=(registry => $rh->{registry}, client_id => $rh->{client_id});
1074 0           my @r=do_add_registry($ctx,'add_registry',$ra,\%r);
1075 0 0 0       if (! defined $r[0] || ! $r[0]->is_success()) { return @r; }
  0            
1076 0 0 0       unless (exists($rh->{name}) && defined($rh->{name}))
1077             {
1078 0           my @p=$ctx->{dri}->available_profiles();
1079 0           $rh->{name}=lc($rh->{registry}).(1+@p);
1080             }
1081 0           delete($rh->{registry});
1082 0           delete($rh->{client_id});
1083 0           return do_add_current_profile($ctx,'add_current_profile',$ra,$rh);
1084             }
1085              
1086             sub do_add_registry
1087             {
1088 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1089 0 0         return (undef,'Usage: add_registry registry=REGISTRYNAME [client_id=ID]') unless Net::DRI::Util::has_key($rh,'registry');
1090 0           my $reg=$rh->{registry};
1091 0           delete($rh->{registry});
1092 0 0         if (! grep { $reg eq $_ } $ctx->{dri}->available_registries() ) { $ctx->{dri}->add_registry($reg,$rh); }
  0            
  0            
1093 0           $ctx->{dri}->target($reg);
1094 0           $ctx->{prompt}=$ctx->{dprompt}.'('.$reg.')';
1095 0           return (Net::DRI::Protocol::ResultStatus->new_success('Registry "'.$reg.'" added successfully'),undef);
1096             }
1097              
1098             sub do_target
1099             {
1100 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1101 0           $ctx->{dri}->target(@$ra);
1102 0           $ctx->{prompt}=$ctx->{dprompt}.'('.join(',',@$ra).')';
1103 0           return;
1104             }
1105              
1106             sub do_add_current_profile
1107             {
1108 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1109 0 0 0       return (undef,'Usage: '.$cmd.' name=PROFILENAME type=SERVICENAME [client_login=YOURLOGIN] [client_password=YOURPASSWORD]') unless (Net::DRI::Util::has_key($rh,'name') && Net::DRI::Util::has_key($rh,'type'));
1110 0           my $name=$rh->{name};
1111 0           my $type=$rh->{type};
1112 0 0         my $rp=defined $rh->{protocol}? $rh->{protocol} : {};
1113 0           delete(@{$rh}{qw/name type protocol/});
  0            
1114 0           my $rc=$ctx->{dri}->$cmd($name,$type,$rh,$rp);
1115 0 0 0       if ($rc->is_success() && $cmd eq 'add_current_profile')
1116             {
1117 0           my @t=$ctx->{dri}->registry();
1118 0           $ctx->{prompt}=$ctx->{dprompt}.'('.$t[0].','.$t[1]->profile().')';
1119             }
1120 0           return ($rc,undef);
1121             }
1122              
1123 0     0 0   sub do_add_profile { return do_add_current_profile(@_); } ## no critic (Subroutines::RequireArgUnpacking)
1124              
1125             sub do_show
1126             {
1127 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1128 0           my $m='Usage: show profiles|tlds|periods|objects|types|status|config';
1129 0 0         return (undef,$m) unless @$ra;
1130 0 0 0       if ($ra->[0] eq 'profiles')
    0          
    0          
    0          
    0          
    0          
    0          
1131             {
1132 0           my $rp=$ctx->{dri}->available_registries_profiles(1);
1133 0           $m='';
1134 0           foreach my $reg (sort { $a cmp $b } keys %$rp)
  0            
1135             {
1136 0           $m.=$reg.': '.join(' ',@{$rp->{$reg}})."\n";
  0            
1137             }
1138             } elsif ($ra->[0] eq 'tlds')
1139             {
1140 0           $m=join("\n",$ctx->{dri}->registry()->driver()->tlds());
1141             } elsif ($ra->[0] eq 'periods' || $ra->[0] eq 'durations')
1142             {
1143 0           $m=join("\n",map { pretty_string($_,0); } $ctx->{dri}->registry()->driver()->periods());
  0            
1144             } elsif ($ra->[0] eq 'objects')
1145             {
1146 0           $m=join("\n",$ctx->{dri}->registry()->driver()->object_types());
1147             } elsif ($ra->[0] eq 'types')
1148             {
1149 0           $m=join("\n",$ctx->{dri}->registry()->driver()->profile_types());
1150             } elsif ($ra->[0] eq 'status')
1151             {
1152 0           my $o=$ctx->{dri}->local_object('status');
1153 0 0         $m=defined($o)? join("\n",map { 'no'.$_ } $o->possible_no()) : 'No status objects';
  0            
1154             } elsif ($ra->[0] eq 'config')
1155             {
1156 0           $m='';
1157 0           foreach my $k (sort { $a cmp $b } keys %{$ctx->{config}})
  0            
  0            
1158             {
1159 0           $m.=$k.'='.$ctx->{config}->{$k}."\n";
1160             }
1161             }
1162 0           return (undef,$m);
1163             }
1164              
1165             sub do_get_info
1166             {
1167 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1168 0           my $m=$ctx->{dri}->get_info(@$ra);
1169 0           return (undef,pretty_string($m,0));
1170             }
1171              
1172             sub do_get_info_all
1173             {
1174 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1175 0           my $rp=$ctx->{dri}->get_info_all(@$ra);
1176 0           my $m='';
1177 0           foreach my $k (sort { $a cmp $b } keys %$rp)
  0            
1178             {
1179 0           $m.=$k.': '.pretty_string($rp->{$k},0)."\n";
1180             }
1181 0           return (undef,$m);
1182             }
1183              
1184             sub do_dri
1185             {
1186 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1187 0           return ($ctx->{dri}->$cmd(@$ra),undef);
1188             }
1189              
1190             sub do_message_waiting
1191             {
1192 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1193 0           my $e=$ctx->{dri}->$cmd(@$ra);
1194 0 0         return (undef,'Unable to find if messages are waiting at the registry') unless defined($e);
1195 0 0         return (undef,'Messages waiting at the registry? '.($e? 'YES' : 'NO'));
1196             }
1197              
1198             sub do_message_count
1199             {
1200 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1201 0           my $e=$ctx->{dri}->$cmd(@$ra);
1202 0 0         return (undef,'Unable to find the number of messages waiting at the registry') unless defined($e);
1203 0           return (undef,'Number of messages waiting at the registry: '.$e);
1204             }
1205              
1206             ## Try to handle all domain commands defined in extensions, with some heuristics
1207             sub do_domain_extension
1208             {
1209 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1210 0           my $dom=shift(@$ra);
1211 0           build_auth($rh);
1212 0           build_duration($ctx,$rh);
1213 0 0         $rh->{status}=build_status($ctx,ref $rh->{status}? $rh->{status} : [ $rh->{status} ] ) if exists($rh->{status});
    0          
1214 0 0         $rh->{contact}=build_contactset($ctx,$rh->{contact}) if (exists $rh->{contact});
1215 0           return wrap_command_domain($ctx,$cmd,$dom,$rh);
1216             }
1217              
1218             sub do_domain
1219             {
1220 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1221 0           my $dom=shift(@$ra);
1222 0           return wrap_command_domain($ctx,$cmd,$dom,$rh);
1223             }
1224              
1225             sub do_domain_exist
1226             {
1227 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1228 0           my $dom=lc($ra->[0]);
1229 0           $ctx->{completion}->{domains}->{$dom}=time();
1230 0           my $e=$ctx->{dri}->$cmd($dom);
1231 0 0         return (undef,'Unable to find if domain name '.$dom.' exists') unless defined($e);
1232 0 0         return (undef,'Does domain name '.$dom.' exists at registry? '.($e? 'YES' : 'NO'));
1233             }
1234              
1235             sub do_domain_transfer
1236             {
1237 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1238 0           build_auth($rh);
1239 0           build_duration($ctx,$rh);
1240 0 0         $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
1241 0           return wrap_command_domain($ctx,$cmd,$ra->[0],$rh);
1242             }
1243              
1244             sub do_domain_update
1245             {
1246 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1247 0           my $dom=shift(@$ra);
1248 0           my $toc=$ctx->{dri}->local_object('changes');
1249 0           my ($radd,$rdel,$rset)=build_update($ctx,$rh);
1250 0           foreach my $k (sort { $a cmp $b } keys %$radd) { $toc->add($k,$radd->{$k}); }
  0            
  0            
1251 0           foreach my $k (sort { $a cmp $b } keys %$rdel) { $toc->del($k,$rdel->{$k}); }
  0            
  0            
1252 0           foreach my $k (sort { $a cmp $b } keys %$rset) { $toc->set($k,$rset->{$k}); }
  0            
  0            
1253 0           return wrap_command_domain($ctx,$cmd,$dom,$toc);
1254             }
1255              
1256             sub do_domain_update_ns
1257             {
1258 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1259 0           my $dom=shift(@$ra);
1260 0           my $ns=build_hosts($ctx,$ra);
1261 0           return wrap_command_domain($ctx,$cmd,$dom,$ns);
1262             }
1263              
1264             sub do_domain_update_status
1265             {
1266 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1267 0           my $dom=shift(@$ra);
1268 0           my $s=build_status($ctx,$ra);
1269 0           return wrap_command_domain($ctx,$cmd,$dom,$s);
1270             }
1271              
1272             sub do_domain_update_contact
1273             {
1274 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1275 0           my $dom=shift(@$ra);
1276 0           my $cs=$ctx->{dri}->local_object('contactset');
1277 0           while(my ($type,$ids)=each(%$rh))
1278             {
1279 0 0         foreach my $id (ref($ids)? @$ids : ($ids))
1280             {
1281 0           $cs->add($ctx->{dri}->local_object('contact')->srid($id),$type);
1282 0           $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()];
1283             }
1284             }
1285 0           return wrap_command_domain($ctx,$cmd,$dom,$cs);
1286             }
1287              
1288             sub do_domain_create
1289             {
1290 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1291 0           my $dom=shift(@$ra);
1292 0           build_duration($ctx,$rh);
1293 0           build_auth($rh);
1294 0 0         $rh->{ns}=build_hosts($ctx,[split(/\s+/,ref $rh->{ns} ? join(' ',@{$rh->{ns}}) : $rh->{ns})]) if exists($rh->{ns});
  0 0          
1295 0           my @ct=qw/registrant admin tech billing/; ## How to retrieve non core contact types ?
1296 0 0 0       @ct=('registrant',$ctx->{dri}->protocol()->core_contact_types()) if ($ctx->{dri}->protocol() && $ctx->{dri}->protocol()->can('core_contact_types'));
1297 0           my %c;
1298 0           foreach my $t (@ct)
1299             {
1300 0 0         next unless exists $rh->{$t};
1301 0           $c{$t}=$rh->{$t};
1302 0           delete $rh->{$t} ;
1303             }
1304 0 0         $rh->{contact}=build_contactset($ctx,\%c) if (%c);
1305 0           $rh->{pure_create}=1;
1306 0           return wrap_command_domain($ctx,$cmd,$dom,$rh);
1307             }
1308              
1309             sub do_domain_renew
1310             {
1311 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1312 0           my $dom=shift(@$ra);
1313 0           build_duration($ctx,$rh);
1314 0 0         if (exists($rh->{current_expiration}))
1315             {
1316 0           my @t=split(/-/,$rh->{current_expiration});
1317 0           $rh->{current_expiration}=$ctx->{dri}->local_object('datetime','year' => $t[0], 'month' => $t[1], 'day' => $t[2]);
1318             }
1319 0           return wrap_command_domain($ctx,$cmd,$dom,$rh);
1320             }
1321              
1322             sub do_domain_delete
1323             {
1324 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1325 0           my $dom=shift(@$ra);
1326 0           $rh->{pure_delete}=1;
1327 0           return wrap_command_domain($ctx,$cmd,$dom,$rh);
1328             }
1329              
1330             sub do_host
1331             {
1332 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1333 0           my @p;
1334 0 0         if ($cmd eq 'host_create')
    0          
    0          
    0          
1335             {
1336 0           @p=build_hosts($ctx,$ra);
1337             } elsif ($cmd=~m/^host_update_ip_(?:add|del|set)$/)
1338             {
1339 0           my $h=shift(@$ra);
1340 0           @p=($h,build_hosts($ctx,[ $h, @$ra ]));
1341             } elsif ($cmd=~m/^host_update_status_(?:add|del|set)$/)
1342             {
1343 0           my $h=shift(@$ra);
1344 0           @p=($h,build_status($ctx,$ra));
1345             } elsif ($cmd eq 'host_update')
1346             {
1347 0           my $h=shift(@$ra);
1348 0           my $toc=$ctx->{dri}->local_object('changes');
1349 0           my ($radd,$rdel,$rset)=build_update($ctx,$rh);
1350 0 0         if (keys %$radd) { foreach my $k (sort { $a cmp $b } keys %$radd) { if ($k eq 'ip') { $radd->{$k}=build_hosts($ctx,[$h,ref $radd->{$k} ? @{$radd->{$k}} : ($radd->{$k})]); } $toc->add($k,$radd->{$k}); } }
  0 0          
  0 0          
  0            
  0            
  0            
  0            
1351 0 0         if (keys %$rdel) { foreach my $k (sort { $a cmp $b } keys %$rdel) { if ($k eq 'ip') { $rdel->{$k}=build_hosts($ctx,[$h,ref $rdel->{$k} ? @{$rdel->{$k}} : ($rdel->{$k})]); } $toc->del($k,$rdel->{$k}); } }
  0 0          
  0 0          
  0            
  0            
  0            
  0            
1352 0 0         if (keys %$rset) { foreach my $k (sort { $a cmp $b } keys %$rset) { $toc->set($k,$rset->{$k}); } }
  0            
  0            
  0            
1353 0 0         $ctx->{completion}->{hosts}->{$rset->{'name'}}=time() if exists $rset->{'name'};
1354 0           @p=($h,$toc);
1355             } else
1356             {
1357 0           @p=@$ra;
1358             }
1359 0           $ctx->{completion}->{hosts}->{$p[0]}=time();
1360 0 0         $ctx->{completion}->{hosts}->{$p[1]}=time() if $cmd eq 'host_update_name_set';
1361 0           return ($ctx->{dri}->$cmd(@p),undef);
1362             }
1363              
1364             sub do_contact
1365             {
1366 0     0 0   my ($ctx,$cmd,$ra,$rh)=@_;
1367 0           my @p;
1368 0           my $c=$ctx->{dri}->local_object('contact');
1369 0           build_auth($rh);
1370 0 0         if ($cmd eq 'contact_create')
    0          
    0          
1371             {
1372 0 0 0       $rh->{street}=[$rh->{street}] if (exists($rh->{street}) && !ref($rh->{street}));
1373 0 0 0       $rh->{srid}=$rh->{id} if (exists($rh->{id}) && ! exists($rh->{srid}));
1374 0 0 0       $rh->{srid}=$ra->[0] if (@$ra && $ra->[0]!~m/=/ && ! exists $rh->{srid});
      0        
1375 0           build_contact($ctx,$c,$rh);
1376             } elsif ($cmd=~m/^contact_update_status_(?:add|del|set)$/)
1377             {
1378 0           my $id=shift(@$ra);
1379 0           $c->srid($id);
1380 0           $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()];
1381 0           @p=(build_status($ctx,$ra));
1382             } elsif ($cmd eq 'contact_update')
1383             {
1384 0           my $id=shift(@$ra);
1385 0           $c->srid($id);
1386 0           $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()];
1387 0           my ($radd,$rdel,$rset)=build_update($ctx,$rh);
1388 0           my $toc=$ctx->{dri}->local_object('changes');
1389 0 0         if (keys %$rset)
1390             {
1391 0           my $c2=$ctx->{dri}->local_object('contact');
1392 0           build_contact($ctx,$c2,$rset);
1393 0           $toc->set('info',$c2);
1394             }
1395 0 0         if (keys %$radd) { foreach my $k (sort { $a cmp $b } keys %$radd) { $toc->add($k,$radd->{$k}); } }
  0            
  0            
  0            
1396 0 0         if (keys %$rdel) { foreach my $k (sort { $a cmp $b } keys %$rdel) { $toc->del($k,$rdel->{$k}); } }
  0            
  0            
  0            
1397 0           @p=($toc);
1398             } else
1399             {
1400 0           my $id=shift(@$ra);
1401 0           $c->srid($id);
1402 0           $ctx->{completion}->{contacts}->{$id}=[time(),$ctx->{dri}->registry_name()];
1403 0           @p=@$ra;
1404             }
1405 0           return ($ctx->{dri}->$cmd($c,@p),undef);
1406             }
1407              
1408             ####################################################################################################
1409              
1410             sub wrap_command_domain
1411             {
1412 0     0 0   my ($ctx,$cmd,$dom,@args)=@_;
1413 0 0 0       return (undef,'Undefined domain name') unless defined $dom && length $dom;
1414              
1415 0           my ($fin,$fout,$res);
1416 0 0         if ($dom=~m/`.+`/) ## Local executable
    0          
1417             {
1418 0           $dom=~s/`(.+)`/$1/;
1419 0           $res=$cmd.'.'.$$.'.'.time().'.results'; ## TODO choose a predictable filename ? if so, use an option
1420 0 0         open($fin,'-|',$dom) or return (undef,'Unable to execute local command '.$dom.' : '.$!); ## no critic (InputOutput::RequireBriefOpen)
1421 0 0         open($fout,'>',$res) or return (undef,'Unable to write (for results) local file '.$res.' : '.$!); ## no critic (InputOutput::RequireBriefOpen)
1422             } elsif ($dom=~m!/!) ## Local file
1423             {
1424 0 0 0       return (undef,'Local file '.$dom.' does not exist or unreadable') unless (-e $dom && -r _);
1425 0           $res=$dom.'.'.$$.'.'.time().'.results'; ## see above
1426 0 0         open($fin,'<',$dom) or return (undef,'Unable to read local file '.$dom.' : '.$!); ## no critic (InputOutput::RequireBriefOpen)
1427 0 0         open($fout,'>',$res) or return (undef,'Unable to write (for results) local file '.$res.' : '.$!); ## no critic (InputOutput::RequireBriefOpen)
1428             }
1429              
1430 0 0 0       unless (defined $fin && defined $fout) ## Pure unique domain name
1431             {
1432 0           $ctx->{completion}->{domains}->{$dom}=time();
1433 0 0         return (undef,'Invalid domain name: '.$dom) unless Net::DRI::Util::is_hostname($dom);
1434 0           return ($ctx->{dri}->$cmd(lc($dom),@args),undef);
1435             }
1436              
1437 0 0 0       my $withinfo=($cmd eq 'domain_check' || $cmd eq 'domain_info')? 1 : 0;
1438 0           my @rc;
1439 0           my $tstart=Time::HiRes::time();
1440 0           while(defined(my $l=<$fin>))
1441             {
1442 0           chomp($l);
1443 0           my @r=($l);
1444 0           $ctx->{completion}->{domains}->{$l}=time();
1445 0 0         if (Net::DRI::Util::is_hostname($l))
1446             {
1447 0           my $rc=$ctx->{dri}->$cmd(lc($l),@args);
1448 0           push @r,$rc->as_string(1);
1449 0 0         push @r,$ctx->{dri}->get_info_all() if $withinfo;
1450             } else
1451             {
1452 0           push @r,'Invalid domain name';
1453             }
1454 0           push @rc,\@r;
1455 0           output($ctx,'.');
1456             }
1457 0           my $tstop=Time::HiRes::time();
1458 0           output($ctx,"\n");
1459 0           close($fin);
1460              
1461 0           my %r;
1462             ## We write the whole file at the end for better performances (but we opened it right at the beginning to test its writability)
1463 0           foreach my $rc (@rc)
1464             {
1465 0           my $l=shift @$rc;
1466 0           my $rcm=shift @$rc;
1467 0           my ($rcms)=($rcm=~m/^([^\n]+)/);
1468 0           $rcm=~s/\n\t*/ /g;
1469 0 0         if ($cmd eq 'domain_check')
    0          
1470             {
1471 0           my $rh=shift @$rc;
1472 0 0         $rcm.=' | exist='.(defined $rh->{exist} ? $rh->{exist} : '?').' exist_reason='.(defined $rh->{exist_reason} ? $rh->{exist_reason} : ''); ## exist should always be defined !
    0          
1473             } elsif ($cmd eq 'domain_info')
1474             {
1475 0           my $rh=shift @$rc;
1476 0           $rcm.=' | '.join(' ',map { $_.'=['.pretty_string($rh->{$_},0).']' } qw/clID crDate exDate contact ns status auth/);
  0            
1477 0 0         if (exists $rh->{ns}) { foreach my $nsname ($rh->{ns}->get_names()) { $ctx->{completion}->{hosts}->{$nsname}=time(); } }
  0            
  0            
1478 0 0         if (exists $rh->{contact}) { foreach my $cid ($rh->{contact}->get_all()) { $ctx->{completion}->{contacts}->{$cid}=[time(),$ctx->{dri}->registry_name()]; } }
  0            
  0            
1479             }
1480 0           print { $fout } $l,' ',$rcm,"\n";
  0            
1481 0           $r{$rcms}++;
1482             }
1483 0           close($fout);
1484              
1485 0           my $t=@rc;
1486 0           my $m=join("\n",map { sprintf('%d/%d (%.02f%%) : %s',$r{$_},$t,100*$r{$_}/$t,$_) } sort { $a cmp $b } keys(%r));
  0            
  0            
1487 0           $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
1488 0           $m.="\nResults in local file: $res";
1489 0           return (undef,$m);
1490             }
1491              
1492             ####################################################################################################
1493              
1494             sub build_contactset
1495             {
1496 0     0 0   my ($ctx,$rh)=@_;
1497 0           my $cs=$ctx->{dri}->local_object('contactset');
1498 0           while(my ($t,$ids)=each(%$rh))
1499             {
1500 0 0         foreach my $c (ref($ids)? @{$ids} : ($ids))
  0            
1501             {
1502 0           $cs->add($ctx->{dri}->local_object('contact')->srid($c),$t);
1503 0           $ctx->{completion}->{contacts}->{$c}=[time(),$ctx->{dri}->registry_name()];
1504             }
1505             }
1506 0           return $cs;
1507             }
1508              
1509             sub build_contact
1510             {
1511 0     0 0   my ($ctx,$c,$rh)=@_;
1512 0           while(my ($m,$v)=each(%$rh))
1513             {
1514 0           $c->$m($v);
1515             }
1516 0 0         if (exists $rh->{srid}) { $ctx->{completion}->{contacts}->{$rh->{srid}}=[time(),$ctx->{dri}->registry_name()]; }
  0            
1517 0 0         if (exists $rh->{id}) { $ctx->{completion}->{contacts}->{$rh->{id}} =[time(),$ctx->{dri}->registry_name()]; }
  0            
1518              
1519 0           return $c;
1520             }
1521              
1522             sub build_status
1523             {
1524 0     0 0   my ($ctx,$ra)=@_;
1525 0           my $s=$ctx->{dri}->local_object('status');
1526 0           foreach (@$ra) { s/^no//; $s->no($_); }
  0            
  0            
1527 0           return $s;
1528             }
1529              
1530             sub build_hosts
1531             {
1532 0     0 0   my ($ctx,$ra)=@_;
1533 0           my $ns=$ctx->{dri}->local_object('hosts');
1534 0           my $i=-1;
1535 0           my @r;
1536 0           foreach my $o (@$ra)
1537             {
1538 0 0         $r[++$i]=[] if ($o=~m/[a-z]/i); ## new hostname (safe since at least the TLD is not numeric)
1539 0 0         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)
  0            
1540             }
1541 0           foreach my $rns (@r)
1542             {
1543 0           my $name=shift(@$rns);
1544 0           $ns->add($name,$rns);
1545 0           $ctx->{completion}->{hosts}->{$name}=time();
1546             }
1547 0           return $ns;
1548             }
1549              
1550             sub build_auth
1551             {
1552 0     0 0   my $rd=shift;
1553 0 0 0       return unless (exists($rd->{auth}) && ! ref($rd->{auth}));
1554 0           $rd->{auth}={ pw => $rd->{auth} };
1555 0           return;
1556             }
1557              
1558             sub build_duration
1559             {
1560 0     0 0   my ($ctx,$rd)=@_;
1561 0 0         return unless exists($rd->{duration});
1562 0           my ($v,$u)=($rd->{duration}=~m/^(\d+)(y(?:ears?)|m(?:onths?))$/i);
1563 0 0 0       die sprintf('Invalid duration specification "%s"',$rd->{duration}) unless defined $v && defined $u;
1564 0 0         $rd->{duration}=$ctx->{dri}->local_object('duration','years' => $v) if ($u=~m/^y(?:ears?)?$/i);
1565 0 0         $rd->{duration}=$ctx->{dri}->local_object('duration','months' => $v) if ($u=~m/^m(?:onths?)?$/i);
1566 0           return;
1567             }
1568              
1569             sub build_update
1570             {
1571 0     0 0   my ($ctx,$rd)=@_;
1572 0           my (%add,%rem);
1573              
1574             ## Some normalizations
1575 0 0         foreach my $k (sort { $a cmp $b } grep { /^[+-]?status$/ } keys(%$rd)) { $rd->{$k}=build_status($ctx,ref $rd->{$k} ? $rd->{$k} : [ $rd->{$k} ]); }
  0            
  0            
  0            
1576 0 0         foreach my $k (sort { $a cmp $b } grep { /^[+-]?ns$/ } keys(%$rd)) { $rd->{$k}=build_hosts($ctx,[ map { split(/\s+/,$_) } ref $rd->{$k} ? @{$rd->{$k}} : ($rd->{$k})]); }
  0            
  0            
  0            
  0            
  0            
1577 0           build_auth($rd);
1578              
1579 0           my @ct=qw/admin tech billing/; ## How to retrieve non core contact types ?
1580 0 0 0       @ct=$ctx->{dri}->protocol()->core_contact_types() if ($ctx->{dri}->protocol() && $ctx->{dri}->protocol()->can('core_contact_types'));
1581 0           my $ctr=join('|',@ct);
1582 0           foreach my $op (qw/+ -/)
1583             {
1584 0           my %c;
1585 0           foreach my $k (sort { $a cmp $b } grep { /^[${op}](?:${ctr})$/ } keys %$rd )
  0            
  0            
1586             {
1587 0           $c{substr($k,1)}=$rd->{$k};
1588 0           delete($rd->{$k});
1589             }
1590 0 0         next unless %c;
1591 0           $rd->{$op.'contact'}=build_contactset($ctx,\%c);
1592             }
1593 0 0         $rd->{registrant}=build_contact($ctx,$ctx->{dri}->local_object('contact'),{srid => $rd->{registrant}}) if exists $rd->{registrant};
1594              
1595             ## Now split in two hashes
1596 0           foreach my $k (sort { $a cmp $b } grep { /^\+/ } keys %$rd)
  0            
  0            
1597             {
1598 0           $add{substr($k,1)}=$rd->{$k};
1599 0           delete($rd->{$k});
1600             }
1601 0           foreach my $k (sort { $a cmp $b } grep { /^-/ } keys %$rd)
  0            
  0            
1602             {
1603 0           $rem{substr($k,1)}=$rd->{$k};
1604 0           delete($rd->{$k});
1605             }
1606              
1607 0           return (\%add,\%rem,$rd);
1608             }
1609              
1610             sub pretty_string
1611             {
1612 0     0 0   my ($v,$full)=@_;
1613 0   0       $full||=0;
1614 0 0         unless(ref($v))
1615             {
1616 0 0         return '' unless defined($v);
1617 0           $v=~s/\s*$//;
1618 0 0         return $v unless ($v=~m/^<\?xml /);
1619 0           my $vi=Net::DRI::Util::xml_indent($v);
1620 0           $vi=~s/\n/\n\t\t/g;
1621 0           return $vi;
1622             }
1623 0 0         return join(' ',@$v) if (ref($v) eq 'ARRAY');
1624 0 0         return join(' ',map { $_.'='.$v->{$_} } sort { $a cmp $b } keys(%$v)) if (ref($v) eq 'HASH');
  0            
  0            
1625 0 0         return ($full? "Ns:\n": '').$v->as_string(1) if ($v->isa('Net::DRI::Data::Hosts'));
    0          
1626 0 0         return ($full? "Contact:\n" : '').$v->as_string() if ($v->isa('Net::DRI::Data::Contact'));
    0          
1627 0 0         if ($v->isa('Net::DRI::Data::ContactSet'))
1628             {
1629 0           my @v;
1630 0           foreach my $t ($v->types())
1631             {
1632 0           push @v,$t.'='.join(',',map { pretty_string($_,$full) } $v->get($t));
  0            
1633             }
1634 0 0         return ($full? "ContactSet:\n" : '').join(' ',@v);
1635             }
1636 0 0         return ($full? "Status:\n" : '').join(' + ',$v->list_status(1)) if ($v->isa('Net::DRI::Data::StatusList'));
    0          
1637 0 0         return ($full? "Command result:\n" : '').$v->as_string(1) if ($v->isa('Net::DRI::Protocol::ResultStatus'));
    0          
1638 0 0         return ($full? "Date:\n" : '').$v->set_time_zone('UTC')->strftime('%Y-%m-%d %T').' UTC' if ($v->isa('DateTime'));
    0          
1639 0 0         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
    0          
1640 0           return $v;
1641             }
1642              
1643             sub dump_info
1644             {
1645 0     0 0   my ($ctx,$rh)=@_;
1646 0           my @r;
1647 0           foreach my $k1 (sort { $a cmp $b } keys %$rh)
  0            
1648             {
1649 0           foreach my $k2 (sort { $a cmp $b } keys %{$rh->{$k1}})
  0            
  0            
1650             {
1651 0 0 0       next if ($k1 eq 'session' && $k2 eq 'exchange' && $ctx->{config}->{verbose}==0);
      0        
1652 0           push @r,$k1.','.$k2;
1653 0           foreach my $k3 (sort { $a cmp $b } keys %{$rh->{$k1}->{$k2}})
  0            
  0            
1654             {
1655 0           push @r,"\t".$k3.': '.pretty_string($rh->{$k1}->{$k2}->{$k3},0);
1656             }
1657 0           push @r,'';
1658             }
1659             }
1660 0           return join("\n",@r);
1661             }
1662              
1663             ####################################################################################################
1664             1;