Commit | Line | Data |
---|---|---|
1479465f GJ |
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 | package Test::Dpkg; | |
17 | ||
18 | use strict; | |
19 | use warnings; | |
20 | ||
21 | our $VERSION = '0.00'; | |
22 | our @EXPORT_OK = qw( | |
23 | all_perl_files | |
24 | test_get_perl_dirs | |
25 | test_get_data_path | |
26 | test_needs_author | |
27 | test_needs_module | |
28 | test_needs_command | |
29 | test_needs_srcdir_switch | |
30 | test_neutralize_checksums | |
31 | ); | |
32 | our %EXPORT_TAGS = ( | |
33 | needs => [ qw( | |
34 | test_needs_author | |
35 | test_needs_module | |
36 | test_needs_command | |
37 | test_needs_srcdir_switch | |
38 | ) ], | |
39 | paths => [ qw( | |
40 | all_perl_files | |
41 | test_get_perl_dirs | |
42 | test_get_data_path | |
43 | ) ], | |
44 | ); | |
45 | ||
46 | use Exporter qw(import); | |
47 | use File::Find; | |
48 | use IPC::Cmd qw(can_run); | |
49 | use Test::More; | |
50 | ||
51 | sub test_get_data_path | |
52 | { | |
53 | my $path = shift; | |
54 | ||
55 | my $srcdir = $ENV{srcdir} || '.'; | |
56 | return "$srcdir/$path"; | |
57 | } | |
58 | ||
59 | sub test_get_perl_dirs | |
60 | { | |
61 | return qw(t src/t lib utils/t scripts dselect); | |
62 | } | |
63 | ||
64 | sub all_perl_files | |
65 | { | |
66 | my @files; | |
67 | my $scan_perl_files = sub { | |
68 | push @files, $File::Find::name if m/\.(pl|pm|t)$/; | |
69 | }; | |
70 | ||
71 | find($scan_perl_files, test_get_perl_dirs()); | |
72 | ||
73 | return @files; | |
74 | } | |
75 | ||
76 | sub test_needs_author | |
77 | { | |
78 | if (not $ENV{DPKG_DEVEL_MODE} and not $ENV{AUTHOR_TESTING}) { | |
79 | plan skip_all => 'developer test'; | |
80 | } | |
81 | } | |
82 | ||
83 | sub test_needs_module | |
84 | { | |
85 | my ($module, @imports) = @_; | |
86 | my ($package) = caller; | |
87 | ||
88 | require version; | |
89 | my $version = ''; | |
90 | if (@imports >= 1 and version::is_lax($imports[0])) { | |
91 | $version = shift @imports; | |
92 | } | |
93 | ||
94 | eval qq{ | |
95 | package $package; | |
96 | use $module $version \@imports; | |
97 | 1; | |
98 | } or do { | |
99 | plan skip_all => "requires module $module $version"; | |
100 | } | |
101 | } | |
102 | ||
103 | sub test_needs_command | |
104 | { | |
105 | my $command = shift; | |
106 | ||
107 | if (not can_run($command)) { | |
108 | plan skip_all => "requires command $command"; | |
109 | } | |
110 | } | |
111 | ||
112 | sub test_needs_srcdir_switch | |
113 | { | |
114 | if (defined $ENV{srcdir}) { | |
115 | chdir $ENV{srcdir} or BAIL_OUT("cannot chdir to source directory: $!"); | |
116 | } | |
117 | } | |
118 | ||
119 | sub test_neutralize_checksums | |
120 | { | |
121 | my $filename = shift; | |
122 | my $filenamenew = "$filename.new"; | |
123 | ||
124 | open my $fhnew, '>', $filenamenew or die; | |
125 | open my $fh, '<', $filename or die; | |
126 | while (<$fh>) { | |
127 | s/^ ([0-9a-f]{32,}) [1-9][0-9]* /q{ } . $1 =~ tr{0-9a-f}{0}r . q{ 0 }/e; | |
128 | print { $fhnew } $_; | |
129 | } | |
130 | close $fh or die; | |
131 | close $fhnew or die; | |
132 | ||
133 | rename $filenamenew, $filename or die; | |
134 | } | |
135 | ||
136 | 1; |