File Coverage

blib/lib/Net/DNS/Check/Test.pm
Criterion Covered Total %
statement 15 64 23.4
branch 0 22 0.0
condition 0 15 0.0
subroutine 5 14 35.7
pod 0 6 0.0
total 20 121 16.5


line stmt bran cond sub pod time code
1             package Net::DNS::Check::Test;
2              
3 1     1   5 use strict;
  1         2  
  1         32  
4 1     1   5 use vars qw($VERSION);
  1         2  
  1         43  
5              
6 1     1   5 use Carp;
  1         6  
  1         49  
7 1     1   5 use Net::DNS::Check::Config;
  1         6  
  1         19  
8 1     1   526 use Net::DNS::Check::Test::unknown;
  1         2  
  1         586  
9              
10             # use vars qw( %_LOADED );
11              
12             my %PUBLIC_ARGS = map { $_ => 1 } qw(
13             config
14             domain
15             type
16             nsquery
17             nsauth
18             hostslist
19             debug
20             );
21              
22              
23             sub new {
24 0     0 0   my ($class) = shift;
25              
26 0 0         unless ( @_ ) {
27             # Some error
28 0           return;
29             }
30            
31 0           my (%args) = @_;
32              
33              
34 0           my $subclass = _get_subclass($class, $args{type} );
35            
36 0 0         if ($subclass) {
37 0           my $self = $subclass->new(@_);
38             # $self->{test_detail} = {};
39 0           return $self;
40             } else {
41 0           return new Net::DNS::Check::Test::unknown();
42             }
43             }
44              
45              
46             # Defined in subclass
47 0     0 0   sub test {
48              
49             }
50              
51              
52              
53             #
54             sub test_status {
55 0     0 0   my $self = shift;
56 0           return $self->{test_status};
57             }
58              
59              
60             #
61             sub test_detail {
62 0     0 0   my $self = shift;
63 0           my $key = shift;
64              
65 0 0         if ($key) {
66 0 0         if ( exists $self->{test_detail}->{$key} ) {
67 0           return %{ $self->{test_detail}->{$key} };
  0            
68             } else {
69 0           return ();
70             }
71             } else {
72 0           return %{ $self->{test_detail} };
  0            
73              
74             }
75             }
76              
77              
78             sub test_detail_desc {
79 0     0 0   my $self = shift;
80 0           my $key = shift;
81              
82 0 0 0       if ($key && exists $self->{test_detail}->{$key} ) {
83 0           return $self->{test_detail}->{$key}->{desc};
84             } else {
85 0           return;
86             }
87             }
88              
89             sub test_detail_status {
90 0     0 0   my $self = shift;
91 0           my $key = shift;
92              
93 0 0 0       if ($key && exists $self->{test_detail}->{$key} ) {
94 0           return $self->{test_detail}->{$key}->{status};
95             } else {
96 0           return;
97             }
98             }
99              
100              
101              
102              
103             sub _process_args {
104 0     0     my ($self, %args) = @_;
105              
106 0           foreach my $attr ( keys %args) {
107 0 0         next unless $PUBLIC_ARGS{$attr};
108            
109             # Controllare se effettivamente funziona questo test
110 0 0 0       if ($attr eq 'nsquery' || $attr eq 'nsauth') {
111 0 0         unless ( UNIVERSAL::isa($args{$attr}, 'ARRAY') ) {
112 0           die "Net::DNS::Check::Test->new(): $attr must be an arrayref\n";
113             }
114             }
115              
116 0           $self->{$attr} = $args{$attr};
117             }
118              
119 0   0       $self->{config} ||= new Net::DNS::Check::Config();
120              
121 0   0       $self->{debug} ||= $self->{config}->debug_default();
122             }
123              
124              
125             sub _get_subclass {
126 0     0     my ($class, $type) = @_;
127              
128 0 0         return unless $type;
129              
130 0           my $subclass = join('::', $class, $type);
131              
132             # probably this is useless because "require" function
133             # load files only once
134             #unless ($_LOADED{$subclass}) {
135 0           eval "require $subclass";
136 0 0         if ( $@ ) {
137 0           carp $@;
138 0           $subclass = '';
139             } #else {
140             # $_LOADED{$subclass}++;
141             #}
142             #}
143              
144 0           return $subclass;
145             }
146              
147              
148 0     0     sub DESTROY {}
149              
150             1;
151              
152             __END__