File Coverage

blib/lib/Net/DRI/Protocol/IRIS/Core.pm
Criterion Covered Total %
statement 18 41 43.9
branch 0 10 0.0
condition 0 6 0.0
subroutine 6 9 66.6
pod 0 3 0.0
total 24 69 34.7


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, IRIS Core functions
2             ##
3             ## Copyright (c) 2008-2010 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::Core;
16              
17 1     1   1639 use utf8;
  1         2  
  1         4  
18 1     1   27 use strict;
  1         1  
  1         22  
19 1     1   3 use warnings;
  1         2  
  1         24  
20              
21 1     1   5 use Carp;
  1         2  
  1         67  
22 1     1   5 use Net::DRI::Protocol::ResultStatus;
  1         2  
  1         9  
23 1     1   20 use Net::DRI::Util;
  1         2  
  1         422  
24              
25             =pod
26              
27             =head1 NAME
28              
29             Net::DRI::Protocol::IRIS::Core - IRIS Core (RFC3981) functions for Net::DRI
30              
31             =head1 DESCRIPTION
32              
33             Please see the README file for details.
34              
35             =head1 SUPPORT
36              
37             For now, support questions should be sent to:
38              
39             Enetdri@dotandco.comE
40              
41             Please also see the SUPPORT file in the distribution.
42              
43             =head1 SEE ALSO
44              
45             Ehttp://www.dotandco.com/services/software/Net-DRI/E
46              
47             =head1 AUTHOR
48              
49             Patrick Mevzek, Enetdri@dotandco.comE
50              
51             =head1 COPYRIGHT
52              
53             Copyright (c) 2008-2010 Patrick Mevzek .
54             All rights reserved.
55              
56             This program is free software; you can redistribute it and/or modify
57             it under the terms of the GNU General Public License as published by
58             the Free Software Foundation; either version 2 of the License, or
59             (at your option) any later version.
60              
61             See the LICENSE file that comes with this distribution for more details.
62              
63             =cut
64              
65             ####################################################################################################
66              
67             our %ERRORS=(insufficientResources => 2400,
68             invalidName => 2005,
69             invalidSearch => 2306,
70             queryNotSupported => 2101,
71             limitExceeded => 2201,
72             nameNotFound => 2303,
73             permissionDenied => 2200,
74             bagUnrecognized => 2005,
75             bagUnacceptable => 2005,
76             bagRefused => 2306,
77             );
78              
79             sub parse_msglang
80             {
81 0     0 0   my ($c,$name)=@_;
82 0           my (@i,$msg,$lang);
83 0           foreach my $sn ($c->getChildrenByTagNameNS($c->namespaceURI(),$name))
84             {
85 0 0         if (! defined $msg) { ($lang,$msg)=($sn->getAttribute('language'),$sn->textContent()); }
  0            
86 0           push @i,sprintf('[%s] %s',$sn->getAttribute('language'),$sn->textContent());
87             }
88 0           return (\@i,$msg,$lang);
89             }
90              
91             sub parse_error
92             {
93 0     0 0   my ($node)=@_; ## $node should be a topmost to be able to catch all errors type
94              
95 0           foreach my $el (Net::DRI::Util::xml_list_children($node))
96             {
97 0           my ($name,$c)=@$el;
98 0 0 0       next if ($name eq 'answer' || $name eq 'additional');
99 0 0         carp('Got unknown error <'.$name.'>, please report') unless exists($ERRORS{$name});
100 0           my ($ri,$msg,$lang)=parse_msglang($c,'explanation');
101             ## We have only one error element at most, so break here if we found one
102 0 0         return Net::DRI::Protocol::ResultStatus->new('iris',$name,exists $ERRORS{$name} ? $ERRORS{$name} : 'COMMAND_FAILED',0,$msg,$lang,$ri);
103             }
104 0           return Net::DRI::Protocol::ResultStatus->new_success();
105             }
106              
107             ## RFC4991 §6 §7
108             sub parse_authentication
109             {
110 0     0 0   my ($node)=@_; ## $node should be a topmost to be able to catch all errors type
111 0           my ($ri,$msg,$lang);
112              
113 0           foreach my $el (Net::DRI::Util::xml_list_children($node))
114             {
115 0           my ($name,$c)=@$el;
116 0 0 0       next unless ($name eq 'authenticationSuccess' || $name eq 'authenticationFailure');
117 0           ($ri,$msg,$lang)=parse_msglang($c,'description');
118 0           last;
119             }
120              
121 0           return ($msg,$lang,$ri);
122             }
123              
124             ####################################################################################################
125             1;