util/perl/OpenSSL/Test/Utils.pm

   1 # Copyright 2016 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 =item B<anydisabled ARRAY>
  57
  58 In an array context returns an array with each element set to 1 if the
  59 corresponding feature is disabled and 0 otherwise.
  60
  61 In a scalar context, alldisabled returns 1 if all of the features in
  62 ARRAY are disabled, while anydisabled returns 1 if any of them are
  63 disabled.
  64
  65 =item B<config STRING>
  66
  67 Returns an item from the %config hash in \$TOP/configdata.pm.
  68
  69 =item B<have_IPv4>
  70 =item B<have_IPv6>
  71
  72 Return true if IPv4 / IPv6 is possible to use on the current system.
  73
  74 =back
  75
  76 =cut
  77
  78 our %available_protocols;
  79 our %disabled;
  80 our %config;
  81 my $configdata_loaded = 0;
  82
  83 sub load_configdata {
  84     # We eval it so it doesn't run at compile time of this file.
  85     # The latter would have bldtop_file() complain that setup() hasn't
  86     # been run yet.
  87     my $configdata = bldtop_file("configdata.pm");
  88     eval { require $configdata;
  89            %available_protocols = %configdata::available_protocols;
  90            %disabled = %configdata::disabled;
  91            %config = %configdata::config;
  92     };
  93     $configdata_loaded = 1;
  94 }
  95
  96 # args
  97 #  list of 1s and 0s, coming from check_disabled()
  98 sub anyof {
  99     my $x = 0;
 100     foreach (@_) { $x += $_ }
 101     return $x > 0;
 102 }
 103
 104 # args
 105 #  list of 1s and 0s, coming from check_disabled()
 106 sub allof {
 107     my $x = 1;
 108     foreach (@_) { $x *= $_ }
 109     return $x > 0;
 110 }
 111
 112 # args
 113 #  list of strings, all of them should be names of features
 114 #  that can be disabled.
 115 # returns a list of 1s (if the corresponding feature is disabled)
 116 #  and 0s (if it isn't)
 117 sub check_disabled {
 118     return map { exists $disabled{lc $_} ? 1 : 0 } @_;
 119 }
 120
 121 # Exported functions #################################################
 122
 123 # args:
 124 #  list of features to check
 125 sub anydisabled {
 126     load_configdata() unless $configdata_loaded;
 127     my @ret = check_disabled(@_);
 128     return @ret if wantarray;
 129     return anyof(@ret);
 130 }
 131
 132 # args:
 133 #  list of features to check
 134 sub alldisabled {
 135     load_configdata() unless $configdata_loaded;
 136     my @ret = check_disabled(@_);
 137     return @ret if wantarray;
 138     return allof(@ret);
 139 }
 140
 141 # !!! Kept for backward compatibility
 142 # args:
 143 #  single string
 144 sub disabled {
 145     anydisabled(@_);
 146 }
 147
 148 sub available_protocols {
 149     load_configdata() unless $configdata_loaded;
 150     my $protocol_class = shift;
 151     if (exists $available_protocols{lc $protocol_class}) {
 152         return @{$available_protocols{lc $protocol_class}}
 153     }
 154     return ();
 155 }
 156
 157 sub config {
 158     load_configdata() unless $configdata_loaded;
 159     return $config{$_[0]};
 160 }
 161
 162 # IPv4 / IPv6 checker
 163 my $have_IPv4 = -1;
 164 my $have_IPv6 = -1;
 165 my $IP_factory;
 166 sub check_IP {
 167     my $listenaddress = shift;
 168
 169     eval {
 170         require IO::Socket::IP;
 171         my $s = IO::Socket::IP->new(
 172             LocalAddr => $listenaddress,
 173             LocalPort => 0,
 174             Listen=>1,
 175             );
 176         $s or die "\n";
 177         $s->close();
 178     };
 179     if ($@ eq "") {
 180         return 1;
 181     }
 182
 183     eval {
 184         require IO::Socket::INET6;
 185         my $s = IO::Socket::INET6->new(
 186             LocalAddr => $listenaddress,
 187             LocalPort => 0,
 188             Listen=>1,
 189             );
 190         $s or die "\n";
 191         $s->close();
 192     };
 193     if ($@ eq "") {
 194         return 1;
 195     }
 196
 197     eval {
 198         require IO::Socket::INET;
 199         my $s = IO::Socket::INET->new(
 200             LocalAddr => $listenaddress,
 201             LocalPort => 0,
 202             Listen=>1,
 203             );
 204         $s or die "\n";
 205         $s->close();
 206     };
 207     if ($@ eq "") {
 208         return 1;
 209     }
 210
 211     return 0;
 212 }
 213
 214 sub have_IPv4 {
 215     if ($have_IPv4 < 0) {
 216         $have_IPv4 = check_IP("127.0.0.1");
 217     }
 218     return $have_IPv4;
 219 }
 220
 221 sub have_IPv6 {
 222     if ($have_IPv6 < 0) {
 223         $have_IPv6 = check_IP("::1");
 224     }
 225     return $have_IPv6;
 226 }
 227
 228
 229 =head1 SEE ALSO
 230
 231 L<OpenSSL::Test>
 232
 233 =head1 AUTHORS
 234
 235 Stephen Henson E<lt>steve@openssl.orgE<gt> and
 236 Richard Levitte E<lt>levitte@openssl.orgE<gt>
 237
 238 =cut
 239
 240 1;