File Coverage

blib/lib/IO/EPP/Test/Base.pm

Criterion	Covered	Total	%
statement	893	1089	82.0
branch	445	664	67.0
condition	70	112	62.5
subroutine	32	33	96.9
pod	0	23	0.0
total	1440	1921	74.9

package IO::EPP::Test::Base;

=encoding utf8

=head1 NAME

IO::EPP::Test::Base

=head1 SYNOPSIS

Call IO::EPP::Base with parameter "test_mode=1"

=head1 DESCRIPTION

Module for testing IO::EPP::CNic,
emulates answers of base registry

=head1 AUTHORS

Vadim Likhota

=cut

use Digest::MD5 qw(md5_hex);

use IO::EPP::Base ();
use IO::EPP::Test::Server;

use strict;
use warnings;

no utf8; # !!!

our %statuses = (
    clientHold => '+',
    clientRenewProhibited => 'renewed',
    clientDeleteProhibited => 'deleted',
    clientUpdateProhibited => 'updated',
    clientTransferProhibited => 'transfered',
    serverHold => '+',
    serverRenewProhibited => 'renewed',
    serverDeleteProhibited => 'deleted',
    serverUpdateProhibited => 'updated',
    serverTransferProhibited => 'transfered',
);

sub req {
    my ( $obj, $out_data, undef ) = @_;

    my $in_data;

    if ( !$out_data  or  $out_data =~ m|]+/>| ) {
        $in_data = hello( $out_data );
    }
    elsif ( $out_data =~ m||s ) {
        $in_data = login( $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = contact_check( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = contact_create_update( $obj, $out_data, 'create' );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = contact_create_update( $obj, $out_data, 'update' );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = contact_info( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = contact_delete( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = host_check( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = host_create( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = host_info( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = host_update( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = host_delete( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = domain_check( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = domain_create( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = domain_info( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = domain_renew( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = domain_update( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = domain_delete( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = domain_transfer( $obj, $out_data );
    }
    elsif ( $out_data =~ m|]+>| ) {
        $in_data = poll( $obj, $out_data );
    }
    elsif ( $out_data =~ m|| ) {
        $in_data = logout( $out_data );
    }
    else {
        die "closed connection\n"; # behavior centralnic
    }

    return $in_data;
}


sub get_svtrid {
    return 'TEST-' . uc( md5_hex( time() . $$ . rand(1000000) ) ); # as CNIC-7E024512B06F1FC202C6E625DE12C69984799AA81D578111813DFF29646
}


sub get_dates {
    my ( $y ) = @_;
    $y ||= 0;
    my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);

    $year += 1900;
    $mon  += 1;
    my $year2 = $year + $y;

    my $dt1 = sprintf( '%0004d-%02d-%02dT%02d:%02d:%02d.0Z', $year,  $mon, $mday, $hour, $min, $sec );
    my $dt2 = sprintf( '%0004d-%02d-%02dT23:59:59.0Z', $year2, $mon, $mday );

    return $dt1, $dt2;
}


sub hello {
    my ( $dt ) = get_dates();

    return qq|EXAMPLE EPP server EPP.EXAMPLE.COM$dt1.0enurn:ietf:params:xml:ns:domain-1.0urn:ietf:params:xml:ns:contact-1.0urn:ietf:params:xml:ns:host-1.0urn:ietf:params:xml:ns:rgp-1.0urn:ietf:params:xml:ns:secDNS-1.1urn:ietf:params:xml:ns:idn-1.0|;
}

sub _fail_cltrid {
    my $svtrid = get_svtrid();

    return qq|



XML schema validation failed: Element '{urn:ietf:params:xml:ns:epp-1.0}clTRID': The value has a length of '0';


xxxx
$svtrid


|;
}

sub _fail_body {
    my ( $err, $code, $cl ) = @_;
    my $svtrid = get_svtrid();
    $cl ||= 'xxxx';

    return qq|



$err


$cl
$svtrid


|;
}

sub _ok_answ {
    my ( $res, $cl ) = @_;

    my $svtrid = get_svtrid();

    $cl ||= 'xxxx';

    return qq|Command completed successfully.$res$cl$svtrid|;
}

sub _min_answ {
    my ( $code, $cl ) = @_;

    my $svtrid = get_svtrid();

    $cl ||= 'xxxx';

    return qq|Command completed successfully.$cl$svtrid|;
}

sub login {
    my ( $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    my $body2;
    if ( $body =~ m|\s*\s*(.+?)\s+[^<>]+\s+\s+|s ) {
        $body2 = $1;
    }
    else {
        die "closed connection\n"; # behavior centralnic
    }

    my ( $login ) = $body =~ m|([0-9A-Za-z_\-]+)|;

    my $svtrid = get_svtrid();

    return qq|



Cannot authenticate $login: not found in database.


$cltrid
$svtrid


|
        unless $login;

    my ( $pass ) = $body =~ m|([0-9A-Za-z!\@\$\%*_.:=+?#,"'\-{}\[\]\(\)]+)|;

    if ( !$pass  ||  length( $pass ) < 6 ) {
        return qq|



XML schema validation failed: Element '{urn:ietf:params:xml:ns:epp-1.0}pw': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '6'.


$cltrid
$svtrid


|;
    }

    if ( $pass eq 'fail-pass' ) {
        return qq|



Invalid password


$cltrid
$svtrid


|;
    }

    return qq|Welcome user.$cltrid$svtrid|;
}


sub contact_check {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: contact:check', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /contact:check', '2001', $cltrid );
    }

    my ( @contacts ) = $body =~ m|([^<>]+)|g;

    unless ( scalar @contacts ) {
        return _fail_body( 'XML schema validation failed: contact:cd' );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $answ_list = '';
    foreach my $row ( @contacts ) {
        my ( $cont_id ) = $row =~ m|([^<>]+)|;

        my $reason = '';
        if ( $s->data->{conts}{$cont_id} ) {
            $reason = $s->data->{conts}{$cont_id}{reason};
        }

        my $avail = $reason ? 0 : 1;

        $reason = "$reason" if $reason;

        $answ_list .= qq|$cont_id$reason|;
    }

    my $svtrid = get_svtrid();

    return qq|



Command completed successfully.

$answ_list
$cltrid$svtrid


|;
}


sub contact_create_update {
    my ( $obj, $body, $act ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+<$act>\s+]+>\s+||s ) {
        return _fail_body( "XML schema validation failed: contact:$act", '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( "XML schema validation failed: /contact:$act", '2001', $cltrid );
    }

    my $i = () = $body =~ //g;

    if ( $i > 1 ) {
        # text from verisign NameStore server
        _fail_body( 'Parameter value policy error, Only one int postal address information allowed', '2306', $cltrid );
    }

    my $l = () = $body =~ //g;

    if ( $l > 1 ) {
        _fail_body( 'Parameter value policy error, Only one loc postal address information allowed', '2306', $cltrid );
    }

    if ( $i+$l == 0 ) {
        _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}voice': This element is not expected. Expected is ( {urn:ietf:params:xml:ns:contact-1.0}postalInfo ).', '2001', $cltrid );
    }

    my %cont;
    if ( $body =~ m|([^<>]+)| ) {
        $cont{id} = $1;
    }
    else {
        return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}$act': Missing child element(s). Expected is one of ( {urn:ietf:params:xml:ns:contact-1.0}id, {urn:ietf:params:xml:ns:contact-1.0}ext ).", '2001', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );

    my $top;
    if ( $act eq 'create' ) {
        if ( $s->data->{conts}{$cont{id}} ) {
            if ( $s->data->{conts}{$cont{id}}{reason} eq 'in use' ) {
                return _fail_body( "Contact object '$cont{id}' already exists.", '2302', $cltrid );
            }
            else {
                return _fail_body( "Contact object '$cont{id}' $s->data->{conts}{$cont{id}}{reason}.", '2302', $cltrid );
            }
        }

        $top = 'create';
    }
    elsif ( $act eq 'update' ) {
        unless ( $s->data->{conts}{$cont{id}}  and  $s->data->{conts}{$cont{id}}{reason} eq 'in use' ) {
            # contact does not exist, the reason does not
            return _fail_body( 'Cannot find that object.', '2303', $cltrid );
        }

        $top = 'chg';
    }

    for my $t ( 'int', 'loc' ) {
        if ( $body =~ m|(.+?)|s ) {
            $cont{$t} = $1;
        }
    }


    for my $t ( 'int', 'loc' ) {
        my $pi = delete $cont{$t};
        next unless $pi;

        $cont{$t} = {};
        foreach my $f ( 'name', 'org', 'addr' ) {
            if ( $pi =~ m|(.+?)|s ) {
                $cont{$t}{$f} = $1;
            }
            elsif ( $pi =~ m|| ) {
                if ( $f eq 'org' ) {
                    # $cont{$t}{$f} = undef;
                }
                else {
                    return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}$f': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.", '2001', $cltrid );
                }
            }
            else {
                if ( $f eq 'name'  &&  $act eq 'create' ) {
                    return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}postalInfo': Missing child element(s). Expected is one of ( {urn:ietf:params:xml:ns:contact-1.0}$f, {urn:ietf:params:xml:ns:contact-1.0}ext ).", '2001', $cltrid );
                }
            }
        }

        my $addr = delete $cont{$t}{addr};
        $cont{$t}{addr} = {};

        my @street = $addr =~ m|([^<>]+)|g;
        unless ( scalar @street ) {
            return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}addr': Missing child element(s). Expected is one of ( {urn:ietf:params:xml:ns:contact-1.0}street, {urn:ietf:params:xml:ns:contact-1.0}ext ).", '2001', $cltrid );
        }
        $cont{$t}{addr}{street} = [];
        foreach my $row ( @street ) {
            if ( $row =~ m|([^<>]+)| ) {
                push @{$cont{$t}{addr}{street}}, $1;
            }
        }

        foreach my $f ( 'city', 'sp', 'pc' , 'cc' ) {
            if ( $pi =~ m|(.+?)|s ) {
                $cont{$t}{addr}{$f} = $1;
            }
            elsif ( $pi =~ m|| ) {
                if ( $f eq 'sp' ) {
                    # $cont{$t}{addr}{$f} = undef;
                }
                else {
                    return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}$f': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.", '2001', $cltrid );
                }
            }
            else {
                return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}addr': Missing child element(s). Expected is one of ( {urn:ietf:params:xml:ns:contact-1.0}$f, {urn:ietf:params:xml:ns:contact-1.0}ext ).", '2001', $cltrid );
            }
        }

        unless ( $cont{$t}{addr}{cc}  &&  length( $cont{$t}{addr}{cc} ) == 2 ) {
            return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}cc': [facet 'length'] The value has a length of '4'; this differs from the allowed length of '2'.', '2001', $cltrid );
        }

        if ( $cont{$t}{addr}{cc} !~ /^[A-Z]+$/ ) {
            return _fail_body( "The country code '$cont{$t}{addr}{cc}' is not known to us", '2004', $cltrid );
        }
    }

    foreach my $f ( 'voice', 'fax', 'email' ) {
        if ( $body =~ // ) {
            my @cfs = $body =~ m|([^<>]*)|g; # contact fields

            $cont{$f} = [];
            foreach my $cf ( @cfs ) {
                if ( $cf =~ m|([^<>]*)| ) {
                    my $c = $1;

                    if ( length( $c ) == 0 ) {
                        return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}$f': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.", '2001', $cltrid );
                    }
                    elsif ( $f eq 'fax'  ||  $f eq 'voice'  and  $c !~ /^\+\d{1,3}\.\d{1,14}$/ ) {
                        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}voice': [facet 'pattern'] The value 'A380954272445' is not accepted by the pattern '(\\+[0-9]{1,3}\\.[0-9]{1,14})?'.', '2001', $cltrid );
                    }
                    elsif ( $f eq 'email'  and  $c !~  /^[0-9a-z\.\-]+\@[0-9a-z\.\-]+$/ ) {
                        return _fail_body( 'E-mail address is invalid or missing', '2004', $cltrid );
                    }
                    else {
                        push @{$cont{$f}}, $c;
                    }
                }
            }
        }
        elsif ( $f eq 'fax'  and  $body =~ m||  ) {
            $cont{$f} = [];
        }
        else {
            return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}$top': Missing child element(s). Expected is one of ( {urn:ietf:params:xml:ns:contact-1.0}$f, {urn:ietf:params:xml:ns:contact-1.0}ext ).", '2001', $cltrid );
        }
    }

    if ( $body =~ m|\s*([^<>]+)\s*|s ) {
        $cont{authInfo} = $1;
    }
    elsif ( $body =~ m|\s*\s*| ) {
        $cont{authInfo} = '';
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}authInfo': Missing child element(s). Expected is one of ( {urn:ietf:params:xml:ns:contact-1.0}pw, {urn:ietf:params:xml:ns:contact-1.0}ext ).', '2001', $cltrid );
    }
    if ( $cont{authInfo}  and  length( $cont{authInfo} ) < 16 ) {
        return _fail_body( 'authInfo code is invalid: password must be at least 16 characters', '2004', $cltrid );
    }
    unless ( $cont{authInfo}  and   $cont{authInfo} =~ /[A-Z]/  and  $cont{authInfo} =~ /[a-z]/  and  $cont{authInfo} =~ /[0-9]/  and  $cont{authInfo} =~ /[!\@\$\%*_.:\-=+?#,"'\\\/&]/ ) {
        return _fail_body( 'authInfo code is invalid: password must contain a mix of uppercase and lowercase characters', '2004', $cltrid );
    }

    # TODO: update statuses

    if ( $act eq 'create' ) {
        my ( $cre_date ) = get_dates();

        $s->data->{conts}{$cont{id}} = { %cont, reason => 'in use', statuses => { 'ok' => '+' }, owner => $obj->{user}, creater => $obj->{user}, updater => $obj->{user}, cre_date => $cre_date, upd_date => $cre_date, roid => uc(md5_hex($cont{id}.$cre_date)) . '-TEST' };

        return _ok_answ( qq|$cont{id}$cre_date|, $cltrid );
    }
    else { # update
        my $old = $s->data->{conts}{$cont{id}};

        if ( $old->{owner} ne $obj->{user} ) {
            # TODO: check main domain
            return _fail_body( 'You are not authorised to modify this contact object (you do not sponsor the parent domain).', '2201', $cltrid );
        }

        my ( $upd_date ) = get_dates();

        foreach my $f ( 'voice','fax','email','authInfo' ) {
            $old->{$f} = $cont{$f};
        }

        for my $t ( 'int', 'loc' ) {
            if ( $cont{$t} ) {
                $old->{$t}{name} = $cont{$t}{name} if $cont{$t}{name};
                if ( $cont{$t}{org} ) {
                    $old->{$t}{org} = $cont{$t}{org}
                }
                else {
                    delete $old->{$t}{org};
                }
                $old->{$t}{addr} = $cont{$t}{addr};
            }
            else {
                delete $old->{$t};
            }
        }

        $old->{upd_date} = $upd_date;
        $old->{updater} = $obj->{user};

        my $svtrid = get_svtrid();

        return _min_answ( '1000', $cltrid );
    }
}


