File Coverage

blib/lib/Test/Dpkg.pm
Criterion Covered Total %
statement 61 89 68.5
branch 12 34 35.2
condition 7 19 36.8
subroutine 21 25 84.0
pod 0 12 0.0
total 101 179 56.4


line stmt bran cond sub pod time code
1             # Copyright © 2015 Guillem Jover
2             #
3             # This program is free software; you can redistribute it and/or modify
4             # it under the terms of the GNU General Public License as published by
5             # the Free Software Foundation; either version 2 of the License, or
6             # (at your option) any later version.
7             #
8             # This program is distributed in the hope that it will be useful,
9             # but WITHOUT ANY WARRANTY; without even the implied warranty of
10             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11             # GNU General Public License for more details.
12             #
13             # You should have received a copy of the GNU General Public License
14             # along with this program. If not, see .
15              
16             package Test::Dpkg;
17              
18 37     37   2565392 use strict;
  37         423  
  37         1128  
19 37     37   198 use warnings;
  37         67  
  37         4246  
20              
21             our $VERSION = '0.00';
22             our @EXPORT_OK = qw(
23             all_po_files
24             all_perl_files
25             all_perl_modules
26             test_get_po_dirs
27             test_get_perl_dirs
28             test_get_data_path
29             test_get_temp_path
30             test_needs_author
31             test_needs_module
32             test_needs_command
33             test_needs_srcdir_switch
34             test_neutralize_checksums
35             );
36             our %EXPORT_TAGS = (
37             needs => [ qw(
38             test_needs_author
39             test_needs_module
40             test_needs_command
41             test_needs_srcdir_switch
42             ) ],
43             paths => [ qw(
44             all_po_files
45             all_perl_files
46             all_perl_modules
47             test_get_po_dirs
48             test_get_perl_dirs
49             test_get_data_path
50             test_get_temp_path
51             ) ],
52             );
53              
54 37     37   267 use Exporter qw(import);
  37         86  
  37         1504  
55 37     37   243 use File::Find;
  37         86  
  37         2778  
56 37     37   277 use File::Basename;
  37         92  
  37         4094  
57 37     37   311 use File::Path qw(make_path);
  37         77  
  37         2527  
58 37     37   27587 use IPC::Cmd qw(can_run);
  37         2335426  
  37         2466  
59 37     37   1122 use Test::More;
  37         66941  
  37         496  
60              
61             my $test_mode;
62              
63             BEGIN {
64 37   50 37   50349 $test_mode = $ENV{DPKG_TEST_MODE} // 'dpkg';
65             }
66              
67             sub _test_get_caller_dir
68             {
69 25     25   214 my (undef, $path, undef) = caller 1;
70              
71 25         165 $path =~ s{\.t$}{};
72 25         74 $path =~ s{^\./}{};
73              
74 25         113 return $path;
75             }
76              
77             sub test_get_data_path
78             {
79 16     16 0 5428 my $path = shift;
80              
81 16 100       77 if (defined $path) {
82 1 50       4 if ($test_mode eq 'cpan') {
83 1         4 return $path;
84             } else {
85 0   0     0 my $srcdir = $ENV{srcdir} || '.';
86 0         0 return "$srcdir/$path";
87             }
88             } else {
89 15         60 return _test_get_caller_dir();
90             }
91             }
92              
93             sub test_get_temp_path
94             {
95 10   33 10 0 3042 my $path = shift // _test_get_caller_dir();
96 10         388 $path = 't.tmp/' . fileparse($path);
97              
98 10         2648 make_path($path);
99 10         65 return $path;
100             }
101              
102             sub test_get_po_dirs
103             {
104 0 0   0 0 0 if ($test_mode eq 'cpan') {
105 0         0 return qw();
106             } else {
107 0         0 return qw(po scripts/po dselect/po man/po);
108             }
109             }
110              
111             sub test_get_perl_dirs
112             {
113 2 50   2 0 11 if ($test_mode eq 'cpan') {
114 2         298 return qw(t lib);
115             } else {
116 0         0 return qw(t src/t lib utils/t scripts dselect);
117             }
118             }
119              
120             sub all_po_files
121             {
122 0   0 0 0 0 my $filter = shift // qr/\.(?:po|pot)$/;
123 0         0 my @files;
124             my $scan_po_files = sub {
125 0 0   0   0 push @files, $File::Find::name if m/$filter/;
126 0         0 };
127              
128 0         0 find($scan_po_files, test_get_po_dirs());
129              
130 0         0 return @files;
131             }
132              
133             sub all_perl_files
134             {
135 2   66 2 0 20 my $filter = shift // qr/\.(?:PL|pl|pm|t)$/;
136 2         6 my @files;
137             my $scan_perl_files = sub {
138 498 100   498   12629 push @files, $File::Find::name if m/$filter/;
139 2         10 };
140              
141 2         9 find($scan_perl_files, test_get_perl_dirs());
142              
143 2         46 return @files;
144             }
145              
146             sub all_perl_modules
147             {
148 1     1 0 9 return all_perl_files(qr/\.pm$/);
149             }
150              
151             sub test_needs_author
152             {
153 9 50 33 9 0 942 if (not $ENV{DPKG_DEVEL_MODE} and not $ENV{AUTHOR_TESTING}) {
154 9         50 plan skip_all => 'developer test';
155             }
156             }
157              
158             sub test_needs_module
159             {
160 2     2 0 182 my ($module, @imports) = @_;
161 2         9 my ($package) = caller;
162              
163 2         13 require version;
164 2         5 my $version = '';
165 2 100 66     13 if (@imports >= 1 and version::is_lax($imports[0])) {
166 1         89 $version = shift @imports;
167             }
168              
169             eval qq{
170             package $package;
171             use $module $version \@imports;
172             1;
173 2 50   2   172 } or do {
  2         560  
  0            
  0            
174 2         29 plan skip_all => "requires module $module $version";
175             }
176             }
177              
178             sub test_needs_command
179             {
180 3     3 0 287 my $command = shift;
181              
182 3 50       21 if (not can_run($command)) {
183 0         0 plan skip_all => "requires command $command";
184             }
185             }
186              
187             sub test_needs_srcdir_switch
188             {
189 4 50   4 0 258 if (defined $ENV{srcdir}) {
190 0 0       0 chdir $ENV{srcdir} or BAIL_OUT("cannot chdir to source directory: $!");
191             }
192             }
193              
194             sub test_neutralize_checksums
195             {
196 0     0 0 0 my $filename = shift;
197 0         0 my $filenamenew = "$filename.new";
198              
199 0 0       0 open my $fhnew, '>', $filenamenew or die;
200 0 0       0 open my $fh, '<', $filename or die;
201 0         0 while (<$fh>) {
202 0         0 s/^ ([0-9a-f]{32,}) [1-9][0-9]* /q{ } . $1 =~ tr{0-9a-f}{0}r . q{ 0 }/e;
  0         0  
203 0         0 print { $fhnew } $_;
  0         0  
204             }
205 0 0       0 close $fh or die;
206 0 0       0 close $fhnew or die;
207              
208 0 0       0 rename $filenamenew, $filename or die;
209             }
210              
211             1;