File Coverage

blib/lib/Net/DRI/Protocol/IRIS/Message.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, IRIS Message
2             ##
3             ## Copyright (c) 2008-2010,2013 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             ####################################################################################################
14              
15             package Net::DRI::Protocol::IRIS::Message;
16              
17 1     1   4 use utf8;
  1         1  
  1         5  
18 1     1   22 use strict;
  1         2  
  1         12  
19 1     1   3 use warnings;
  1         1  
  1         21  
20              
21 1     1   162 use XML::LibXML ();
  0            
  0            
22              
23             use Net::DRI::Protocol::ResultStatus;
24             use Net::DRI::Exception;
25             use Net::DRI::Util;
26              
27             use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message);
28             __PACKAGE__->mk_accessors(qw/version tid authority options search results/);
29              
30             =pod
31              
32             =head1 NAME
33              
34             Net::DRI::Protocol::IRIS::Message - IRIS Message for Net::DRI
35              
36             =head1 DESCRIPTION
37              
38             Please see the README file for details.
39              
40             =head1 SUPPORT
41              
42             For now, support questions should be sent to:
43              
44             Enetdri@dotandco.comE
45              
46             Please also see the SUPPORT file in the distribution.
47              
48             =head1 SEE ALSO
49              
50             Ehttp://www.dotandco.com/services/software/Net-DRI/E
51              
52             =head1 AUTHOR
53              
54             Patrick Mevzek, Enetdri@dotandco.comE
55              
56             =head1 COPYRIGHT
57              
58             Copyright (c) 2008-2010,2013 Patrick Mevzek .
59             All rights reserved.
60              
61             This program is free software; you can redistribute it and/or modify
62             it under the terms of the GNU General Public License as published by
63             the Free Software Foundation; either version 2 of the License, or
64             (at your option) any later version.
65              
66             See the LICENSE file that comes with this distribution for more details.
67              
68             =cut
69              
70             ####################################################################################################
71              
72             sub new
73             {
74             my $class=shift;
75             my $trid=shift;
76              
77             my $self={ ns => {}, options => {} };
78             bless($self,$class);
79              
80             $self->tid($trid) if defined $trid && length $trid;
81             return $self;
82             }
83              
84             sub ns
85             {
86             my ($self,$what)=@_;
87             return $self->{ns} unless defined $what;
88              
89             if (ref $what eq 'HASH')
90             {
91             $self->{ns}=$what;
92             return $what;
93             }
94             return unless exists $self->{ns}->{$what};
95             return $self->{ns}->{$what}->[0];
96             }
97              
98             sub nsattrs
99             {
100             my ($self,$what)=@_;
101             return unless defined $what && exists $self->{ns}->{$what};
102             my @n=@{$self->{ns}->{$what}};
103             return ($n[0],$n[0],$n[1]);
104             }
105              
106             sub is_success { return 1; } ## TODO
107              
108             sub result_status { return Net::DRI::Protocol::ResultStatus->new_success(); }; ## There is no message-level result_status, only at resultSet level, hence global success
109              
110             sub as_string
111             {
112             my ($self)=@_;
113              
114             ## TODO : handle other top nodes, see RFC4991, + control node in
115             Net::DRI::Exception::err_assert('Net::DRI::Protocol::IRIS::Message can only handle operations for now') unless defined $self->search();
116             my @d;
117             push @d,'';
118             push @d,sprintf('',$self->nsattrs('iris1'));
119              
120             foreach my $search (@{$self->search()}) ## $search is a refhash comme il faut
121             {
122             push @d,'';
123             ## We do not handle bags for now
124             ## Only lookupEntity is supported for now
125             push @d,Net::DRI::Util::xml_write(['lookupEntity',$search]);
126             push @d,'';
127             }
128              
129             push @d,'';
130             return join('',@d);
131             }
132              
133             # RFC3981 §4.2
134             sub parse
135             {
136             my ($self,$dc,$rinfo)=@_;
137              
138             my $parser=XML::LibXML->new();
139             my $doc=$parser->parse_string($dc->as_string());
140             my $root=$doc->getDocumentElement();
141             ## TODO: handle RFC4991 other types of responses
142             Net::DRI::Exception->die(0,'protocol/IRIS',1,'Unsuccessfull parse, root element is not response') unless ($root->localname() eq 'response');
143              
144             ## We currently do not parse the node (in reply to a which we do never send for now, see §4.3.8) and (see §4.4)
145             ## We take care only of the nodes
146             $self->results(scalar($root->getChildrenByTagNameNS($self->ns('iris1'),'resultSet')));
147             return;
148             }
149              
150             ####################################################################################################
151             1;