sub contact_info {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: contact:info', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /contact:info', '2001', $cltrid );
    }

    my $id;
    if ( $body =~ m|([^<>]+)| ) {
        $id = $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}id': [facet 'minLength'] The value has a length of '1'; this underruns the allowed minimum length of '3'.', '2001', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );

    unless ( $s->data->{conts}{$id} ) {
        return _fail_body( "Cannot find an object with an ID of $id.", '2303', $cltrid );
    }

    my %cont = %{$s->data->{conts}{$id}};

    my $answ = '' .
        $id . '' . $cont{roid} . '';

    foreach my $s ( keys %{ $cont{statuses} } ) {
        if ( $cont{statuses}{$s} eq '+' ) {
            $answ .= qq||;
        }
        else {
            $answ .= qq|| . $cont{statuses}{$s} . '';
        }
    }

    for my $t ( 'int', 'loc' ) {
        if ( $cont{$t} ) {
            $answ .= qq||.$cont{$t}{name}.'';
            $answ .= $cont{$t}{org} ? qq|$cont{$t}{org}| : '' ;
            $answ .= '';
            $answ .= qq|$_| for @{$cont{$t}{addr}{street}};
            $answ .= qq|$cont{$t}{addr}{city}|;
            $answ .= $cont{$t}{addr}{sp} ? qq|$cont{$t}{addr}{sp}| : '';
            $answ .= $cont{$t}{addr}{sp} ? qq|$cont{$t}{addr}{sp}| : '';
            $answ .= $cont{$t}{addr}{cc} ? qq|$cont{$t}{addr}{cc}| : '';
            $answ .= '';
            $answ .= '';
        }
    }
    foreach my $v ( @{$cont{voice}} ) {
        $answ .= "$v";
    }
    if ( scalar @{$cont{fax}} ) {
        foreach my $f ( @{$cont{fax}} ) {
            $answ .= "$f";
        }
    }
    else {
        $answ .= '';
    }
    foreach my $e ( @{$cont{email}} ) {
        $answ .= "$e";
    }
    $answ .= "$cont{owner}";
    $answ .= "$cont{creater}";
    $answ .= "$cont{cre_date}";
    $answ .= "$cont{updater}" if $cont{updater};
    $answ .= "$cont{upd_date}";

    $answ .= qq||;

    return _ok_answ( $answ, $cltrid );
}


