File Coverage

blib/lib/IO/EPP/RIPN.pm

Criterion	Covered	Total	%
statement	24	406	5.9
branch	0	230	0.0
condition	0	65	0.0
subroutine	8	26	30.7
pod	14	18	77.7
total	46	745	6.1

package IO::EPP::RIPN;

=encoding utf8

=head1 NAME

IO::EPP::RIPN

=head1 SYNOPSIS

    use IO::EPP::RIPN;

    # Parameters for LWP
    my %sock_params = (
        PeerHost        => 'uap.tcinet.ru',
        PeerPort        => 8028, # 8027 for .SU,  8028 for .RU,  8029 for .РФ
        SSL_key_file    => 'key_file.pem',
        SSL_cert_file   => 'cert_file.pem',
        LocalAddr       => '1.2.3.4',
        Timeout         => 30,
    );

    # Create object, get greeting and call login()
    my $conn = IO::EPP::RIPN->new( {
        user => 'XXX-RU',
        pass => 'XXXXXXXX',
        sock_params => \%sock_params,
        test_mode => 0, # real connect
    } );

    # Check domain
    my ( $answ, $code, $msg ) = $conn->check_domains( { domains => [ 'org.info' ] } );

    # Call logout() and destroy object
    undef $conn;

=head1 DESCRIPTION

RIPN is the first organization the registry in the .ru tld
Then it transferred functions of the registry into TCI (L)
but all special headings in epp remained

Examlpe:

C
instead of
C

Module overwrites IO::EPP::Base where there are differences from RFC
and work with tcinet epp using http api

For details see:
L,
L,
L,
L

All documents -- L

IO::EPP::RIPN only works with .RU, .SU & .РФ cctlds.

For work with the new gtlds .ДЕТИ, .TATAR need use IO::EPP::TCI

Features:

Working over https

Completely other contacts

Non-standard domain transfer in the .su zone

The domain:check function has an error: when checking the availability of a blocked domain, it responds that it is available.
The list of blocked domains should be downloaded from the Registrar panel.

=cut

use LWP::UserAgent;
use HTTP::Request;
use HTTP::Cookies;
use Time::HiRes qw( time );

use IO::EPP::Base;
use parent qw( IO::EPP::Base );

use strict;
use warnings;

# Old TCI uses special headings
our $epp_head = '
';
our $epp_cont_urn =
'xmlns:contact="http://www.ripn.net/epp/ripn-contact-1.0" xsi:schemaLocation="http://www.ripn.net/epp/ripn-contact-1.0 ripn-contact-1.0.xsd"';
our $epp_host_urn =
'xmlns:host="http://www.ripn.net/epp/ripn-host-1.0" xsi:schemaLocation="http://www.ripn.net/epp/ripn-host-1.0 ripn-host-1.0.xsd"';
our $epp_dom_urn  =
'xmlns:domain="http://www.ripn.net/epp/ripn-domain-1.0" xsi:schemaLocation="http://www.ripn.net/epp/ripn-domain-1.0 ripn-domain-1.0.xsd"';
our $epp_dom_urn_ru  =
'xmlns:domain="http://www.ripn.net/epp/ripn-domain-1.1" xsi:schemaLocation="http://www.ripn.net/epp/ripn-domain-1.1 ripn-domain-1.1.xsd"';
our $epp_reg_urn  =
'xmlns:registrar="http://www.ripn.net/epp/ripn-registrar-1.0" xsi:schemaLocation="http://www.ripn.net/epp/ripn-registrar-1.0 ripn-registrar-1.0.xsd"';


