mdw@git.distorted.org.uk Git - dpkg/blob - scripts/Test/Dpkg.pm

   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;