1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
# Copyright (C) 1998 Richard Braakman
# Copyright (C) 2008 Frank Lichtenheld
# Copyright (C) 2008, 2009 Russ Allbery
# Copyright (C) 2018 Felix Lechner
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, you can find it on the World Wide
# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA
package Test::Lintian::Helper;
=head1 NAME
Test::Lintian::Helper -- Helper functions for various testing parts
=head1 SYNOPSIS
use Test::Lintian::Helper qw(get_latest_policy);
my $policy_version = get_latest_policy();
=head1 DESCRIPTION
Helper functions for preparing and running Lintian tests.
=cut
use v5.20;
use warnings;
use utf8;
use Exporter qw(import);
BEGIN {
our @EXPORT_OK = qw(
cache_dpkg_architecture_values
get_latest_policy
get_recommended_debhelper_version
copy_dir_contents
rfc822date
);
}
use Carp;
use File::Spec::Functions qw(abs2rel rel2abs);
use File::Path qw(remove_tree);
use Path::Tiny;
use POSIX qw(locale_h strftime);
use Unicode::UTF8 qw(encode_utf8 decode_utf8);
use Lintian::IPC::Run3 qw(safe_qx);
use Lintian::Profile;
=head1 FUNCTIONS
=over 4
=item cache_dpkg_architecture_values()
Ensures that the output from dpkg-architecture has been cached.
=cut
sub cache_dpkg_architecture_values {
my $output = decode_utf8(safe_qx('dpkg-architecture'));
die encode_utf8('dpkg-architecture failed')
if $?;
$output = decode_utf8($output)
if length $output;
my @lines = split(/\n/, $output);
for my $line (@lines) {
my ($k, $v) = split(/=/, $line, 2);
$ENV{$k} = $v;
}
return;
}
=item get_latest_policy()
Returns a list with two elements. The first is the most recent version
of the Debian policy. The second is its effective date.
=cut
sub get_latest_policy {
my $profile = Lintian::Profile->new;
$profile->load(undef, undef, 0);
my $releases = $profile->data->policy_releases;
my $version = $releases->latest_version;
die encode_utf8('Could not get latest policy version.')
unless defined $version;
my $epoch = $releases->epoch($version);
die encode_utf8('Could not get latest policy date.')
unless defined $epoch;
return ($version, $epoch);
}
=item get_recommended_debhelper_version()
Returns the version of debhelper recommended in 'debhelper/compat-level'
via Lintian::Data, relative to the established LINTIAN_BASE.
=cut
sub get_recommended_debhelper_version {
my $profile = Lintian::Profile->new;
$profile->load(undef, undef, 0);
my $compat_level = $profile->data->debhelper_levels;
return $compat_level->value('recommended');
}
=item copy_dir_contents(SRC_DIR, TARGET_DIR)
Populates TARGET_DIR with files/dirs from SRC_DIR, preserving all attributes but
dereferencing links. For an empty directory, no dummy file is required.
=cut
sub copy_dir_contents {
my ($source, $destination) = @_;
# 'cp -r' cannot overwrite directories with files or vice versa
my @paths = File::Find::Rule->in($source);
foreach my $path (@paths) {
my $relative = abs2rel($path, $source);
my $prospective = rel2abs($relative, $destination);
# recursively delete directories to be replaced by a file
remove_tree($prospective)
if -d $prospective && -e $path && !-d _;
# remove files to be replaced by a directory
if (-e $prospective && !-d _ && -d $path) {
unlink($prospective)
or die encode_utf8("Cannot unlink $prospective");
}
}
# 'cp -r' with a dot will error without files present
if (scalar path($source)->children) {
system('cp', '-rp', "$source/.", '-t', $destination)== 0
or croak encode_utf8("Could not copy $source to $destination: $!");
}
return 1;
}
=item rfc822date(EPOCH)
Returns a string with the date and time described by EPOCH, formatted
according to RFC822.
=cut
sub rfc822date {
my ($epoch) = @_;
my $old_locale = setlocale(LC_TIME, 'C');
my $datestring = strftime('%a, %d %b %Y %H:%M:%S %z', localtime($epoch));
setlocale(LC_TIME, $old_locale);
return $datestring;
}
=back
=cut
1;
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
|