sub make_request {
    my ( $action, $params ) = @_;

    #$params = IO::EPP::Base::recursive_utf8_unflaged( $params );

    my ( $code, $msg, $answ, $self );

    unless ( $params->{conn} ) {
        # Default:
        $params->{sock_params}{PeerHost} ||= 'uap.tcinet.ru';
        $params->{sock_params}{PeerPort} ||= 8028; # .RU

        ( $self, $code, $msg ) = IO::EPP::RIPN->new( $params );

        unless ( $code  and  $code == 1000 ) {
            goto END_MR;
        }
    }
    else {
        $self = $params->{conn};
    }

    $self->{critical_error} = '';

    if ( $self->can( $action ) ) {
        ( $answ, $code, $msg ) = $self->$action( $params );
    }
    else {
        $msg = "undefined command <$action>, request cancelled";
        $code = 0;
    }

END_MR:

    $msg .= ', ' . $self->{critical_error} if $self->{critical_error};

    my $full_answ = "code: $code\nmsg: $msg";

    $answ = {} unless $answ && ref $answ;

    $answ->{code} = $code;
    $answ->{msg}  = $msg;

    return wantarray ? ( $answ, $full_answ, $self ) : $answ;
}


sub gen_pw {
    my @chars = ( 'A'..'Z', 'a'..'z', '0'..'9', '!', '@', '$', '%', '*', '_', '.', ':', '-', '=', '+', '?', '#', ',' );

    return join '', map( { $chars[ int rand( scalar @chars ) ] } 1..16 );
}


=head1 METHODS

=head2 new

If the C parameter is received, it loads cookies from the file specified by C

=cut

sub new {
    my ( $package, $params ) = @_;

    my ( $self, $code, $msg );

    my $sock_params   = delete $params->{sock_params};

    my $host          = $sock_params->{PeerHost};
    my $port          = $sock_params->{PeerPort};
    my $url           = "https://$host:$port";
    my $local_address = $sock_params->{LocalAddr};
    my $timeout       = $sock_params->{Timeout} || 5;

    my %ua_params = ( ssl_opts => $sock_params );
    $ua_params{local_address} = $local_address if $local_address;

    if ( $timeout ) {
        # LWP feature: first param for LWP, second - for IO::Socket
        $ua_params{timeout} = $timeout;
        $ua_params{Timeout} = $timeout;
    }

    my $cookie;
    if ( $params->{alien_conn} ) {
        $cookie = HTTP::Cookies->new( autosave => 0 );

        unless ( $cookie->load( $params->{load_cook_from} ) ) {
            $msg = "load cooker is fail";
            $code = 0;

            goto ERR;
        }
    }
    else {
        $cookie = HTTP::Cookies->new;
    }

    my $ua = LWP::UserAgent->new(
        agent      => 'EppBot/7.02 (Perl; Linux i686; ru, en_US)',
        parse_head =>  0,
        keep_alive => 30,
        cookie_jar => $cookie,
        %ua_params,
    );

    unless ( $ua ) {
        $msg = "can not connect";
        $code = 0;

        goto ERR;
    }

    $self = bless {
        sock     => $ua,
        user     => $params->{user},
        url      => $url,
        cookies  => $cookie,
        no_log   => delete $params->{no_log},
        alien    => $params->{alien_conn} ? 1 : 0,
    };

    $self->set_urn();

    $self->set_log_vars( $params );

    $self->epp_log( "Connect to $url\n" );

    if ( $self->{alien} ) {
        return wantarray ? ( $self, 1000, 'ok' ) : $self;
    }

    # Get HEADER only
    $self->epp_log( "HEAD connect to $url from $local_address" );

    my $request = HTTP::Request->new( HEAD => $url ); # не POST
    my $response = $ua->request( $request );

    my $rcode = $response->code;
    $self->epp_log( "header answ code: $rcode" );

    unless ( $rcode == 200 ) {
        $code = 0;
        $msg  = "Can't open socket";

        goto ERR;
    }

    my $headers = $response->headers;

    my $length = $headers->content_length;
    $self->epp_log( "header content-length == $length" );

    if ( $length == 0 ) {
        $code = 0;
        $msg  = "Can't open socket";

        goto ERR;
    }

    my ( undef, $c0, $m0 ) = $self->hello();

    unless ( $c0  &&  $c0 == 1000 ) {
        $code = 0;
        $msg = "Can't get greeting";
        $msg .= '; ' . $self->{critical_error} if $self->{critical_error};

        goto ERR;
    }


    my ( undef, $c1, $m1 ) = $self->login( delete $params->{pass} ); # no password in object

    if ( $c1  &&  $c1 == 1000 ) {
        return wantarray ? ( $self, $c1, $m1 ) : $self;
    }

    $msg = ( $m1 || '' ) . $self->{critical_error};
    $code = $c1 || 0;

ERR:
    return wantarray ? ( 0, $code, $msg ) : 0;
}


