Adding upstream version 1.19.8.upstream/1.19.8upstream

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

1 files changed, 211 insertions, 0 deletions

diff --git a/scripts/Test/Dpkg.pm b/scripts/Test/Dpkg.pm
new file mode 100644
index 0000000..937f333
--- /dev/null
+++ b/scripts/Test/Dpkg.pm
@@ -0,0 +1,211 @@
+# 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/>.
+
+package Test::Dpkg;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.00';
+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_srcdir_switch
+    test_neutralize_checksums
+);
+our %EXPORT_TAGS = (
+    needs => [ qw(
+        test_needs_author
+        test_needs_module
+        test_needs_command
+        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 File::Find;
+use File::Basename;
+use File::Path qw(make_path);
+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) {
+        if ($test_mode eq 'cpan') {
+            return $path;
+        } else {
+            my $srcdir = $ENV{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);
+
+    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 src/t lib utils/t scripts dselect);
+    }
+}
+
+sub all_po_files
+{
+    my $filter = shift // qr/\.(?:po|pot)$/;
+    my @files;
+    my $scan_po_files = sub {
+        push @files, $File::Find::name if m/$filter/;
+    };
+
+    find($scan_po_files, test_get_po_dirs());
+
+    return @files;
+}
+
+sub all_perl_files
+{
+    my $filter = shift // qr/\.(?:PL|pl|pm|t)$/;
+    my @files;
+    my $scan_perl_files = sub {
+        push @files, $File::Find::name if m/$filter/;
+    };
+
+    find($scan_perl_files, test_get_perl_dirs());
+
+    return @files;
+}
+
+sub all_perl_modules
+{
+    return all_perl_files(qr/\.pm$/);
+}
+
+sub test_needs_author
+{
+    if (not $ENV{DPKG_DEVEL_MODE} and not $ENV{AUTHOR_TESTING}) {
+        plan skip_all => 'developer 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_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";
+
+    open my $fhnew, '>', $filenamenew or die;
+    open my $fh, '<', $filename or die;
+    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;
+    close $fhnew or die;
+
+    rename $filenamenew, $filename or die;
+}
+
+1;