File Coverage

File:Test/Dpkg.pm
Coverage:54.5%

linestmtbrancondsubpodtimecode
1# Copyright © 2015 Guillem Jover <guillem@debian.org>
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 <https://www.gnu.org/licenses/>.
15
16package Test::Dpkg;
17
18
93
93
93
93
210
84
1079
use strict;
19
93
93
93
93
113
37
4337
use warnings;
20
21our $VERSION = '0.00';
22our @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);
36our %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
93
93
93
93
186
29
1125
use Exporter qw(import);
55
93
93
93
93
185
35
2307
use Cwd;
56
93
93
93
93
324
37
1729
use File::Find;
57
93
93
93
93
141
68
3060
use File::Basename;
58
93
93
93
93
171
35
2239
use File::Path qw(make_path rmtree);
59
93
93
93
93
21476
1848721
2378
use IPC::Cmd qw(can_run);
60
93
93
93
93
445
32674
424
use Test::More;
61
62my $test_mode;
63
64BEGIN {
65
93
50
93
50633
    $test_mode = $ENV{DPKG_TEST_MODE} // 'dpkg';
66}
67
68sub _test_get_caller_dir
69{
70
268
268
861
    my (undef, $path, undef) = caller 1;
71
72
268
813
    $path =~ s{\.t$}{};
73
268
463
    $path =~ s{^\./}{};
74
75
268
556
    return $path;
76}
77
78sub test_get_data_path
79{
80
137
137
0
590
    my $path = shift;
81
82
137
100
501
    if (defined $path) {
83
1
1
        my $srcdir;
84
1
50
2
        $srcdir = $ENV{srcdir} if $test_mode ne 'cpan';
85
1
50
1
        $srcdir ||= '.';
86
1
2
        return "$srcdir/$path";
87    } else {
88
136
262
        return _test_get_caller_dir();
89    }
90}
91
92sub test_get_temp_path
93{
94
132
33
132
0
514
    my $path = shift // _test_get_caller_dir();
95
132
3090
    $path = 't.tmp/' . fileparse($path);
96
97
132
25665
    rmtree($path);
98
132
26096
    make_path($path);
99
132
340
    return $path;
100}
101
102sub 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
111sub test_get_perl_dirs
112{
113
0
0
0
0
0
    if ($test_mode eq 'cpan') {
114
0
0
        return qw(t lib);
115    } else {
116
0
0
        return qw(t lib utils/t scripts dselect);
117    }
118}
119
120sub _test_get_files
121{
122
0
0
0
    my ($filter, $dirs) = @_;
123
0
0
    my @files;
124    my $scan_files = sub {
125
0
0
0
0
        push @files, $File::Find::name if m/$filter/;
126
0
0
    };
127
128
0
0
0
0
    find($scan_files, @{$dirs});
129
130
0
0
    return @files;
131}
132
133sub all_po_files
134{
135
0
0
0
0
    return _test_get_files(qr/\.(?:po|pot)$/, [ test_get_po_dirs() ]);
136}
137
138sub all_perl_files
139{
140
0
0
0
0
    return _test_get_files(qr/\.(?:PL|pl|pm|t)$/, [ test_get_perl_dirs() ]);
141}
142
143sub all_perl_modules
144{
145
0
0
0
0
    return _test_get_files(qr/\.pm$/, [ test_get_perl_dirs() ]);
146}
147
148sub test_needs_author
149{
150
0
0
0
0
0
    if (not $ENV{AUTHOR_TESTING}) {
151
0
0
        plan skip_all => 'author test';
152    }
153}
154
155sub test_needs_module
156{
157
0
0
0
0
    my ($module, @imports) = @_;
158
0
0
    my ($package) = caller;
159
160
0
0
    require version;
161
0
0
    my $version = '';
162
0
0
0
0
    if (@imports >= 1 and version::is_lax($imports[0])) {
163
0
0
        $version = shift @imports;
164    }
165
166    eval qq{
167        package $package;
168        use $module $version \@imports;
169        1;
170
0
0
0
    } or do {
171
0
0
        plan skip_all => "requires module $module $version";
172    }
173}
174
175sub test_needs_command
176{
177
11
11
0
11
    my $command = shift;
178
179
11
50
20
    if (not can_run($command)) {
180
0
0
        plan skip_all => "requires command $command";
181    }
182}
183
184sub test_needs_srcdir_switch
185{
186
2
50
2
0
4
    if (defined $ENV{srcdir}) {
187
2
50
10
        chdir $ENV{srcdir} or BAIL_OUT("cannot chdir to source directory: $!");
188    }
189}
190
191sub test_neutralize_checksums
192{
193
31
31
0
176
    my $filename = shift;
194
31
30
    my $filenamenew = "$filename.new";
195
196
31
164
    my $cwd = getcwd();
197
31
50
1248
    open my $fhnew, '>', $filenamenew or die "cannot open new $filenamenew in $cwd: $!";
198
31
50
331
    open my $fh, '<', $filename or die "cannot open $filename in $cwd: $!";
199
31
263
    while (<$fh>) {
200
659
168
727
299
        s/^ ([0-9a-f]{32,}) [1-9][0-9]* /q{ } . $1 =~ tr{0-9a-f}{0}r . q{ 0 }/e;
201
659
659
335
741
        print { $fhnew } $_;
202    }
203
31
50
111
    close $fh or die "cannot close $filename";
204
31
50
487
    close $fhnew or die "cannot close $filenamenew";
205
206
31
50
1636
    rename $filenamenew, $filename or die "cannot rename $filenamenew to $filename";
207}
208
2091;