sub set_urn {
    $_[0]->{urn} = {
        head => $IO::EPP::RIPN::epp_head,
        cont => $IO::EPP::RIPN::epp_cont_urn,
        host => $IO::EPP::RIPN::epp_host_urn,
        dom  => $IO::EPP::RIPN::epp_dom_urn,
        reg  => $IO::EPP::RIPN::epp_reg_urn,
    };
}


sub req {
    my ( $self, $out_data, $info ) = @_;

    return 0 unless $out_data && $self->{sock};

    $info ||= '';

    if ( $out_data ) {
        my $d = $out_data;
        # remove password, authinfo from log
        $d =~ s/[^<>]+<\/pw>/xxxxx<\/pw>/;

        $self->epp_log( "$info request:\n$d" );
    }

    my $request = HTTP::Request->new( POST => $self->{url} );
    $request->content_type('text/xml');
    $request->content_type_charset('UTF-8');
    $request->content( $out_data );

    my $start_time = time;

    my $response = $self->{sock}->request( $request );

    my $req_time = sprintf( '%0.4f', time - $start_time );

    # print Dumper $response;

    my $rcode = $response->code;

    unless ( $rcode == 200 ) {
        $self->{critical_error} = "Get answer code = $rcode";

        return 0;
    }

    # feature of connection on epp over https
    if ( $info eq 'login' ) {
        $self->{cook} = $self->{sock}->cookie_jar->as_string;
        $self->epp_log( "cookies: $$self{cook}" );

        $self->{sessionid} = $response->header('set-cookie') || '';
        $self->epp_log( "sessionid: $$self{sessionid}" );
    }

    my $in_data = $response->content;

    $self->epp_log( "req_time: $req_time\n$info answer:\n$in_data\n" );

    return $in_data;
}


=head2 login

Ext params for login,

INPUT: new password for change

=cut

sub login {
    my ( $self, $pw, undef, undef, $new_pw ) = @_;

    return 0 unless $pw;

    my $npw = $new_pw ? "\n   $new_pw" : '';

    my ( $svcs, $ext ) = ( '', '' );

    if ( $self->{user} =~ /-(RU|RF)$/ ) {
        $svcs = "\n    http://www.ripn.net/epp/ripn-domain-1.1";
        # Does not work $ext  = "\n     http://www.tcinet.ru/epp/tci-billing-1.0";
    }

    my $cltrid = $self->get_cltrid();

    my $body = <
$$self{urn}{head}


   $$self{user}
   $pw$npw

    1.0
    en


    http://www.ripn.net/epp/ripn-contact-1.0
    http://www.ripn.net/epp/ripn-domain-1.0$svcs
    http://www.ripn.net/epp/ripn-epp-1.0
    http://www.ripn.net/epp/ripn-eppcom-1.0
    http://www.ripn.net/epp/ripn-host-1.0
    http://www.ripn.net/epp/ripn-registrar-1.0

     urn:ietf:params:xml:ns:secDNS-1.1$ext



  $cltrid


LOGIN

    return $self->simple_request( $body, 'login' );
}


=head2 save_cookies

Save http connection cookies,
they can be used to create another connection on this IP address without opening a new session, that is, without a login

=cut

sub save_cookies {
    my ( $self, $params ) = @_;

    unless ( ref $params  and  $params->{save_cook_to} ) {
        return wantarray ? ( 0, 0, 'no params' ) : 0;
    }

    my $cook = $self->{sock}->cookie_jar->as_string;

    open( COOKFILE, '>', $params->{save_cook_to} )  or  return ( 0, 0, "Can't open $$params{save_cook_to} file: $!" );
    print COOKFILE "#LWP-Cookies-1.0\n";
    print COOKFILE "$cook\n";
    close COOKFILE;

    my %info = ( cook => $cook );
    $self->{cook} = $cook;

    return wantarray ? ( \%info, 1000, 'ok' ) : \%info;
}