sub contact_delete {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: contact:info', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /contact:delete', '2001', $cltrid );
    }

    my $id;
    if ( $body =~ m|([^<>]+)| ) {
        $id = $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:contact-1.0}id': [facet 'minLength'] The value has a length of '1'; this underruns the allowed minimum length of '3'.', '2001', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );

    unless ( $s->data->{conts}{$id} ) {
        return _fail_body( "Contact object cannot be found.", '2303', $cltrid );
    }

    if ( $s->data->{conts}{$id}{statuses}{linked} ) {
        return _fail_body( 'Contact object is linked to one or more domains.', '2305', $cltrid );
    }

    if ( $s->data->{conts}{$id}{owner} ne $obj->{user} ) {
        return _fail_body( 'Permission denied.', '2201', $cltrid );
    }

    delete $s->data->{conts}->{$id};

    my $svtrid = get_svtrid();

    return _min_answ( '1000', $cltrid );
}


sub host_check {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: host:check', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /host:check', '2001', $cltrid );
    }

    my ( @hosts ) = $body =~ m|([^<>]+)|g;

    unless ( scalar @hosts ) {
        return _fail_body( 'XML schema validation failed: host:cd', '2001', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $answ_list = '';
    foreach my $row ( @hosts ) {
        my ( $ns ) = $row =~ m|([^<>]+)|;
        $ns = lc $ns;

        my $reason = '';

        if ( $s->data->{nss}{$ns} ) {
            $reason = $s->data->{nss}{$ns}{reason} || '';
        }
        elsif ( $ns !~ /^[0-9a-z\.\-]+$/ ) {
            my ( $c ) = $ns !~ /([^0-9a-z\.\-])/;
            $reason = 'the following characters are not permitted: ''.$c.''';
        }

        my $avail = $reason ? 0 : 1;

        $reason = "$reason" if $reason;

        $answ_list .= qq|$ns$reason|;
    }

    my $svtrid = get_svtrid();

    return qq|



Command completed successfully.

$answ_list
$cltrid$svtrid


|;
}


sub host_create {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: host:create', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /host:create', '2001', $cltrid );
    }

    my ( $ns, $local_ns );
    if ( $body =~ m|([0-9A-Za-z\-\.]+)| ) {
        $ns = lc $1;
    }
    else {
        return _fail_body( 'Host name is invalid.', '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $nss = $s->data->{nss};
    my $doms = $s->data->{doms};

    if ( $nss->{$ns} ) {
        return _fail_body( 'A host object with that hostname already exists.', '2302', $cltrid );
    }

    my @v4 = $body =~ m|([^<>]+)|g;
    my @v6 = $body =~ m|([^<>]+)|g;

    foreach my $dm ( keys %{$doms} ) {
        if ( $ns =~ /\.$dm$/ ) {
            if ( $doms->{$dm}{owner} ne $obj->{user} ) {
                return _fail_body( 'You are not the sponsor for the parent domain of this host and cannot create subordinate host objects for it.', '2201', $cltrid );
            }
            elsif ( ( scalar( @v4 ) + scalar( @v6 ) ) == 0 ) {
                return _fail_body( 'You need IPv4 or IPv6 address.', '2004', $cltrid );
            }

            $local_ns = $dm;
        }
    }

    foreach my $v ( @v4 ) {
        unless ( $v =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
            return _fail_body( "IP address $v is not valid.", '2004', $cltrid );
        }
    }
    foreach my $v ( @v6 ) {
        unless ( $v =~ /^[0-9a-z:]{1,29}$/ ) {
            return _fail_body( "IP address $v is not valid.", '2004', $cltrid );
        }
    }

    my ( $cre_date ) = get_dates();

    $nss->{$ns} = { avail => 0, reason => 'in use', statuses => { ok => '+' }, creater => $obj->{user}, owner => $obj->{user}, cre_date => $cre_date, addr_v4 => \@v4, addr_v6 => \@v6, roid => uc(md5_hex($ns.$cre_date)) . '-TEST' };

    if ( $local_ns ) {
        $doms->{$local_ns}{hosts}{$ns} = '+';
    }

    return _ok_answ( qq|$ns$cre_date|, $cltrid );
}


sub host_info {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: host:info', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /host:info', '2001', $cltrid );
    }

    my $ns;
    if ( $body =~ m|([0-9A-Za-z\-\.]+)| ) {
        $ns = lc $1;
    }
    else {
        return _fail_body( 'Host name is invalid.', '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $nss = $s->data->{nss};

    unless ( $nss->{$ns} ) {
        return _fail_body( "The host '$ns' does not exist", '2303', $cltrid );
    }

    my $answ = '';
    $answ   .= "$ns";
    $answ   .= "$$nss{$ns}{roid}";
    foreach my $st ( keys %{$$nss{$ns}{statuses}} ) {
        if ( $$nss{$ns}{statuses}{$st} eq '+' ) {
            $answ .= qq||;
        }
        else {
            $answ .= qq|| . $$nss{$ns}{statuses}{$st} . '';
        }
    }
    foreach my $v ( @{$$nss{$ns}{addr_v4}} ) {
        $answ .= qq|$v|;
    }
    foreach my $v ( @{$$nss{$ns}{addr_v6}} ) {
        $answ .= qq|$v|;
    }
    $answ   .= "$$nss{$ns}{owner}";
    $answ   .= "$$nss{$ns}{creater}";
    $answ   .= "$$nss{$ns}{cre_date}";
    $answ   .= "$$nss{$ns}{upd_date}" if $$nss{$ns}{upd_date};
    $answ   .= '';

    return _ok_answ( $answ, $cltrid );
}


sub host_update {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: host:update', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /host:update', '2001', $cltrid );
    }

    my ( $ns, $local_ns );
    if ( $body =~ m|([0-9A-Za-z\-\.]+)| ) {
        $ns = lc $1;
    }
    else {
        return _fail_body( 'Host name is invalid.', '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $nss = $s->data->{nss};

    unless ( $nss->{$ns} ) {
        return _fail_body( "The host '$ns' does not exist", '2303', $cltrid );
    }

    if ( $nss->{$ns}{owner} ne $obj->{user} ) {
        # TODO: check main domain
        return _fail_body( 'You are not authorised to modify this host object (you do not sponsor the parent domain).', '2201', $cltrid );
    }

    my ( @a4, @a6, @d4, @d6, @ast, @dst );

    for my $act ( 'add', 'rem' ) {
        if ( $body =~ m|(.+?)|s ) {
            my $ab = $1;

            my @v4 = $ab =~ m|([^<>]+)|g;
            my @v6 = $ab =~ m|([^<>]+)|g;

            foreach my $v ( @v4 ) {
                unless ( $v =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
                    return _fail_body( "IP address $v is not valid.", '2004', $cltrid );
                }

                if ( $act eq 'add' ) { push @a4, $v } else { push @d4, $v }
            }

            foreach my $v ( @v6 ) {
                unless ( $v =~ /^[0-9a-f:]{1,29}$/ ) {
                    return _fail_body( "IP address $v is not valid.", '2004', $cltrid );
                }

                if ( $act eq 'add' ) { push @a6, $v } else { push @d6, $v }
            }

            # Centralnic ignored add/rem client* statuses for host
        }
    }

    # TODO: chg name

    if ( scalar @a4 ) {
        my %h = map { $_ => '+' } @{$nss->{$ns}{addr_v4}};

        $h{$_} = '+' for @a4;

        $nss->{$ns}{addr_v4} = [ sort keys %h ];
    }

    if ( scalar @a6 ) {
        my %h = map { $_ => '+' } @{$nss->{$ns}{addr_v6}};

        $h{$_} = '+' for @a6;

        $nss->{$ns}{addr_v6} = [ sort keys %h ];
    }

    if ( scalar @d4 ) {
        my %h = map { $_ => '+' } @{$nss->{$ns}{addr_v4}};

        delete( $h{$_} ) for @d4;

        $nss->{$ns}{addr_v4} = [ sort keys %h ];
    }

    if ( scalar @d6 ) {
        my %h = map { $_ => '+' } @{$nss->{$ns}{addr_v6}};

        delete( $h{$_} ) for @d6;

        $nss->{$ns}{addr_v6} = [ sort keys %h ];
    }

    my $svtrid = get_svtrid();

    return _min_answ( '1000', $cltrid );
}


sub host_delete {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: host:delete', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /host:delete', '2001', $cltrid );
    }

    my $ns;
    if ( $body =~ m|([0-9A-Za-z\-\.]+)| ) {
        $ns = lc $1;
    }
    else {
        return _fail_body( 'Host name is invalid.', '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $nss = $s->data->{nss};

    unless ( $nss->{$ns} ) {
        return _fail_body( "The host '$ns' does not exist", '2303', $cltrid );
    }

    if ( $nss->{$ns}{statuses}{linked} ) {
        return _fail_body( 'Host object is linked to one or more domains.', '2305', $cltrid );
    }

    my $doms = $s->data->{doms};
    foreach my $dm ( keys %{$doms} ) {
        if ( $ns =~ /\.$dm$/ ) {
            delete $doms->{$dm}{hosts}->{$ns};
        }
    }

    if ( $nss->{$ns}{owner} ne $obj->{user} ) {
        return _fail_body( 'Permission denied.', '2201', $cltrid );
    }

    delete $nss->{$ns};

    my $svtrid = get_svtrid();

    return _min_answ( '1000', $cltrid );
}


sub domain_check {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: domain:check', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /domain:check', '2001', $cltrid );
    }

    my ( @domains ) = $body =~ m|([^<>]+)|g;

    unless ( scalar @domains ) {
        return _fail_body( 'XML schema validation failed: domain:cd', '2001', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $answ_list = '';
    foreach my $row ( @domains ) {
        my ( $dm ) = $row =~ m|([^<>]+)|;
        $dm = lc $dm;

        my $reason = '';

        if ( $s->data->{doms}{$dm} ) {
            $reason = $s->data->{doms}{$dm}{reason} || '';
        }
        elsif ( $dm !~ /^[0-9a-z\.\-]+$/ ) {
            my ( $c ) = $dm !~ /([^0-9a-z\.\-])/;
            $reason = 'the following characters are not permitted: ''.$c.''';
        }
        elsif ( $dm =~ /^reg/ ) { # reged
            $reason = 'in use';
        }
        elsif ( $dm =~ /^blo/ ) {
            $reason = 'blocked';
        }
        elsif ( $dm =~ /^ava/ ) {
            # available
        }
        else {
            $reason = int( rand( 10 ) ) == 1 ? 'in use' : ''; # 10% -- domains is not available
        }

        my $avail = $reason ? 0 : 1;

        unless ( $s->data->{doms}{$dm} ) {
            if ( $reason  &&  $reason !~ /not permitted/ ) {
                $s->data->{doms}{$dm} = { avail => $avail, reason => $reason };
            }
        }

        $reason = "$reason" if $reason;

        $answ_list .= qq|$dm$reason|;
    }

    my $svtrid = get_svtrid();

    return qq|



Command completed successfully.

$answ_list
$cltrid$svtrid


|;
}


sub domain_create {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: domain:create', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /domain:create', '2001', $cltrid );
    }

    my $dname;
    if ( $body =~ m|([^<>]+)| ) {
        $dname = lc $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}name': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.', '2001', $cltrid );
    }

    if ( $dname =~ /([^0-9a-z\.\-])/ ) {
        return _fail_body( "'$dname' is not a valid domain name: the following characters are not permitted: '$1'", '2004', $cltrid );
    }

    if ( $dname !~ /^[0-9a-z\.\-]+\.[0-9a-z\-]+$/ ) {
        return _fail_body( "'$dname' is not a valid domain name: suffix ... does not exist", '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $conts = $s->data->{conts};
    my $nss   = $s->data->{nss};
    my $doms  = $s->data->{doms};

    if ( $doms->{$dname} ) {
        return _fail_body( "'$dname' is already registered.", '2302', $cltrid );
    }

    my $period;
    if ( $body =~ m|([^<>]+)| ) {
        $period = $1;

        if ( $period =~ /([^0-9])/ ) {
            return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}period': '$period' is not a valid value of the atomic type '{urn:ietf:params:xml:ns:domain-1.0}pLimitType'." );
        }
    }
    else {
        $period = 1;
    }

    if ( $period < 1  or $period > 9 ) {
        return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}period': [facet 'maxInclusive'] The value '100' is greater than the maximum value allowed ('9').", '2001', $cltrid );
    }

    my $reg_id;
    if ( $body =~ m|([^<>]+)| ) {
        $reg_id = $1;

        unless ( $conts->{$reg_id} ) {
            return _fail_body( "Specified registrant contact $reg_id is not registered here.", '2303', $cltrid );
        }
    }
    else {
        return _fail_body( 'The 'registrant' attribute is empty or missing', '2003', $cltrid );
    }

    my %cc = ( admin => {}, tech => {}, billing => {} );
    for my $t ( 'admin', 'tech', 'billing' ) {
        my @acs = $body =~ m|([^<>]+)|gs;

        foreach my $ac ( @acs ) {
            if ( $conts->{$ac} ) {
                $cc{$t}{$ac} = '+';
            }
            else {
                return _fail_body( "Specified $t contact $ac is not registered here.", '2303', $cltrid );
            }
        }
    }

    my $pw;
    if ( $body =~ m|\s*([^<>]+)\s*|s ) {
        $pw = $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}authInfo': Missing child element(s). Expected is one of ( {urn:ietf:params:xml:ns:domain-1.0}pw, {urn:ietf:params:xml:ns:domain-1.0}ext ).', '2001', $cltrid );
    }
    if ( $pw  and  length( $pw ) < 16 ) {
        return _fail_body( 'authInfo code is invalid: password must be at least 16 characters', '2004', $cltrid );
    }
    unless ( $pw  and  $pw =~ /[A-Z]/  and  $pw =~ /[a-z]/  and  $pw =~ /[0-9]/  and  $pw =~ /[!\@\$\%*_.:\-=+?#,"'\\\/&]/ ) {
        return _fail_body( 'authInfo code is invalid: password must contain a mix of uppercase and lowercase characters', '2004', $cltrid );
    }

    my %nss;
    if ( $body =~ m|(.+?)|s ) {
        my $hosts = $1;

        my @nss0 = $hosts =~ m|([^<>]+)|gs;

        foreach my $ns ( @nss0 ) {
            unless ( $nss->{$ns} ) {
                return _fail_body( "Cannot find host object '$ns'", '2303', $cltrid );
            }

            $nss{$ns} = '+';
        }
    }

    my ( $cre_date, $exp_date ) = get_dates( 1 );

    $doms->{$dname} = {
        registrant => $reg_id,
        admin => $cc{admin},
        tech => $cc{tech},
        billing => $cc{billing},
        nss => \%nss,
        cre_date => $cre_date,
        upd_date => $cre_date,
        exp_date => $exp_date,
        authInfo => $pw,
        roid => uc(md5_hex($dname.$cre_date)).'-TEST',
        statuses => { },
        creater => $obj->{user},
        owner => $obj->{user},
        updater => $obj->{user},
        avail => 0,
        reason => 'in use',
    };

    $conts->{$reg_id}{statuses}{linked}++;

    if ( $conts->{$reg_id}{statuses}{ok} ) {
        delete $conts->{$reg_id}{statuses}{ok};
        $conts->{$reg_id}{statuses}{serverDeleteProhibited} = '+';
    }

    for my $t ( 'admin', 'tech', 'billing' ) {

        foreach my $c ( keys %{$cc{$t}} ) {
            $conts->{$c}{statuses}{linked}++;

            if ( $conts->{$c}{statuses}{ok} ) {
                delete $conts->{$c}{statuses}{ok};
                $conts->{$c}{statuses}{serverDeleteProhibited} = '+';
            }
        }
    }

    foreach my $ns ( keys %nss ) {
        $nss->{$ns}{statuses}{linked}++;

        if ( $nss->{$ns}{statuses}{ok} ) {
            delete $nss->{$ns}{statuses}{ok};
            $nss->{$ns}{statuses}{serverDeleteProhibited} = '+';
        }
    }

    return _ok_answ( qq|$dname$cre_date$exp_date|, $cltrid );
}


