util/perl/OpenSSL/Test/Utils.pm

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