sub hello {
    my ( $self ) = @_;

    my $body = <
$$self{urn}{head}


HELLO

    my $content = $self->req( $body, 'hello' );

    return 0 unless $content && $content =~ /greeting/;

    my $info = { code => 1000, msg  => $content };

    return wantarray ? ( $info, 1000, $content ) : $info;
}

sub cont_to_xml {
    my ( undef, $cont ) = @_;

    my $is_person = $cont->{passport} ? 1 : 0;

    my $txtcont .= $is_person ? "\n" : "\n";

    foreach my $type ( 'int', 'loc' ) {
        $txtcont .= "    \n";

        if ( $is_person ) {
	   $txtcont .= "     ".$$cont{$type}{name}."\n";
        }
        else {
	   $txtcont .= "     ".$$cont{$type}{org}."\n";
        }

        $$cont{$type}{addr} = [ $$cont{$type}{addr} ] unless ref $$cont{$type}{addr};

        $txtcont .= "     $_\n" foreach @{$$cont{$type}{addr}};

        $txtcont .= "    \n";
    }

    unless ( $is_person ) {
	$txtcont .= "    \n";

	$$cont{legal}{addr} = [ $$cont{legal}{addr} ] unless ref $$cont{legal}{addr};

        $txtcont .= "     $_\n" foreach @{$$cont{legal}{addr}};

	$txtcont .= "    \n";
    }

    if ( $$cont{taxpayerNumbers} ) {
	$txtcont .= "    $$cont{taxpayerNumbers}\n";
    }
    else {
	$txtcont .= "    \n";
    }

    if ( $is_person ) {
	$txtcont .= "    $$cont{birthday}\n";

	$$cont{passport} = [ $$cont{passport} ] unless ref $$cont{passport};

        $txtcont .= "    $_\n" foreach @{$$cont{passport}};
    }

    $$cont{voice} = [ $$cont{voice} ] unless ref $$cont{voice};

    $txtcont .= "    $_\n" foreach @{$$cont{voice}};

    if ( $$cont{fax} ) {
        $$cont{fax} = [ $$cont{fax} ] unless ref $$cont{fax};

        $txtcont .= "    $_\n" foreach @{$$cont{fax}};
    }
    else {
        $txtcont .= "    \n";
    }

    $$cont{email} = [ $$cont{email} ] unless ref $$cont{email};

    $txtcont .= "    $_\n" foreach @{$$cont{email}};

    if ( $is_person ) {
        $txtcont .= "   \n";
    }
    else {
        $txtcont .= "   \n";
    }

    if ( $$cont{verified} ) {
        $txtcont .= "   ";
    }
    else {
	$txtcont .= "   ";
    }

    return $txtcont;
}


