diff options
Diffstat (limited to 'lib/Test/Lintian/Helper.pm')
| -rw-r--r-- | lib/Test/Lintian/Helper.pm | 198 |
1 files changed, 198 insertions, 0 deletions
diff --git a/lib/Test/Lintian/Helper.pm b/lib/Test/Lintian/Helper.pm new file mode 100644 index 0000000..518d036 --- /dev/null +++ b/lib/Test/Lintian/Helper.pm @@ -0,0 +1,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 |