sub domain_info {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: domain:info', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /domain:info', '2001', $cltrid );
    }

    my $dname;
    if ( $body =~ m|([^<>]+)| ) {
        $dname = lc $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}name': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.', '2001', $cltrid );
    }

    if ( $dname =~ /([^0-9a-z\.\-])/ ) {
        return _fail_body( "'$dname' is not a valid domain name: the following characters are not permitted: '$1'", '2004', $cltrid );
    }

    if ( $dname !~ /^[0-9a-z\.\-]+\.[0-9a-z\-]+$/ ) {
        return _fail_body( "'$dname' is not a valid domain name: suffix ... does not exist", '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $doms  = $s->data->{doms};

    unless ( $s->data->{doms}{$dname} ) {
        return _fail_body( "The domain '$dname' does not exist", '2303', $cltrid );
    }

    my $dm = $s->data->{doms}{$dname};

    my $answ = qq|$dname|;
    $answ .= "$$dm{roid}";
    unless ( scalar( keys %{$$dm{statuses}} ) ) {
        $answ .= qq||;
    }
    else {
        for my $st ( keys %{$$dm{statuses}} ) {
            if ( $$dm{statuses}{$st} eq '+' ) {
                $answ .= qq||;
            }
            else {
                $answ .= qq|| . $$dm{statuses}{$st} . '';
            }
        }
    }
    $answ .= "$$dm{registrant}";
    for my $t ( 'tech', 'admin', 'billing' ) {
        for my $c ( keys %{$$dm{$t}} ) {
            $answ .= qq|$c|;
        }
    }
    if ( $$dm{nss}  &&  scalar( keys %{$$dm{nss}} ) ) {
        $answ .= '';
        foreach my $ns ( keys %{$$dm{nss}} ) {
            $answ .= "$ns";
        }
        $answ .= '';
    }
    if ( $$dm{hosts}  &&  scalar( keys %{$$dm{hosts}} ) ) {
        foreach my $host ( sort keys %{$$dm{hosts}} ) {
            $answ .= "$host";
        }
    }
    # centralnic does not show authinfo to anybody
    $answ .= "$$dm{owner}";
    $answ .= "$$dm{creater}";
    $answ .= "$$dm{cre_date}";
    $answ .= "$$dm{updater}";
    $answ .= "$$dm{upd_date}";
    $answ .= "$$dm{exp_date}";
    $answ .= "$$dm{trans_date}" if $dm->{trans_date};
    $answ .= '';

    return _ok_answ( $answ, $cltrid );
}


sub domain_renew {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: domain:renew', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /domain:renew', '2001', $cltrid );
    }

    my $dname;
    if ( $body =~ m|([^<>]+)| ) {
        $dname = lc $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}name': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.', '2001', $cltrid );
    }

    if ( $dname =~ /([^0-9a-z\.\-])/ ) {
        return _fail_body( "'$dname' is not a valid domain name: the following characters are not permitted: '$1'", '2004', $cltrid );
    }

    if ( $dname !~ /^[0-9a-z\.\-]+\.[0-9a-z\-]+$/ ) {
        return _fail_body( "'$dname' is not a valid domain name: suffix ... does not exist", '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $doms  = $s->data->{doms};

    unless ( $s->data->{doms}{$dname} ) {
        return _fail_body( "The domain '$dname' does not exist", '2303', $cltrid );
    }

    my $dm = $s->data->{doms}{$dname};

    for my $s ( 'clientRenewProhibited', 'serverRenewProhibited' ) {
        if ( $dm->{statuses}{$s} ) {
            return _fail_body( "Domain cannot be renewed ($s)", 2304, $cltrid );
        }
    }

    my $period = 1;
    if ( $body =~ m|(\d+)| ) {
        $period = $1;

        if ( $period > 9 ) {
            return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}period': [facet 'maxInclusive'] The value '$period' is greater than the maximum value allowed ('9').", '2001', $cltrid );
        }
    }

    my $edt;
    if ( $body =~ m|(\d\d\d\d-\d\d-\d\d)| ) {
        $edt = $1;
    }
    else {
        return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}curExpDate': 'xxx' is not a valid value of the atomic type 'xs:date'.", '2001', $cltrid );
    }

    my ( $old_exp_date ) = $dm->{exp_date} =~ /^(\d\d\d\d-\d\d-\d\d)/;
    if ( $old_exp_date ne $edt ) {
        return _fail_body( 'Expiry date is not correct.', '2004', $cltrid );
    }

    $dm->{exp_date} =~ s/^(\d+)/$1+$period/e;
    my $new_exp_date = $dm->{exp_date};

    my $svtrid = get_svtrid();

    return qq|


                        Command completed successfully.




                                $dname
                                $new_exp_date



                        $cltrid
                        $svtrid