sub cont_from_xml {
    my ( undef, $txtcont ) = @_;

    my %cont;

    my $is_person = ($txtcont =~ /contact:person/) ? 1 : 0;

    my @ss = $txtcont =~ //g;
    $cont{statuses}{$_} = '+' for @ss;

    my %types = ( intPostalInfo => 'int', locPostalInfo => 'loc', legalInfo => 'legal' );
    foreach my $type ( keys %types ) {
        if ( $txtcont =~ /(.+)<\/contact:$type>/s ) {
            my $pi = $1;

            if ( $pi =~ /([^<>]+)<\/contact:name>/ ) {
                $cont{$types{$type}}{name} = $1;
            }
            if ( $pi =~ /([^<>]+)<\/contact:org>/ ) {
                $cont{$types{$type}}{org} = $1;
            }

            $cont{$types{$type}}{addr} = [ $pi =~ /([^<>]+)<\/contact:address>/g ];
        }
    }

    if ( $txtcont =~ /([^<>]+)<\/contact:taxpayerNumbers>/ ) {
        $cont{taxpayerNumbers} = $1;
    }

    if ( $is_person ) {
        if ( $txtcont =~ /([^<>]+)<\/contact:birthday>/ ) {
            $cont{birthday} = $1;
        }

        $cont{passport} = [ $txtcont =~ /([^<>]+)<\/contact:passport>/g ];
    }

    $cont{voice} = [ $txtcont =~ /([^<>]+)<\/contact:voice>/g ];

    $cont{fax} = [ $txtcont =~ /([^<>]+)<\/contact:fax>/g ];

    $cont{email} = [ $txtcont =~ /([^<>]+)<\/contact:email>/g ];

    if ( $txtcont =~ // ) {
        $cont{verified} = 1;
    }
    elsif ( $txtcont =~ // ) {
        $cont{verified} = 0;
    }

    my %id = %IO::EPP::Base::id;
    foreach my $k ( keys %id ) {
        if ( $txtcont =~ /([^<>]+)<\/contact:$k>/ ) {
            $cont{$id{$k}} = $1;
        }
    }

    my %dt = %IO::EPP::Base::dt;
    foreach my $k ( keys %dt ) {
        if ( $txtcont =~ /([^<>]+)<\/contact:$k>/ ) {
            $cont{$dt{$k}} = $1;

            $cont{$dt{$k}} =~ s/T/ /;
            $cont{$dt{$k}} =~ s/\.\d+Z$//;
        }
    }

    return \%cont;
}


sub create_domain_authinfo {
    my ( $self, $params ) = @_;

    return '' unless $params->{authinfo};

    $params->{authinfo} =~ s/&/&/g;

    return "\n    \n     $$params{authinfo}\n    ";
}

=head2 transfer

Addition parameter for .SU, .NET.RU, .ORG.RU, .PP.RU:
C - registrar name which will receive the domain (here all on the contrary)

=cut

sub transfer {
    my ( $self, $params ) = @_;

    if ( $params->{to} ) {
        $params->{addition} = "\n    $$params{sent_to}";
    }

    if ( $params->{user} =~ /-(RU|RF)$/ ) {
        $self->{urn}{dom} = $epp_dom_urn_ru;
    }

    my @res = $self->SUPER::transfer( $params );

    $self->{urn}{dom} = $IO::EPP::RIPN::epp_dom_urn;

    return @res;
}


=head2 get_registrar_info

Get Registrar data: white IP, email, whois data

=cut

sub get_registrar_info {
    my ( $self ) = @_;

    my $cltrid = $self->get_cltrid();

    my $body = <
$$self{urn}{head}



    $$self{user}


  $cltrid


REGINFO

    my $answ = $self->req( $body, 'registrar_info' );

    if ( $answ  &&  $answ =~ // ) {
        my $rcode = $1 + 0;

        my $msg = '';
        if ( $answ =~ /]*>(.+)<\/msg>.+\/result>/s ) {
            $msg = $1;
        }

        if ( $rcode != 1000 ) {
            if ( $answ =~ /(.+)<\/reason>/s ) {
                $msg .= '; ' . $1;
            }

            return wantarray ? ( 0, $rcode, $msg ) : 0;
        }

        my $info = {};

        if ( $answ =~ /(.+)<\/resData>/s ) {
            my $rdata = $1 // '';

            my %types = ( intPostalInfo => 'int', locPostalInfo => 'loc', legalInfo => 'legal' );
            foreach my $type ( keys %types ) {
                if ( $rdata =~ /(.+)<\/registrar:$type>/s ) {
                    my $pi = $1;
                    if ( $pi =~ /([^<>]+)<\/registrar:org>/ ) {
                        $info->{$types{$type}}{org} = $1;
                    }

                    $info->{$types{$type}}{address} = join(', ', $pi =~ /([^<>]+)<\/registrar:address>/g );
                }
            }

            if ( $rdata =~ /([^<>]+)<\/registrar:taxpayerNumbers>/ ) {
                $info->{taxpayerNumbers} = $1;
            }

            $info->{voice} = [ $rdata =~ /([^<>]+)<\/registrar:voice>/g ];

            $info->{fax} = [ $rdata =~ /([^<>]+)<\/registrar:fax>/g ];

            my @emails = $rdata =~ /([^<>]+<\/registrar:email>)/g;

            foreach my $e ( @emails ) {
                if ( $e =~ /registrar:email type="([^"]+)">([^<>]+)<\/registrar:email/ ) {
                    $info->{emails}{$1} = $2;
                }
            }

            if ( $rdata =~ /([^<>]+)<\/registrar:www>/ ) {
                $info->{www} = $1;
            }

            if ( $rdata =~ /([^<>]+)<\/registrar:whois>/ ) {
                $info->{whois} = $1;
            }

            $info->{addrs} = [ $rdata =~ /([0-9A-Fa-f.:]+)<\/registrar:addr>/g ];

            my %dt = %IO::EPP::Base::dt;
            foreach my $k ( keys %dt ) {
                if ( $rdata =~ /([^<>]+)<\/registrar:$k>/ ) {
                    $info->{$dt{$k}} = $1;

                    $info->{$dt{$k}} =~ s/T/ /;
                    $info->{$dt{$k}} =~ s/\.\d+Z$//;
                }
            }
        }

        return wantarray ? ( $info, $rcode, $msg ) : $info;
    }

    return wantarray ? ( 0, 0, 'empty answer' ) : 0;
}


