File Coverage

File:Test/Dpkg.pm
Coverage:56.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
16=encoding utf8
17
18 - 29
=head1 NAME

Test::Dpkg - helpers for test scripts for the dpkg suite

=head1 DESCRIPTION

This module provides helper functions to ease implementing test scripts
for the dpkg suite of tools.

B<Note>: This is a private module, its API can change at any time.

=cut
30
31package Test::Dpkg 0.00;
32
33
372
372
372
372
1365
351
8030
use strict;
34
372
372
372
372
763
155
25517
use warnings;
35
36our @EXPORT_OK = qw(
37    all_po_files
38    all_perl_files
39    all_perl_modules
40    test_get_po_dirs
41    test_get_perl_dirs
42    test_get_data_path
43    test_get_temp_path
44    test_needs_author
45    test_needs_module
46    test_needs_command
47    test_needs_openpgp_backend
48    test_needs_srcdir_switch
49    test_neutralize_checksums
50    test_get_openpgp_backend
51);
52our %EXPORT_TAGS = (
53    needs => [ qw(
54        test_needs_author
55        test_needs_module
56        test_needs_command
57        test_needs_openpgp_backend
58        test_needs_srcdir_switch
59    ) ],
60    paths => [ qw(
61        all_po_files
62        all_perl_files
63        all_perl_modules
64        test_get_po_dirs
65        test_get_perl_dirs
66        test_get_data_path
67        test_get_temp_path
68    ) ],
69);
70
71
372
372
372
372
821
228
6500
use Exporter qw(import);
72
372
372
372
372
735
247
13998
use Cwd;
73
372
372
372
372
1077
341
9679
use File::Find;
74
372
372
372
372
1526
138
15069
use File::Basename;
75
372
372
372
372
801
162
12463
use File::Path qw(make_path rmtree);
76
372
372
372
372
103660
9799659
20625
use IPC::Cmd qw(can_run);
77
372
372
372
372
2253
113834
2555
use Test::More;
78
79my $test_mode;
80
81BEGIN {
82
372
50
372
315937
    $test_mode = $ENV{DPKG_TEST_MODE} // 'dpkg';
83}
84
85sub _test_get_caller_dir
86{
87
1629
1629
5930
    my (undef, $path, undef) = caller 1;
88
89
1629
6924
    $path =~ s{\.t$}{};
90
1629
2790
    $path =~ s{^\./}{};
91
92
1629
3700
    return $path;
93}
94
95sub test_get_data_path
96{
97
825
825
0
1175
    my $path = shift;
98
99
825
100
2279
    if (defined $path) {
100
3
3
        my $srcdir;
101
3
50
9
        $srcdir = $ENV{srcdir} if $test_mode ne 'cpan';
102
3
50
5
        $srcdir ||= '.';
103
3
5
        return "$srcdir/$path";
104    } else {
105
822
2356
        return _test_get_caller_dir();
106    }
107}
108
109sub test_get_temp_path
110{
111
807
33
807
0
4176
    my $path = shift // _test_get_caller_dir();
112
807
22341
    $path = 't.tmp/' . fileparse($path);
113
114
807
351426
    rmtree($path);
115
807
105971
    make_path($path);
116
807
3584
    return $path;
117}
118
119sub test_get_po_dirs
120{
121
0
0
0
0
0
    if ($test_mode eq 'cpan') {
122
0
0
        return qw();
123    } else {
124
0
0
        return qw(po scripts/po dselect/po man/po);
125    }
126}
127
128sub test_get_perl_dirs
129{
130
0
0
0
0
0
    if ($test_mode eq 'cpan') {
131
0
0
        return qw(t lib);
132    } else {
133
0
0
        return qw(t lib utils/t scripts dselect);
134    }
135}
136
137sub _test_get_files
138{
139
0
0
0
    my ($filter, $dirs) = @_;
140
0
0
    my @files;
141    my $scan_files = sub {
142
0
0
0
0
        push @files, $File::Find::name if m/$filter/;
143
0
0
    };
144
145
0
0
0
0
    find($scan_files, @{$dirs});
146
147
0
0
    return @files;
148}
149
150sub all_po_files
151{
152
0
0
0
0
    return _test_get_files(qr/\.(?:po|pot)$/, [ test_get_po_dirs() ]);
153}
154
155sub all_perl_files
156{
157
0
0
0
0
    return _test_get_files(qr/\.(?:PL|pl|pm|t)$/, [ test_get_perl_dirs() ]);
158}
159
160sub all_perl_modules
161{
162
0
0
0
0
    return _test_get_files(qr/\.pm$/, [ test_get_perl_dirs() ]);
163}
164
165sub test_needs_author
166{
167
0
0
0
0
0
    if (not $ENV{AUTHOR_TESTING}) {
168
0
0
        plan skip_all => 'author test';
169    }
170}
171
172sub test_needs_module
173{
174
0
0
0
0
    my ($module, @imports) = @_;
175
0
0
    my ($package) = caller;
176
177
0
0
    require version;
178
0
0
    my $version = '';
179
0
0
0
0
    if (@imports >= 1 and version::is_lax($imports[0])) {
180
0
0
        $version = shift @imports;
181    }
182
183    eval qq{
184        package $package;
185        use $module $version \@imports;
186        1;
187
0
0
0
    } or do {
188
0
0
        plan skip_all => "requires module $module $version";
189    }
190}
191
192sub test_needs_command
193{
194
39
39
0
60
    my $command = shift;
195
196
39
50
111
    if (not can_run($command)) {
197
0
0
        plan skip_all => "requires command $command";
198    }
199}
200
201my %openpgp_command = (
202    'gpg-sq' => {
203        backend => 'gpg',
204    },
205    'gpg' => {
206        backend => 'gpg',
207    },
208    'sq' => {
209        backend => 'sq',
210    },
211    'sqop' => {
212        backend => 'sop',
213    },
214    'pgpainless-cli' => {
215        backend => 'sop',
216    },
217);
218
219sub test_needs_openpgp_backend
220{
221
216
216
0
927
    my @cmds = sort keys %openpgp_command;
222
216
1080
432
12245550
    my @have_cmds = grep { can_run($_) } @cmds;
223
216
50
21933
    if (@have_cmds == 0) {
224
0
0
        plan skip_all => "requires >= 1 openpgp command: @cmds";
225    }
226
227
216
705
    return @have_cmds;
228}
229
230sub test_get_openpgp_backend
231{
232
726
726
0
1581
    my $cmd = shift;
233
234
726
100
7608
    return 'auto' if $cmd eq 'auto';
235
519
2526
    return $openpgp_command{$cmd}{backend};
236}
237
238sub test_needs_srcdir_switch
239{
240
6
50
6
0
16
    if (defined $ENV{srcdir}) {
241
6
50
40
        chdir $ENV{srcdir} or BAIL_OUT("cannot chdir to source directory: $!");
242    }
243}
244
245sub test_neutralize_checksums
246{
247
138
138
0
393
    my $filename = shift;
248
138
113
    my $filenamenew = "$filename.new";
249
250
138
1287
    my $cwd = getcwd();
251
138
50
5386
    open my $fhnew, '>', $filenamenew or die "cannot open new $filenamenew in $cwd: $!";
252
138
50
1176
    open my $fh, '<', $filename or die "cannot open $filename in $cwd: $!";
253
138
1194
    while (<$fh>) {
254
2757
504
3034
949
        s/^ ([0-9a-f]{32,}) [1-9][0-9]* /q{ } . $1 =~ tr{0-9a-f}{0}r . q{ 0 }/e;
255
2757
2757
1694
3673
        print { $fhnew } $_;
256    }
257
138
50
451
    close $fh or die "cannot close $filename";
258
138
50
2054
    close $fhnew or die "cannot close $filenamenew";
259
260
138
50
7339
    rename $filenamenew, $filename or die "cannot rename $filenamenew to $filename";
261}
262
263 - 269
=head1 CHANGES

=head2 Version 0.xx

This is a private module.

=cut
270
2711;