|;
=rem



                        Command completed successfully.




                                xxx.ru.com
                                2022-07-18T23:59:59.0Z


                USD18.00

                        f919bef2e68b168e5d39bf91aff6fa6e
                        CNIC-7295E4F58291FFD21B1702346BA9D70F25952BD03CF3780ECF0DA0D8285



=cut
}


sub domain_update {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: domain:update', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /domain:update', '2001', $cltrid );
    }

    my $dname;
    if ( $body =~ m|([^<>]+)| ) {
        $dname = lc $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}name': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.', '2001', $cltrid );
    }

    if ( $dname =~ /([^0-9a-z\.\-])/ ) {
        return _fail_body( "'$dname' is not a valid domain name: the following characters are not permitted: '$1'", '2004', $cltrid );
    }

    if ( $dname !~ /^[0-9a-z\.\-]+\.[0-9a-z\-]+$/ ) {
        return _fail_body( "'$dname' is not a valid domain name: suffix ... does not exist", '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $conts = $s->data->{conts};
    my $nss   = $s->data->{nss};
    my $doms  = $s->data->{doms};

    unless ( $s->data->{doms}{$dname} ) {
        return _fail_body( "The domain '$dname' does not exist", '2303', $cltrid );
    }

    my $dm = $s->data->{doms}{$dname};

    if ( $dm->{statuses}{serverUpdateProhibited} ) {
        return _fail_body( 'The domain name cannot be updated (serverUpdateProhibited).', '2304', $cltrid );
    }

    my $no_upd = $dm->{statuses}{clientUpdateProhibited} ? 1 : 0;

    if ( $body =~ m|(.+?)|s ) {
        my $u = $1;

        my @sts = $u =~ m|

        foreach my $st ( @sts ) {
            if ( $no_upd  &&  $st eq 'clientUpdateProhibited' ) {
                $no_upd = 0;
            }
        }
    }

    if ( $no_upd ) {
        return _fail_body( 'The domain name cannot be updated (clientUpdateProhibited).', '2304', $cltrid );
    }


    my %add;
    my %rem;
    my %chg;

    # For NSS Registry at first adds everything, then deletes -- it is already checked
    if ( $body =~ m|(.+?)|s ) {
        my $add = $1;

        # CentralNIC not save the status reason
        my @sts = $add =~ /

        foreach my $st ( @sts ) {
            unless ( $statuses{$st} ) {
                return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}status', attribute 's': [facet 'enumeration'] The value '$st' is not an element of the set {'clientDeleteProhibited', 'clientHold', 'clientRenewProhibited', 'clientTransferProhibited', 'clientUpdateProhibited', 'inactive', 'ok', 'pendingCreate', 'pendingDelete', 'pendingRenew', 'pendingTransfer', 'pendingUpdate', 'serverDeleteProhibited', 'serverHold', 'serverRenewProhibited', 'serverTransferProhibited', 'serverUpdateProhibited'}.", '2001', $cltrid );
            }

            if ( $dm->{statuses}{$st} ) {
                return _fail_body( "$st is already set on this domain.", '2004', $cltrid );
            }

            push @{$add{statuses}}, $st;
        }

        foreach my $t ( 'admin', 'tech', 'billing' ) {
            if ( $add =~ m|([^<>]+)| ) {
                $add{$t} = $1;

                unless ( $conts->{$add{$t}} ) {
                    return _fail_body( "Cannot add $t contact $add{$t} contact not found.", '2303', $cltrid );
                }
            }
        }

        if ( $add =~ m|(.+?)|s ) {
            my $ns = $1;

            my @hosts = $ns =~ m|([^<>]+)|g;

            $add{nss} = {};

            foreach my $h ( @hosts ) {
                if ( $nss->{$h} ) {
                    $add{nss}{$h} = '+';
                }
                else {
                    return _fail_body( "Cannot find host object '$h'", '2303', $cltrid );
                }
            }
        }
    }

    if ( $body =~ m|(.+?)|s ) {
        my $rem = $1;

        my @sts = $rem =~ m|

        foreach my $st ( @sts ) {
            unless ( $statuses{$st} ) {
                return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}status', attribute 's': [facet 'enumeration'] The value '$st' is not an element of the set {'clientDeleteProhibited', 'clientHold', 'clientRenewProhibited', 'clientTransferProhibited', 'clientUpdateProhibited', 'inactive', 'ok', 'pendingCreate', 'pendingDelete', 'pendingRenew', 'pendingTransfer', 'pendingUpdate', 'serverDeleteProhibited', 'serverHold', 'serverRenewProhibited', 'serverTransferProhibited', 'serverUpdateProhibited'}.", '2001', $cltrid );
            }

            unless ( $dm->{statuses}{$st} ) {
                return _fail_body( "$st is not set on this domain.", '2004', $cltrid );
            }

            push @{$rem{statuses}}, $st;
        }

        foreach my $t ( 'admin', 'tech', 'billing' ) {
            if ( $rem =~ m|([^<>]+)| ) {
                $rem{$t} = $1;

                unless ( $conts->{$rem{$t}} ) {
                    return _fail_body( "Cannot remove $t contact $rem{$t}: contact not found.", '2303', $cltrid );
                }

                unless ( $dm->{$t}{$rem{$t}} ) {
                    return _fail_body( "Invalid contact association type '$t'", '2004', $cltrid );
                }
            }
        }

        if ( $rem =~ m|(.+?)|s ) {
            my $ns = $1;

            my @hosts = $ns =~ m|([^<>]+)|g;

            $rem{nss} = {};

            foreach my $h ( @hosts ) {
                if ( $add{nss}{$h} ) {
                    delete $add{nss}{$h};
                    next;
                }

                if ( $dm->{nss}{$h} ) {
                    $rem{nss}{$h} = '+';
                }
                else {
                    return _fail_body( "The host $h is not linked to this domain name.", '2303', $cltrid );
                }
            }
        }
    }

    foreach my $t ( 'admin', 'tech', 'billing' ) {
        if ( $add{$t}  and  not $rem{$t} ) {
            return _fail_body( "Cannot assign a new $t contact without removing current tech contact.", '2004', $cltrid );
        }

        if ( not $add{$t}  and  $rem{$t} ) {
            return _fail_body( "Invalid contact association type '$t'", '2004', $cltrid );
        }
    }

    if ( $body =~ m|(.+?)|s ) {
        my $chg = $1;

        if ( $chg =~ m|([^<>]+)| ) {
            $chg{registrant} = $1;

            unless ( $conts->{$chg{registrant}} ) {
                return _fail_body( "Contact $chg{registrant} does not exist, cannot change registrant.", '2303', $cltrid );
            }
        }

        if ( $chg =~ m|authInfo.+([^<>]*).+authInfo|s ) {
            my $pw = $1;

            if ( $pw  and  length( $pw ) < 16 ) {
                return _fail_body( 'authInfo code is invalid: password must be at least 16 characters', '2004', $cltrid );
            }

            unless ( $pw  and  $pw =~ /[A-Z]/  and  $pw =~ /[a-z]/  and  $pw =~ /[0-9]/  and  $pw =~ /[!\@\$\%*_.:\-=+?#,"'\\\/&]/ ) {
                return _fail_body( 'authInfo code is invalid: password must contain a mix of uppercase and lowercase characters', '2004', $cltrid );
            }

            $chg{authInfo} = $pw;
        }
    }

    # at first there is adding!!!
    if ( scalar( keys %add ) ) {
        if ( $add{statuses} ) {
            foreach my $st ( @{$add{statuses}} ) {
                $dm->{statuses}{$st} = '+';
            }
        }

        foreach my $t ( 'admin', 'tech', 'billing' ) {
            if ( $add{$t} ) {
                $dm->{$t}{$add{$t}} = '+';

                $conts->{$add{$t}}{statuses}{linked}++;

                if ( $conts->{$add{$t}}{statuses}{ok} ) {
                    delete $conts->{$add{$t}}{statuses}{ok};
                    $conts->{$add{$t}}{statuses}{serverDeleteProhibited} = '+';
                }
            }
        }

        if ( $add{nss} ) {
            foreach my $ns ( keys %{$add{nss}} ) {
                $dm->{nss}{$ns} = '+';

                $nss->{$ns}{statuses}{linked}++;

                if ( $nss->{$ns}{statuses}{ok} ) {
                    delete $nss->{$ns}{statuses}{ok};
                    $nss->{$ns}{statuses}{serverDeleteProhibited} = '+';
                }
            }
        }
    }

    if ( scalar( keys %rem ) ) {
        if ( $rem{statuses} ) {
            foreach my $st ( @{$rem{statuses}} ) {
                delete $dm->{statuses}->{$st};
            }
        }

        foreach my $t ( 'admin', 'tech', 'billing' ) {
            if ( $rem{$t} ) {
                delete $dm->{$t}{$rem{$t}};

                $conts->{$rem{$t}}{statuses}{linked}--;

                if ( $conts->{$rem{$t}}{statuses}{linked} <= 0 ) {
                    delete $conts->{$rem{$t}}{statuses}{linked};

                    $conts->{$rem{$t}}{statuses}{ok} = '+';
                    delete $conts->{$rem{$t}}{statuses}{serverDeleteProhibited};
                }
            }
        }

        if ( $rem{nss} ) {
            foreach my $ns ( keys %{$rem{nss}} ) {
                delete $dm->{nss}->{$ns};

                $nss->{$ns}{statuses}{linked}--;

                if ( $nss->{$ns}{statuses}{linked} <= 0 ) {
                    delete $nss->{$ns}{statuses}{linked};

                    $nss->{$ns}{statuses}{ok} = '+';
                    delete $nss->{$ns}{statuses}{serverDeleteProhibited};
                }
            }
        }
    }

    if ( $chg{registrant} ) {
        $conts->{$dm->{registrant}}{statuses}{linked}--;

        if ( $conts->{$dm->{registrant}}{statuses}{linked} <= 0 ) {
            delete $conts->{$dm->{registrant}}{statuses}{linked};

            $conts->{$dm->{registrant}}{statuses}{ok} = '+';
            delete $conts->{$dm->{registrant}}{statuses}{serverDeleteProhibited};
        }

        $dm->{registrant} = $chg{registrant};

        $conts->{$chg{registrant}}{statuses}{linked}++;

        if ( $conts->{$chg{registrant}}{statuses}{ok} ) {
            delete $conts->{$chg{registrant}}{statuses}{ok};
            $conts->{$chg{registrant}}{statuses}{serverDeleteProhibited} = '+';
        }
    }

    $dm->{authInfo} = $chg{authInfo} if $chg{authInfo};

    my $svtrid = get_svtrid();

    return _min_answ( '1000', $cltrid );
}