=head2 update_registrar

Changing Registrar data: white IP, email, whois data

INPUT:

key of params:

C or C:

C -- arrayref of ipv4 or ipv6 address,

C - hashref where keys - email type, values - email

C:

C - new web url
C - new whois url

=cut

sub update_registrar {
    my ( $self, $params ) = @_;

    return ( 0, 0, 'no params' ) unless ref $params;

    my $cltrid = $self->get_cltrid();

    my $add = '';
    if ( $params->{add} ) {
        if ( defined $params->{add}{ips}  and  ref $params->{add}{ips} ) {
            foreach my $ip ( @{$params->{add}{ips}} ) {
                if ( $ip =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
                    $add .= '     ' . $ip . "\n";
                }
                else {
                    $add .= '     ' . $ip . "\n";
                }
            }
        }

        if ( defined $params->{add}{emails}  and  ref $params->{add}{emails} ) {
            foreach my $type ( @{$params->{add}{emails}} ) {
                $add .= qq|     | . $$params{add}{emails}{$type} . "\n";
            }
        }
    }

    if ( $add ) {
        $add = "\n$add    ";
    }
    else {
        $add = ''
    }

    my $rem = '';
    if ( $params->{rem} ) {
        if ( defined $params->{rem}{ips}  &&  ref $params->{rem}{ips} ) {
            foreach my $ip ( @{$params->{rem}{ips}} ) {
                if ( $ip =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
                    $rem .= '     ' . $ip . "\n";
                }
                else {
                    $rem .= '     ' . $ip . "\n";
                }
            }
        }

        if ( defined $params->{rem}{emails}  and  ref $params->{rem}{emails} ) {
            foreach my $type ( @{$params->{rem}{emails}} ) {
                $rem .= qq|     | . $$params{rem}{emails}{$type} . "\n";
            }
        }
    }

    if ( $rem ) {
        $rem = "\n$rem    ";
    }
    else {
        $rem = ''
    }

    my $chg = '';
    if ( $params->{chg} ) {
        if ( $params->{chg}{www} ) {
            $chg .= '     ' . $$params{chg}{www} . "\n";
        }

        if ( $params->{chg}{whois} ) {
            $chg .= '     ' . $$params{chg}{www} . "\n";
        }
    }

    if ( $chg ) {
        $chg = "\n$chg    ";
    }
    else {
        $chg = "";
    }


    my $body = <
$$self{urn}{head}



    $$self{user}
    $add
    $rem
    $chg


  $cltrid


UPDREG

    return $self->simple_request( $body, 'update_registrar' );
}


=head2 get_billing_info

INPUT:

keys of params:

C,
C: in days,
C: RUB.

=cut

