test/testlib/OpenSSL/Test/Utils.pm

   1 package OpenSSL::Test::Utils;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Exporter;
   7 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
   8 $VERSION = "0.1";
   9 @ISA = qw(Exporter);
  10 @EXPORT = qw(alldisabled anydisabled disabled config available_protocols
  11              have_IPv4 have_IPv6);
  12
  13 =head1 NAME
  14
  15 OpenSSL::Test::Utils - test utility functions
  16
  17 =head1 SYNOPSIS
  18
  19   use OpenSSL::Test::Utils;
  20
  21   my @tls = available_protocols("tls");
  22   my @dtls = available_protocols("dtls");
  23   alldisabled("dh", "dsa");
  24   anydisabled("dh", "dsa");
  25
  26   config("fips");
  27
  28   have_IPv4();
  29   have_IPv6();
  30
  31 =head1 DESCRIPTION
  32
  33 This module provides utility functions for the testing framework.
  34
  35 =cut
  36
  37 use OpenSSL::Test qw/:DEFAULT top_file/;
  38
  39 =over 4
  40
  41 =item B<available_protocols STRING>
  42
  43 Returns a list of strings for all the available SSL/TLS versions if
  44 STRING is "tls", or for all the available DTLS versions if STRING is
  45 "dtls".  Otherwise, it returns the empty list.  The strings in the
  46 returned list can be used with B<alldisabled> and B<anydisabled>.
  47
  48 =item B<alldisabled ARRAY>
  49 =item B<anydisabled ARRAY>
  50
  51 In an array context returns an array with each element set to 1 if the
  52 corresponding feature is disabled and 0 otherwise.
  53
  54 In a scalar context, alldisabled returns 1 if all of the features in
  55 ARRAY are disabled, while anydisabled returns 1 if any of them are
  56 disabled.
  57
  58 =item B<config STRING>
  59
  60 Returns an item from the %config hash in \$TOP/configdata.pm.
  61
  62 =item B<have_IPv4>
  63 =item B<have_IPv6>
  64
  65 Return true if IPv4 / IPv6 is possible to use on the current system.
  66
  67 =back
  68
  69 =cut
  70
  71 our %available_protocols;
  72 our %disabled;
  73 our %config;
  74 my $configdata_loaded = 0;
  75
  76 sub load_configdata {
  77     # We eval it so it doesn't run at compile time of this file.
  78     # The latter would have top_dir() complain that setup() hasn't
  79     # been run yet.
  80     my $configdata = top_file("configdata.pm");
  81     eval { require $configdata;
  82            %available_protocols = %configdata::available_protocols;
  83            %disabled = %configdata::disabled;
  84            %config = %configdata::config;
  85     };
  86     $configdata_loaded = 1;
  87 }
  88
  89 # args
  90 #  list of 1s and 0s, coming from check_disabled()
  91 sub anyof {
  92     my $x = 0;
  93     foreach (@_) { $x += $_ }
  94     return $x > 0;
  95 }
  96
  97 # args
  98 #  list of 1s and 0s, coming from check_disabled()
  99 sub allof {
 100     my $x = 1;
 101     foreach (@_) { $x *= $_ }
 102     return $x > 0;
 103 }
 104
 105 # args
 106 #  list of strings, all of them should be names of features
 107 #  that can be disabled.
 108 # returns a list of 1s (if the corresponding feature is disabled)
 109 #  and 0s (if it isn't)
 110 sub check_disabled {
 111     return map { exists $disabled{lc $_} ? 1 : 0 } @_;
 112 }
 113
 114 # Exported functions #################################################
 115
 116 # args:
 117 #  list of features to check
 118 sub anydisabled {
 119     load_configdata() unless $configdata_loaded;
 120     my @ret = check_disabled(@_);
 121     return @ret if wantarray;
 122     return anyof(@ret);
 123 }
 124
 125 # args:
 126 #  list of features to check
 127 sub alldisabled {
 128     load_configdata() unless $configdata_loaded;
 129     my @ret = check_disabled(@_);
 130     return @ret if wantarray;
 131     return allof(@ret);
 132 }
 133
 134 #!!! Kept for backward compatibility
 135 # args:
 136 #  single string
 137 sub disabled {
 138     anydisabled(@_);
 139 }
 140
 141 sub available_protocols {
 142     load_configdata() unless $configdata_loaded;
 143     my $protocol_class = shift;
 144     if (exists $available_protocols{lc $protocol_class}) {
 145         return @{$available_protocols{lc $protocol_class}}
 146     }
 147     return ();
 148 }
 149
 150 sub config {
 151     return $config{$_[0]};
 152 }
 153
 154 # IPv4 / IPv6 checker
 155 my $have_IPv4 = -1;
 156 my $have_IPv6 = -1;
 157 my $IP_factory;
 158 sub check_IP {
 159     my $listenaddress = shift;
 160
 161     eval {
 162         require IO::Socket::IP;
 163         my $s = IO::Socket::IP->new(
 164             LocalAddr => $listenaddress,
 165             LocalPort => 0,
 166             Listen=>1,
 167             );
 168         $s or die "\n";
 169         $s->close();
 170     };
 171     if ($@ eq "") {
 172         return 1;
 173     }
 174
 175     eval {
 176         require IO::Socket::INET6;
 177         my $s = IO::Socket::INET6->new(
 178             LocalAddr => $listenaddress,
 179             LocalPort => 0,
 180             Listen=>1,
 181             );
 182         $s or die "\n";
 183         $s->close();
 184     };
 185     if ($@ eq "") {
 186         return 1;
 187     }
 188
 189     eval {
 190         require IO::Socket::INET;
 191         my $s = IO::Socket::INET->new(
 192             LocalAddr => $listenaddress,
 193             LocalPort => 0,
 194             Listen=>1,
 195             );
 196         $s or die "\n";
 197         $s->close();
 198     };
 199     if ($@ eq "") {
 200         return 1;
 201     }
 202
 203     return 0;
 204 }
 205
 206 sub have_IPv4 {
 207     if ($have_IPv4 < 0) {
 208         $have_IPv4 = check_IP("127.0.0.1");
 209     }
 210     return $have_IPv4;
 211 }
 212
 213 sub have_IPv6 {
 214     if ($have_IPv6 < 0) {
 215         $have_IPv6 = check_IP("::1");
 216     }
 217     return $have_IPv6;
 218 }
 219
 220
 221 =head1 SEE ALSO
 222
 223 L<OpenSSL::Test>
 224
 225 =head1 AUTHORS
 226
 227 Stephen Henson E<lt>steve@openssl.orgE<gt> and
 228 Richard Levitte E<lt>levitte@openssl.orgE<gt>
 229
 230 =cut
 231
 232 1;