File Coverage

blib/lib/Net/DRI/Protocol/Whois/Message.pm
Criterion Covered Total %
statement 18 48 37.5
branch 0 10 0.0
condition 0 6 0.0
subroutine 6 11 54.5
pod 1 5 20.0
total 25 80 31.2


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Whois Message
2             ##
3             ## Copyright (c) 2007-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::Whois::Message;
16              
17 1     1   3 use strict;
  1         1  
  1         21  
18 1     1   3 use warnings;
  1         1  
  1         23  
19              
20 1     1   4 use Net::DRI::Protocol::ResultStatus;
  1         1  
  1         5  
21 1     1   19 use Net::DRI::Exception;
  1         2  
  1         13  
22 1     1   2 use Net::DRI::Util;
  1         1  
  1         19  
23              
24 1     1   3 use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message);
  1         2  
  1         399  
25             __PACKAGE__->mk_accessors(qw(version errcode errmsg errlang command cltrid response response_raw));
26              
27             =pod
28              
29             =head1 NAME
30              
31             Net::DRI::Protocol::Whois::Message - Whois Message for Net::DRI
32              
33             =head1 DESCRIPTION
34              
35             Please see the README file for details.
36              
37             =head1 SUPPORT
38              
39             For now, support questions should be sent to:
40              
41             Enetdri@dotandco.comE
42              
43             Please also see the SUPPORT file in the distribution.
44              
45             =head1 SEE ALSO
46              
47             Ehttp://www.dotandco.com/services/software/Net-DRI/E
48              
49             =head1 AUTHOR
50              
51             Patrick Mevzek, Enetdri@dotandco.comE
52              
53             =head1 COPYRIGHT
54              
55             Copyright (c) 2007-2010,2013 Patrick Mevzek .
56             All rights reserved.
57              
58             This program is free software; you can redistribute it and/or modify
59             it under the terms of the GNU General Public License as published by
60             the Free Software Foundation; either version 2 of the License, or
61             (at your option) any later version.
62              
63             See the LICENSE file that comes with this distribution for more details.
64              
65             =cut
66              
67             ####################################################################################################
68              
69             sub new
70             {
71 0     0 1   my ($class,$trid)=@_;
72 0           my $self={
73             errcode => -1000,
74             response => {},
75             };
76              
77 0           bless($self,$class);
78 0 0 0       $self->cltrid($trid) if (defined($trid) && $trid);
79 0           return $self;
80             }
81              
82 0 0   0 0   sub is_success { return (shift->errcode()==0)? 1 : 0; }
83              
84             sub result_status
85             {
86 0     0 0   my $self=shift;
87 0           my %C=( 0 => 1500, ## Command successful + connection closed
88             );
89 0           my $c=$self->errcode();
90 0 0         my $rs=Net::DRI::Protocol::ResultStatus->new('whois',$c,exists($C{$c})? $C{$c} : 'COMMAND_FAILED',$self->is_success(),$self->errmsg(),$self->errlang(),undef);
91 0           $rs->_set_trid([ $self->cltrid(),undef ]);
92 0           return $rs;
93             }
94              
95             sub as_string
96             {
97 0     0 0   my ($self)=@_;
98 0           my $s=sprintf("%s\x0d\x0a",$self->command());
99 0           return $s;
100             }
101              
102             sub parse
103             {
104 0     0 0   my ($self,$dc,$rinfo)=@_;
105 0           my @d=$dc->as_array();
106 0           my %info;
107 0           foreach my $l (grep { /:/ } @d)
  0            
108             {
109 0           my ($k,$v)=($l=~m/^\s*(\S[^:]*\S)\s*:\s*(\S.*\S)\s*$/);
110 0 0 0       next unless ($k && $v);
111 0 0         if (exists($info{$k}))
112             {
113 0           push @{$info{$k}},$v;
  0            
114             } else
115             {
116 0           $info{$k}=[$v];
117             }
118             }
119              
120 0           $self->errcode(0);
121 0           $self->response(\%info);
122 0           $self->response_raw(\@d);
123 0           return;
124             }
125              
126             ####################################################################################################
127             1;