sub get_billing_info {
    my ( $self, $params ) = @_;

    return ( 0, 0, 'no params' ) unless ref $params;

    my $cltrid = $self->get_cltrid();

    my $body = <
$$self{urn}{head}



   balance

     $$params{date}
     $$params{period}
     $$params{currency}



  $cltrid


BILINFO

    my $answ = $self->req( $body, 'billing_info' );

    if ( $answ  &&  $answ =~ // ) {
        my $rcode = $1 + 0;

        my $msg = '';
        if ( $answ =~ /]*>(.+)<\/msg>.+\/result>/s ) {
            $msg = $1;
        }

        if ( $rcode != 1000 ) {
            if ( $answ =~ /(.+)<\/reason>/s ) {
                $msg .= '; ' . $1;
            }

            return wantarray ? ( 0, $rcode, $msg ) : 0;
        }

        my $info = {};

        if ( $answ =~ /(.+)<\/resData>/s ) {
            my $rdata = $1 // '';

            my @billing = $rdata =~ /(]+>[^<>]+<\/billing:[^<>]+>)/g;

            foreach my $row ( @billing ) {
                if ( $row =~ /]*>([^<>]+)<\/billing:[^<>]+>/ ) {
                    $info->{$1} = $2;
                }
            }

            $info->{calc_date} = delete $info->{calcDate};
            $info->{calc_date} =~ s/T/ /;
            $info->{calc_date} =~ s/\.\d+Z$//;
        }

        return wantarray ? ( $info, $rcode, $msg ) : $info;
    }

    return wantarray ? ( 0, 0, 'empty answer' ) : 0;
}


=head2 get_limits_info

How many requests are left in this hour

=cut

sub get_limits_info {
    my ( $self ) = @_;

    my $cltrid = $self->get_cltrid();

    my $body = <
$$self{urn}{head}




 $cltrid


LIMINFO

    my $answ = $self->req( $body, 'limits_info' );

    if ( $answ  &&  $answ =~ // ) {
        my $rcode = $1 + 0;

        my $msg = '';
        if ( $answ =~ /]*>(.+)<\/msg>.+\/result>/s ) {
            $msg = $1;
        }

        if ( $rcode != 1000 ) {
            if ( $answ =~ /(.+)<\/reason>/s ) {
                $msg .= '; ' . $1;
            }

            return wantarray ? ( 0, $rcode, $msg ) : 0;
        }

        my $info = {};

        if ( $answ =~ /(.+)<\/resData>/s ) {
            my $rdata = $1 // '';

            my @limits = $rdata =~ /(]+>[^<>]+<\/limits:[^<>]+>)/g;

            foreach my $row ( @limits ) {
                if ( $row =~ /]+)>([^<>]+)<\/limits:[^<>]+>/ ) {
                    $info->{$1} = $2;
                }
            }
        }

        return wantarray ? ( $info, $rcode, $msg ) : $info;
    }

    return wantarray ? ( 0, 0, 'empty answer' ) : 0;
}


=head2 get_stat_info

Show domain statistics by metric

key of params:
C -- varians: C, C, C, C, C, C

Now not work:

code="2400", msg="Command failed", reason="Internal server error"

=cut

sub get_stat_info {
    my ( $self, $params ) = @_;

    return ( 0, 0, 'no params' ) unless ref $params;

    my $cltrid = $self->get_cltrid();

    my $body = <
$$self{urn}{head}






  $cltrid


STATINFO

    return $self->simple_request( $body, 'info' );
}


=head2 logout

Close session, disconnect

=cut

sub logout {
    my ( $self ) = @_;

    return 0 unless $self && $self->{sock};

    return 0 if $self->{alien};

    my $cltrid = $self->get_cltrid();

    my $body = <
$$self{urn}{head}


  $cltrid


LOGOUT

    # The answer doesn't matter
    $self->req( $body, 'logout' );

    delete $$self{sock};
    delete $$self{cook};
    delete $$self{cookies};
    delete $$self{sessionid};
    delete $$self{user};
    delete $$self{url};
}

1;


__END__