sub domain_delete {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: domain:delete', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /domain:delete', '2001', $cltrid );
    }

    my $dname;
    if ( $body =~ m|([^<>]+)| ) {
        $dname = lc $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}name': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.', '2001', $cltrid );
    }

    if ( $dname =~ /([^0-9a-z\.\-])/ ) {
        return _fail_body( "'$dname' is not a valid domain name: the following characters are not permitted: '$1'", '2004', $cltrid );
    }

    if ( $dname !~ /^[0-9a-z\.\-]+\.[0-9a-z\-]+$/ ) {
        return _fail_body( "'$dname' is not a valid domain name: suffix ... does not exist", '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $conts = $s->data->{conts};
    my $nss   = $s->data->{nss};
    my $doms  = $s->data->{doms};

    unless ( $doms->{$dname} ) {
        return _fail_body( "The domain '$dname' does not exist", '2303', $cltrid );
    }

    my $dm = $doms->{$dname};

    unless ( $dm->{reason} eq 'in use' ) {
        return _fail_body( "The domain '$dname' does not exist", '2303', $cltrid );
    }

    foreach my $st ( 'clientDeleteProhibited', 'serverDeleteProhibited', 'clientUpdateProhibited', 'serverUpdateProhibited' ) {
        if ( $dm->{statuses}{$st} ) {
            return _fail_body( "The domain name cannot be $statuses{$st} ($st).", '2304', $cltrid );
        }
    }

    if ( $dm->{hosts} ) {
        foreach my $h ( keys %{$dm->{hosts}} ) {
            if ( $nss->{$h}{statuses}{linked} ) {
                return _fail_body( "Domain host $h is linked to one or more domains.", '2305', $cltrid );
            }
        }
    }

    if ( $dm->{hosts} ) {
        foreach my $h ( keys %{$dm->{hosts}} ) {
            delete $nss->{$h};
        }
    }

    $conts->{$dm->{registrant}}{statuses}{linked}--;

    if ( $conts->{$dm->{registrant}}{statuses}{linked} <= 0 ) {
        delete $conts->{$dm->{registrant}}{statuses}{linked};
        delete $conts->{$dm->{registrant}}{statuses}{serverDeleteProhibited};
        $conts->{$dm->{registrant}}{statuses}{ok} = '+';
    }

    foreach my $t ( 'admin', 'tech', 'billing' ) {
        foreach my $c ( keys %{$dm->{$t}} ) {
            $conts->{$c}{statuses}{linked}--;

            if ( $conts->{$c}{statuses}{linked} <= 0 ) {
                delete $conts->{$c}{statuses}{linked};
                delete $conts->{$c}{statuses}{serverDeleteProhibited};
                $conts->{$c}{statuses}{ok} = '+';
            }
        }
    }

    foreach my $ns ( keys %{$dm->{nss}} ) {
        $nss->{$ns}{statuses}{linked}--;

        if ( $nss->{$ns}{statuses}{linked} <= 0 ) {
            delete $nss->{$ns}{statuses}{linked};
            delete $nss->{$ns}{statuses}{serverDeleteProhibited};
            $nss->{$ns}{statuses}{ok} = '+';
        }
    }

    undef $dm;
    delete $doms->{$dname};

    return _min_answ( '1000', $cltrid );
}


sub domain_transfer {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    unless ( $body =~ s|^<\?xml version="1.0" encoding="UTF-8"\?>\s+||s ) {
        return _fail_body( 'XML schema validation failed: ', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+||s ) {
        return _fail_body( 'XML schema validation failed: Element '{uurn:ietf:params:xml:ns:epp-1.0}epp': No matching global declaration available for the validation root.', '2001', $cltrid );
    }

    my $op;
    if ( $body =~ // ) {
        $op = $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:epp-1.0}transfer', attribute 'op': [facet 'enumeration'] The value 'xxxx' is not an element of the set {'approve', 'cancel', 'query', 'reject', 'request'}.', '2001', $cltrid );
    }

    unless ( $body =~ s|^\s+\s+]+>\s+||s ) {
        return _fail_body( 'XML schema validation failed: domain:transfer', '2001', $cltrid );
    }

    unless ( $body =~ s|\s+\s+\s+[^<>]+\s+\s+\s*$||s ) {
        return _fail_body( 'XML schema validation failed: /domain:transfer', '2001', $cltrid );
    }

    my $dname;
    if ( $body =~ m|([^<>]+)| ) {
        $dname = lc $1;
    }
    else {
        return _fail_body( 'XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}name': [facet 'minLength'] The value has a length of '0'; this underruns the allowed minimum length of '1'.', '2001', $cltrid );
    }

    if ( $dname =~ /([^0-9a-z\.\-])/ ) {
        return _fail_body( "'$dname' is not a valid domain name: the following characters are not permitted: '$1'", '2004', $cltrid );
    }

    if ( $dname !~ /^[0-9a-z\.\-]+\.[0-9a-z\-]+$/ ) {
        return _fail_body( "'$dname' is not a valid domain name: suffix ... does not exist", '2004', $cltrid );
    }

    my $srv_url = $obj->{sock};
    my $s = new IO::EPP::Test::Server( $srv_url );
    my $doms  = $s->data->{doms};

    unless ( $doms->{$dname} ) {
        return _fail_body( "The domain '$dname' cannot be found.", '2303', $cltrid );
    }

    my $dm = $doms->{$dname};

    if ( $op eq 'cancel'  or  $op eq 'reject'  or  $op eq 'approve' ) {
        unless ( $dm->{statuses}{pendingTransfer} ) {
            return _fail_body( 'There are no pending transfer requests for this object.', '2301', $cltrid );
        }
    }

    if ( $op eq 'query' ) {
        unless ( $dm->{statuses}{pendingTransfer} ) {
            return _fail_body( 'You cannot view the details of this transfer.', '2201', $cltrid );
        }

        unless ( $dm->{owner} eq $obj->{user}  or  $dm->{transfer}{new_owner} eq $obj->{user} ) {
            return _fail_body( 'You cannot view the details of this transfer.', '2201', $cltrid );
        }

        my $from = $dm->{owner};
        my $to = $dm->{transfer}{new_owner};

        my $exp_date = $dm->{exp_date};
        my $period = $dm->{transfer}{period};
        $exp_date =~ s/^(\d+)/$1+$period/e;

        my $tr_dt = $dm->{transfer}{tr_date};
        my $q_dt  = $dm->{transfer}{q_date};


        return _ok_answ( qq|flowerlab.onlinepending$to$q_dt$from$tr_dt$exp_date|, $cltrid );
    }

    if ( $op eq 'request' ) {
        if ( $dm->{owner} eq $obj->{user} ) {
            return _fail_body( 'You are already the sponsor for this domain', '2304', $cltrid );
        }

        foreach my $st ( 'clientTransferProhibited', 'clientUpdateProhibited', 'serverTransferProhibited', 'serverUpdateProhibited' ) {
            if ( $dm->{statuses}{$st} ) {
                return _fail_body( "The domain name cannot be $statuses{$st} ($st).", '2304', $cltrid );
            }
        }
    }

    if ( $op eq 'cancel' ) {
        if ( $dm->{transfer}{new_owner} eq $obj->{user} ) {
            delete $dm->{transfer};
            delete $dm->{statuses}{pendingTransfer};

            return _min_answ( '1000', $cltrid );
        }

        return _fail_body( 'You cannot cancel this transfer.', '2201', $cltrid );
    }

    if ( $op eq 'reject' ) {
        if ( $dm->{owner} eq $obj->{user} ) {
            delete $dm->{transfer};
            delete $dm->{statuses}{pendingTransfer};

            return _min_answ( '1000', $cltrid );
        }

        return _fail_body( 'You cannot reject this transfer.', '2201', $cltrid );
    }

    if ( $op eq 'approve' ) {
        if ( $dm->{owner} eq $obj->{user} ) {
            $dm->{owner} = $dm->{transfer}{new_owner};
            my $p = $dm->{transfer}{period};
            $dm->{exp_date} =~ s/^(\d+)/$1+$p/e;

            delete $dm->{transfer};
            delete $dm->{statuses}{pendingTransfer};

            return _min_answ( '1000', $cltrid );
        }

        return _fail_body( 'You cannot approve this transfer.', '2201', $cltrid );
    }

    my $period = 1;
    if ( $body =~ m|(\d+)| ) {
        $period = $1;

        if ( $period > 9 ) {
            return _fail_body( "XML schema validation failed: Element '{urn:ietf:params:xml:ns:domain-1.0}period': [facet 'maxInclusive'] The value '$period' is greater than the maximum value allowed ('9').", '2001', $cltrid );
        }
    }

    if ( $body =~ m|authInfo.+([^<>]+).+authInfo|s ) {
        my $pw = $1;

        if ( $pw ne $dm->{authInfo} ) {
            return _fail_body( 'Invalid authorisation code.', '2202', $cltrid );
        }
    }

    my $from = $dm->{owner};
    my $to = $obj->{user};

    my $exp_date = $dm->{exp_date};
    $exp_date =~ s/^(\d+)/$1+$period/e;
    my ( $q_dt ) = get_dates();
    my $tr_dt = $q_dt;
    $tr_dt =~ s/^(\d+)/$1+1/e;

    $dm->{transfer} = {
        period => $period,
        new_owner => $obj->{user},
        q_date => $q_dt,
        tr_date => $tr_dt,
    };

    $dm->{statuses}{pendingTransfer} = '+';

    my $svtrid = get_svtrid();

    return qq|Command completed OK; action pending$dnamepending$to$q_dt$from$tr_dt$exp_date$cltrid$svtrid|;
}


sub poll {
    my ( $obj, $body ) = @_;

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    return _fail_cltrid() unless $cltrid;

    my $svtrid = get_svtrid();

    return qq|



There are no messages for you!


$cltrid
$svtrid


|;
}


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

    unless ( $body =~ s|^<\?xml[^<>]+\?>\s+]+>||s ) {
        _fail_body( 'XML schema validation failed: ', '2001' );
    }

    unless ( $body =~ m|(.+?)|s ) {
        die "closed connection\n";
    }

    my $svtrid = get_svtrid();

    my ( $cltrid ) = $body =~ m|([0-9A-Za-z\-]+)|s;

    if ( $cltrid ) {
        return _min_answ( '1500', $cltrid );
    }

    return _fail_cltrid();
}

1;