File Coverage

blib/lib/Net/DRI/Protocol/RRI/Connection.pm
Criterion Covered Total %
statement 15 71 21.1
branch 0 20 0.0
condition 0 15 0.0
subroutine 5 14 35.7
pod 0 9 0.0
total 20 129 15.5


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, RRI Connection handling
2             ##
3             ## Copyright (c) 2007-2009,2013 Tonnerre Lombard . 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::RRI::Connection;
16              
17 1     1   1223 use strict;
  1         1  
  1         31  
18 1     1   8 use warnings;
  1         2  
  1         34  
19              
20 1     1   10 use Net::DRI::Util;
  1         2  
  1         26  
21 1     1   7 use Net::DRI::Data::Raw;
  1         2  
  1         15  
22 1     1   35 use Net::DRI::Protocol::ResultStatus;
  1         1  
  1         9  
23              
24             =pod
25              
26             =head1 NAME
27              
28             Net::DRI::Protocol::RRI::Connection - RRI Connection handling (DENIC-11) for Net::DRI
29              
30             =head1 DESCRIPTION
31              
32             Please see the README file for details.
33              
34             =head1 SUPPORT
35              
36             For now, support questions should be sent to:
37              
38             Etonnerre.lombard@sygroup.chE
39              
40             Please also see the SUPPORT file in the distribution.
41              
42             =head1 SEE ALSO
43              
44             Ehttp://oss.bsdprojects.net/projects/netdri/E
45              
46             =head1 AUTHOR
47              
48             Tonnerre Lombard, Etonnerre.lombard@sygroup.chE
49              
50             =head1 COPYRIGHT
51              
52             Copyright (c) 2007-2009,2013 Tonnerre Lombard .
53             All rights reserved.
54              
55             This program is free software; you can redistribute it and/or modify
56             it under the terms of the GNU General Public License as published by
57             the Free Software Foundation; either version 2 of the License, or
58             (at your option) any later version.
59              
60             See the LICENSE file that comes with this distribution for more details.
61              
62             =cut
63              
64             ####################################################################################################
65              
66             sub login
67             {
68 0     0 0   my ($class, $cm, $id, $pass, $cltrid, $dr, $newpass, $pdata) = @_;
69              
70 0           my $mes=$cm->();
71 0           $mes->command(['login']);
72 0           my @d;
73 0           push @d,['user',$id];
74 0           push @d,['password',$pass];
75 0           $mes->command_body(\@d);
76 0           return $mes;
77             }
78              
79             sub logout
80             {
81 0     0 0   my ($class,$cm,$cltrid)=@_;
82 0           my $mes=$cm->();
83 0           $mes->command(['logout']);
84 0 0         $mes->cltrid($cltrid) if $cltrid;
85 0           return $mes;
86             }
87              
88             sub keepalive
89             {
90 0     0 0   my ($class,$cm,$cltrid)=@_;
91 0           my $mes=$cm->();
92 0           $mes->command(['hello']);
93 0           return $mes;
94             }
95              
96             ####################################################################################################
97              
98             sub read_data
99             {
100 0     0 0   my ($class,$to,$sock)=@_;
101              
102 0           my $version = $to->{transport}->{protocol_version};
103 0           my $m='';
104 0           my $c;
105 0           my $rl=$sock->sysread($c, 4); ## first 4 bytes are the packed length
106 0 0 0       die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING',
107             'Unable to read RRI 4 bytes length (connection closed by registry ?): '.$!,
108             'en')) unless (defined $rl && $rl==4);
109 0           my $length = unpack('N', $c);
110 0           while ($length > 0)
111             {
112 0           my $new;
113 0           $length-=$sock->sysread($new,$length);
114 0           $m.=$new;
115             }
116              
117 0           $m=Net::DRI::Util::decode_utf8($m);
118 0 0         die(Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR',
    0          
119             $m ? $m : '', 'en'))
120             unless ($m =~ m!$!);
121              
122 0           return Net::DRI::Data::Raw->new_from_xmlstring($m);
123             }
124              
125             sub write_message
126             {
127 0     0 0   my ($self,$to,$msg)=@_;
128              
129 0           my $m=Net::DRI::Util::encode_utf8($msg->as_string());
130 0           my $l = pack('N', length($m)); ## DENIC-11
131 0           return $l.$m;
132             }
133              
134             sub parse_login
135             {
136 0     0 0   my ($class,$dc)=@_;
137 0           my ($result,$code,$msg)=find_result($dc);
138 0 0 0       unless (defined($result) && ($result eq 'success'))
139             {
140 0 0 0       return Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR',
141             (defined($msg) && length($msg) ? $msg : 'Login failed'), 'en');
142             } else
143             {
144 0           return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL',
145             'Login OK', 'en');
146             }
147             }
148              
149             sub parse_logout
150             {
151 0     0 0   my ($class,$dc)=@_;
152 0           my ($result,$code,$msg)=find_result($dc);
153 0 0 0       unless (defined($result) && ($result eq 'success'))
154             {
155 0 0 0       return Net::DRI::Protocol::ResultStatus->new_error('COMMAND_SYNTAX_ERROR',
156             (defined($msg) && length($msg) ? $msg : 'Logout failed'), 'en');
157             } else
158             {
159 0           return Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL',
160             'Logout OK', 'en');
161             }
162             }
163              
164             sub find_result
165             {
166 0     0 0   my $dc=shift;
167 0           my $a=$dc->as_string();
168 0 0         return () unless ($a=~m!!);
169 0           $a=~s/>[\n\s\t]+/>/g;
170 0           my ($result,$code,$msg);
171 0 0         return () unless (($result)=($a=~m!(\w+)!));
172 0           ($code) = ($a =~ m!!);
173 0           ($msg) = ($a =~ m!([^>]+)!);
174 0           return ($result, $code, $msg);
175             }
176              
177             sub transport_default
178             {
179 0     0 0   my ($self,$tname)=@_;
180 0           return ();
181             }
182              
183             ####################################################################################################
184             1;