File Coverage

blib/lib/Zonemaster/Engine/Util.pm
Criterion Covered Total %
statement 75 77 97.4
branch 13 14 92.8
condition 8 8 100.0
subroutine 16 17 94.1
pod 7 7 100.0
total 119 123 96.7


line stmt bran cond sub pod time code
1             package Zonemaster::Engine::Util;
2              
3 26     26   43563 use version; our $VERSION = version->declare("v1.1.3");
  26         1369  
  26         159  
4              
5 26     26   2521 use 5.014002;
  26         89  
6              
7 26     26   421 use parent 'Exporter';
  26         252  
  26         187  
8              
9 26     26   1452 use strict;
  26         57  
  26         554  
10 26     26   115 use warnings;
  26         90  
  26         712  
11              
12 26     26   380 use Zonemaster::Engine;
  26         64  
  26         522  
13 26     26   127 use Zonemaster::Engine::DNSName;
  26         50  
  26         483  
14 26     26   7700 use Pod::Simple::SimpleTree;
  26         615804  
  26         22860  
15              
16             ## no critic (Modules::ProhibitAutomaticExportation)
17             our @EXPORT = qw[ ns info name pod_extract_for scramble_case ];
18             our @EXPORT_OK = qw[ ns info name pod_extract_for policy scramble_case ];
19             our %EXPORT_TAGS = ( all => \@EXPORT_OK );
20              
21             ## no critic (Subroutines::RequireArgUnpacking)
22             sub ns {
23 326738     326738 1 1504599 return Zonemaster::Engine->ns( @_ );
24             }
25              
26             sub info {
27 20383     20383 1 72935 my ( $tag, $argref ) = @_;
28              
29 20383         83678 return Zonemaster::Engine->logger->add( $tag, $argref );
30             }
31              
32             sub policy {
33 10     10 1 29 return Zonemaster::Engine->config->policy;
34             }
35              
36             sub name {
37 757553     757553 1 4484507 my ( $name ) = @_;
38              
39 757553         19990378 return Zonemaster::Engine::DNSName->new( $name );
40             }
41              
42             # Functions for extracting POD documentation from test modules
43              
44             sub _pod_process_tree {
45 20     20   34407 my ( $node, $flags ) = @_;
46 20         24 my ( $name, $ahash, @subnodes ) = @{$node};
  20         32  
47 20         23 my @res;
48              
49 20   100     35 $flags //= {};
50              
51 20         25 foreach my $node ( @subnodes ) {
52 57 100       87 if ( ref( $node ) ne 'ARRAY' ) {
53 17 100 100     35 $flags->{tests} = 1 if $name eq 'head1' and $node eq 'TESTS';
54 17 100 100     38 if ( $name eq 'item-text' and $flags->{tests} ) {
55 1         7 $node =~ s/\A(\w+).*\z/$1/x;
56 1         3 $flags->{item} = $node;
57 1         3 push @res, $node;
58             }
59             }
60             else {
61 40 100       50 if ( $flags->{item} ) {
62 21         31 push @res, _pod_extract_text( $node );
63             }
64             else {
65 19         34 push @res, _pod_process_tree( $node, $flags );
66             }
67             }
68             }
69              
70 20         49 return @res;
71             } ## end sub _pod_process_tree
72              
73             sub _pod_extract_text {
74 21     21   28 my ( $node ) = @_;
75 21         25 my ( $name, $ahash, @subnodes ) = @{$node};
  21         35  
76 21         26 my $res = q{};
77              
78 21         27 foreach my $node ( @subnodes ) {
79 21 100       35 if ( $name eq q{item-text} ) {
80 10         28 $node =~ s/\A(\w+).*\z/$1/x;
81             }
82              
83 21 50       29 if ( ref( $node ) eq q{ARRAY} ) {
84 0         0 $res .= _pod_extract_text( $node );
85             }
86             else {
87 21         39 $res .= $node;
88             }
89             }
90              
91 21         40 return $res;
92             } ## end sub _pod_extract_text
93              
94             sub pod_extract_for {
95 1     1 1 3 my ( $name ) = @_;
96              
97 1         19 my $parser = Pod::Simple::SimpleTree->new;
98 1         30 $parser->no_whining( 1 );
99              
100 1         13 my %desc = eval { _pod_process_tree( $parser->parse_file( $INC{"Zonemaster/Engine/Test/$name.pm"} )->root ) };
  1         11  
101              
102 1         27 return \%desc;
103             }
104              
105             # Function from CPAN package Text::Capitalize that causes
106             # issues when installing ZM.
107             #
108             sub scramble_case {
109 1     1 1 4 my $string = shift;
110 1         3 my ( @chars, $uppity, $newstring, $uppers, $downers );
111              
112 1         10 @chars = split //, $string;
113              
114 1         4 $uppers = 2;
115 1         3 $downers = 1;
116 1         6 foreach my $c ( @chars ) {
117 10         21 $uppity = int( rand( 1 + $downers / $uppers ) );
118              
119 10 100       17 if ( $uppity ) {
120 4         7 $c = uc( $c );
121 4         5 $uppers++;
122             }
123             else {
124 6         10 $c = lc( $c );
125 6         11 $downers++;
126             }
127             }
128 1         5 $newstring = join q{}, @chars;
129 1         6 return $newstring;
130             } # end sub scramble_case
131              
132             sub supports_ipv6 {
133 0     0 1   return;
134             }
135              
136             1;
137              
138             =head1 NAME
139              
140             Zonemaster::Engine::Util - utility functions for other Zonemaster modules
141              
142             =head1 SYNOPSIS
143              
144             use Zonemaster::Engine::Util;
145             info(TAG => { some => 'argument'});
146             my $ns = ns($name, $address);
147             my $name = name('whatever.example.org');
148              
149             =head1 EXPORTED FUNCTIONS
150              
151             =over
152              
153             =item info($tag, $href)
154              
155             Creates and returns a L<Zonemaster::Engine::Logger::Entry> object. The object
156             is also added to the global logger object's list of entries.
157              
158             =item ns($name, $address)
159              
160             Creates and returns a nameserver object with the given name and address.
161              
162             =item policy()
163              
164             Returns a reference to the global policy hash.
165              
166             =item name($string_name_or_zone)
167              
168             Creates and returns a L<Zonemaster::Engine::DNSName> object for the given argument.
169              
170             =item pod_extract_for($testname)
171              
172             Will attempt to extract the POD documentation for the test methods in
173             the test module for which the name is given. If it can, it returns a
174             reference to a hash where the keys are the test method names and the
175             values the documentation strings.
176              
177             This method blindly assumes that the structure of the POD is exactly
178             like that in the Example and Basic test modules. If it's not, the
179             results are undefined.
180              
181             =item scramble_case
182              
183             This routine provides a special effect: sCraMBliNg tHe CaSe
184              
185             =item supports_ipv6
186              
187             Check if ZOnemaster hosting server supports IPv6.
188              
189             =back