Adding upstream version 1.22.4.upstream/1.22.4

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 249 insertions, 0 deletions

diff --git a/scripts/Test/Dpkg.pm b/scripts/Test/Dpkg.pm
new file mode 100644
index 0000000..54f494c
--- /dev/null
+++ b/scripts/Test/Dpkg.pm
@@ -0,0 +1,249 @@
+# Copyright © 2015 Guillem Jover <guillem@debian.org>
+#
+# 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, see <https://www.gnu.org/licenses/>.
+
+=encoding utf8
+
+=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
+
+package Test::Dpkg 0.00;
+
+use strict;
+use warnings;
+
+our @EXPORT_OK = qw(
+    all_po_files
+    all_perl_files
+    all_perl_modules
+    test_get_po_dirs
+    test_get_perl_dirs
+    test_get_data_path
+    test_get_temp_path
+    test_needs_author
+    test_needs_module
+    test_needs_command
+    test_needs_openpgp_backend
+    test_needs_srcdir_switch
+    test_neutralize_checksums
+);
+our %EXPORT_TAGS = (
+    needs => [ qw(
+        test_needs_author
+        test_needs_module
+        test_needs_command
+        test_needs_openpgp_backend
+        test_needs_srcdir_switch
+    ) ],
+    paths => [ qw(
+        all_po_files
+        all_perl_files
+        all_perl_modules
+        test_get_po_dirs
+        test_get_perl_dirs
+        test_get_data_path
+        test_get_temp_path
+    ) ],
+);
+
+use Exporter qw(import);
+use Cwd;
+use File::Find;
+use File::Basename;
+use File::Path qw(make_path rmtree);
+use IPC::Cmd qw(can_run);
+use Test::More;
+
+my $test_mode;
+
+BEGIN {
+    $test_mode = $ENV{DPKG_TEST_MODE} // 'dpkg';
+}
+
+sub _test_get_caller_dir
+{
+    my (undef, $path, undef) = caller 1;
+
+    $path =~ s{\.t$}{};
+    $path =~ s{^\./}{};
+
+    return $path;
+}
+
+sub test_get_data_path
+{
+    my $path = shift;
+
+    if (defined $path) {
+        my $srcdir;
+        $srcdir = $ENV{srcdir} if $test_mode ne 'cpan';
+        $srcdir ||= '.';
+        return "$srcdir/$path";
+    } else {
+        return _test_get_caller_dir();
+    }
+}
+
+sub test_get_temp_path
+{
+    my $path = shift // _test_get_caller_dir();
+    $path = 't.tmp/' . fileparse($path);
+
+    rmtree($path);
+    make_path($path);
+    return $path;
+}
+
+sub test_get_po_dirs
+{
+    if ($test_mode eq 'cpan') {
+        return qw();
+    } else {
+        return qw(po scripts/po dselect/po man/po);
+    }
+}
+
+sub test_get_perl_dirs
+{
+    if ($test_mode eq 'cpan') {
+        return qw(t lib);
+    } else {
+        return qw(t lib utils/t scripts dselect);
+    }
+}
+
+sub _test_get_files
+{
+    my ($filter, $dirs) = @_;
+    my @files;
+    my $scan_files = sub {
+        push @files, $File::Find::name if m/$filter/;
+    };
+
+    find($scan_files, @{$dirs});
+
+    return @files;
+}
+
+sub all_po_files
+{
+    return _test_get_files(qr/\.(?:po|pot)$/, [ test_get_po_dirs() ]);
+}
+
+sub all_perl_files
+{
+    return _test_get_files(qr/\.(?:PL|pl|pm|t)$/, [ test_get_perl_dirs() ]);
+}
+
+sub all_perl_modules
+{
+    return _test_get_files(qr/\.pm$/, [ test_get_perl_dirs() ]);
+}
+
+sub test_needs_author
+{
+    if (not $ENV{AUTHOR_TESTING}) {
+        plan skip_all => 'author test';
+    }
+}
+
+sub test_needs_module
+{
+    my ($module, @imports) = @_;
+    my ($package) = caller;
+
+    require version;
+    my $version = '';
+    if (@imports >= 1 and version::is_lax($imports[0])) {
+        $version = shift @imports;
+    }
+
+    eval qq{
+        package $package;
+        use $module $version \@imports;
+        1;
+    } or do {
+        plan skip_all => "requires module $module $version";
+    }
+}
+
+sub test_needs_command
+{
+    my $command = shift;
+
+    if (not can_run($command)) {
+        plan skip_all => "requires command $command";
+    }
+}
+
+sub test_needs_openpgp_backend
+{
+    my @backends = qw(
+        gpg
+        sq
+        sqop
+        pgpainless-cli
+    );
+    my @cmds = grep { can_run($_) } @backends;
+    if (@cmds == 0) {
+        plan skip_all => "requires >= 1 openpgp command: @backends";
+    }
+
+    return @cmds;
+}
+
+sub test_needs_srcdir_switch
+{
+    if (defined $ENV{srcdir}) {
+        chdir $ENV{srcdir} or BAIL_OUT("cannot chdir to source directory: $!");
+    }
+}
+
+sub test_neutralize_checksums
+{
+    my $filename = shift;
+    my $filenamenew = "$filename.new";
+
+    my $cwd = getcwd();
+    open my $fhnew, '>', $filenamenew or die "cannot open new $filenamenew in $cwd: $!";
+    open my $fh, '<', $filename or die "cannot open $filename in $cwd: $!";
+    while (<$fh>) {
+        s/^ ([0-9a-f]{32,}) [1-9][0-9]* /q{ } . $1 =~ tr{0-9a-f}{0}r . q{ 0 }/e;
+        print { $fhnew } $_;
+    }
+    close $fh or die "cannot close $filename";
+    close $fhnew or die "cannot close $filenamenew";
+
+    rename $filenamenew, $filename or die "cannot rename $filenamenew to $filename";
+}
+
+=head1 CHANGES
+
+=head2 Version 0.xx
+
+This is a private module.
+
+=cut
+
+1;