Net::DRI::Protocol::OpenSRS::XCP::Message - OpenSRS XCP Message for Net::DRI
Index
Code Index:
NAME
Net::DRI::Protocol::OpenSRS::XCP::Message - OpenSRS XCP Message for Net::DRI
DESCRIPTION
Please see the README file for details.
SUPPORT
For now, support questions should be sent to:
<netdri@dotandco.com>
Please also see the SUPPORT file in the distribution.
SEE ALSO
<http://www.dotandco.com/services/software/Net-DRI/>
AUTHOR
Patrick Mevzek, <netdri@dotandco.com>
COPYRIGHT
Copyright (c) 2008,2009 Patrick Mevzek <netdri@dotandco.com>.
All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
See the LICENSE file that comes with this distribution for more details.
## Domain Registry Interface, OpenSRS XCP Message
##
## Copyright (c) 2008,2009 Patrick Mevzek <netdri@dotandco.com>. All rights reserved.
##
## This file is part of Net::DRI
##
## Net::DRI is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## See the LICENSE file that comes with this distribution for more details.
#
#
#
####################################################################################################
package Net::DRI::Protocol::OpenSRS::XCP::Message;
use strict;
use warnings;
use XML::LibXML ();
use Net::DRI::Protocol::ResultStatus;
use Net::DRI::Exception;
use Net::DRI::Util;
use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message);
__PACKAGE__->mk_accessors(qw(version client_auth command command_attributes response_attributes response_code response_text response_is_success));
our $VERSION=do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); };
####################################################################################################
sub new
{
my ($class,$trid)=@_;
my $self={ results => [], _body => '', command => {}};
bless($self,$class);
$self->version('0.9');
return $self;
}
our %CODES=( 200 => 1000,
210 => 2303,
211 => 2302,
221 => 2302,
250 => 1001,
300 => 1001,
310 => 2502,
350 => 2502, ## A maximum of 100 commands can be sent through one connection/session. After 100 commands have been submitted, the connection is closed and a new connection must be opened to submit outstanding requests.
400 => 2400,
404 => 2400,
405 => 2400,
410 => 2200,
415 => 2200,
430 => 2000,
435 => 2201,
436 => 2400,
437 => 2304,
440 => 2201,
445 => 2201,
447 => 2201,
460 => 2003,
465 => 2005,
480 => 2306,
485 => 2302,
486 => 2304,
487 => 2106,
541 => 2004,
552 => 2304,
555 => 2306,
557 => 2305,
705 => 2400,
);
sub result_status
{
my $self=shift;
return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL',$self->response_text()) if ($self->response_is_success());
my $code=$self->response_code();
my $eppcode=(!defined($code) || !exists($CODES{$code}))? 'GENERIC_ERROR' : $CODES{$code};
return Net::DRI::Protocol::ResultStatus->new('opensrs_xcp',$code,$eppcode,$self->response_is_success(),$self->response_text(),'en');
}
sub is_success { return shift->response_is_success(); }
sub as_string { return shift->get_body(); }
sub get_body
{
my ($self)=@_;
return $self->{_body} if length($self->{_body});
my @d;
push @d,q{<?xml version='1.0' encoding='UTF-8' standalone='no' ?>};
push @d,q{<!DOCTYPE OPS_envelope SYSTEM 'ops.dtd'>};
push @d,'<OPS_envelope>';
push @d,'<header><version>',$self->version(),'</version></header>';
push @d,'<body>';
push @d,'<data_block>';
push @d,'<dt_assoc>';
my $d=$self->command(); ## ref hash with at least action & object keys, maybe more (such as cookie)
$d->{protocol}='XCP';
foreach my $k (sort(keys(%$d)))
{
push @d,'<item key="',$k,'">',$d->{$k},'</item>';
}
push @d,'<item key="attributes">',_obj2dt($self->command_attributes()),'</item>' if defined($self->command_attributes());
push @d,'</dt_assoc>';
push @d,'</data_block>';
push @d,'</body>';
push @d,'</OPS_envelope>';
$self->{_body}=join('',@d);
return $self->{_body};
}
sub _obj2dt
{
my ($in)=@_;
my @r;
foreach my $el ($in)
{
my $ref=ref($el);
if (!$ref)
{
push @r,sprintf('<dt_scalar>%s</dt_scalar>',Net::DRI::Util::xml_escape($el));
} elsif ($ref eq 'HASH')
{
my @c;
foreach my $k (sort(keys(%$el)))
{
$k=~s/"/"/g;
my $v=$el->{$k};
if (!defined($v)) {
push @c,sprintf('<item key="%s" />',$k);
} else {
push @c,sprintf('<item key="%s">%s</item>',$k,ref($v)? _obj2dt($v) : Net::DRI::Util::xml_escape($v));
}
}
push @r,sprintf('<dt_assoc>%s</dt_assoc>',join('',@c));
} elsif ($ref eq 'ARRAY')
{
my @c;
foreach my $i (0..$#$el)
{
push @c,sprintf('<item key="%d">%s</item>',$i,ref($el->[$i])? _obj2dt($el->[$i]) : Net::DRI::Util::xml_escape($el->[$i]));
}
push @r,sprintf('<dt_array>%s</dt_array>',join('',@c));
} elsif ($ref eq 'SCALAR')
{
push @r,sprintf('<dt_scalarref>%s</dt_scalarref>',Net::DRI::Util::xml_escape($$el)); ## defined in specifications, but not really used ?
} else
{
Net::DRI::Exception::err_assert('_obj2dt cannot deal with data '.$el);
}
}
return @r;
}
sub _dt2obj
{
my ($doc)=@_;
my $c=$doc->getFirstChild();
return unless defined($c);
while (defined($c) && $c->nodeType()!=1) { $c=$c->getNextSibling(); }
return $doc->textContent() unless (defined($c) && $c->nodeType()==1);
my $n=$c->nodeName();
if ($n eq 'dt_scalar')
{
return $c->textContent();
} elsif ($n eq 'dt_assoc')
{
my %r;
foreach my $item ($c->getChildrenByTagName('item'))
{
$r{$item->getAttribute('key')}=_dt2obj($item);
}
return \%r;
} elsif ($n eq 'dt_array')
{
my @r;
foreach my $item ($c->getChildrenByTagName('item'))
{
$r[$item->getAttribute('key')]=_dt2obj($item);
}
return \@r;
}
Net::DRI::Exception::err_assert('_dt2obj ca not deal with node name '.$n);
}
sub parse
{
my ($self,$dr,$rinfo,$otype,$oaction,$msgsent)=@_;
$self->command($msgsent->command()); ## Copy over for reference from message sent
my $parser=XML::LibXML->new();
my $doc=$parser->parse_string($dr->as_string());
my $root=$doc->getDocumentElement();
Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, root element is not OPS_envelope but '.$root->getName()) unless ($root->getName() eq 'OPS_envelope');
my $db=$root->getElementsByTagName('data_block');
Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, expected only one data_block node below root, found '.$db->size()) unless ($db->size()==1);
$db=$db->get_node(1)->getChildrenByTagName('dt_assoc');
Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, expected one dt_assoc node directly below data_block, found '.$db->size()) unless ($db->size()==1);
foreach my $item ($db->get_node(1)->getChildrenByTagName('item'))
{
my $key=$item->getAttribute('key');
next if ($key eq 'protocol' || $key eq 'action' || $key eq 'object'); ## protocol is XCP, action is always REPLY, and we already have object in command()
if ($key eq 'attributes') ## specific data about requested action, should always be an hash based on documentation
{
$self->response_attributes(_dt2obj($item));
next;
}
if ($key eq 'response_code') ## meaning is action-specific
{
$self->response_code($item->textContent());
next;
}
if ($key eq 'response_text') ## meaning is action-specific
{
$self->response_text($item->textContent());
next;
}
if ($key eq 'is_success') ## 0 if not successful, 1 if action was successful
{
$self->response_is_success($item->textContent());
next;
}
}
}
####################################################################################################
1;