Testsuite: fix warning

[users/heiko/exim.git] / test / lib / Exim / Runtest.pm

diff --git a/test/lib/Exim/Runtest.pm b/test/lib/Exim/Runtest.pm
index 1677ae3e6ed914b5a5af3bbbcc569929204940f5..8d22544bfdcdd7de26d5a0d8e2ce688e82f22619 100644 (file)
--- a/test/lib/Exim/Runtest.pm
+++ b/test/lib/Exim/Runtest.pm
@@ -2,12 +2,15 @@ package Exim::Runtest;
 use 5.010;
 use strict;
 use warnings;
 use 5.010;
 use strict;
 use warnings;

+use File::Basename;

 use IO::Socket::INET;
 use Cwd;
 use Carp;
 
 use IO::Socket::INET;
 use Cwd;
 use Carp;
 

-use parent 'Exporter';
-our @EXPORT_OK = qw(mailgroup dynamic_socket exim_binary);
+use Exporter;
+our @ISA = qw(Exporter);
+
+our @EXPORT_OK = qw(mailgroup dynamic_socket exim_binary flavour flavours);

 our %EXPORT_TAGS = (
     all => \@EXPORT_OK,
 );
 our %EXPORT_TAGS = (
     all => \@EXPORT_OK,
 );


@@ -61,8 +64,10 @@ sub dynamic_socket {
 sub exim_binary {
 
     # two simple cases, absolute path or relative path and executable
 sub exim_binary {
 
     # two simple cases, absolute path or relative path and executable

-    return @_ if $_[0] =~ /^\//;
-    return Cwd::abs_path(shift), @_ if -x $_[0];
+    if (@_) {
+        return @_ if $_[0] =~ /^\//;
+        return Cwd::abs_path(shift), @_ if -x $_[0];
+    }

 
     # so we're still here, if the simple approach didn't help.
 
 
     # so we're still here, if the simple approach didn't help.
 


@@ -104,6 +109,36 @@ sub exim_binary {
     return $binaries[0], @_;
 }
 
     return $binaries[0], @_;
 }
 

+sub flavour {
+    my $etc = '/etc';
+
+    if (@_) {
+        croak "do not pass a directory, it's for testing only"
+            unless $ENV{HARNESS_ACTIVE};
+        $etc = shift;
+    }
+
+    if (open(my $f, '<', "$etc/os-release")) {
+        local $_ = join '', <$f>;
+        my ($id) = /^ID="?(.*?)"?\s*$/m;
+        my $version = /^VERSION_ID="?(.*?)"?\s*$/m ? $1 : '';
+        return "$id$version";
+    }
+
+    if (open(my $f, '<', "$etc/debian_version")) {
+        chomp(local $_ = <$f>);
+        $_ = int $_;
+        return "debian$_";
+    }
+
+    undef;
+}
+
+sub flavours {
+    my %h = map { /\.(\S+)$/, 1 }
+            glob('stdout/*.*'), glob('stderr/*.*');
+    return sort keys %h;
+}

 
 1;
 
 
 1;
 


@@ -131,6 +166,16 @@ Otherwise search the binary (while honouring C<EXIM_BUILD_SUFFIX>,
 C<../scripts/os-type> and C<../os-arch>) and return the
 the path to the binary and the unmodified I<@argv>.
 
 C<../scripts/os-type> and C<../os-arch>) and return the
 the path to the binary and the unmodified I<@argv>.
 

+=item B<flavour>()
+
+Find a hint for the current flavour (Linux distro). It does so by checking
+typical files in the F</etc> directory.
+
+=item B<flavours>()
+
+Return a list of available flavours. It does so by scanning F<stdout/> and
+F<stderr/> for I<flavour> files (extensions after the numerical prefix.
+

 =back
 
 =cut
 =back
 
 =cut