• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
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
8package OpenSSL::Test::Utils;
9
10use strict;
11use warnings;
12
13use Exporter;
14use 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
22OpenSSL::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
40This module provides utility functions for the testing framework.
41
42=cut
43
44use OpenSSL::Test qw/:DEFAULT bldtop_file/;
45
46=over 4
47
48=item B<available_protocols STRING>
49
50Returns a list of strings for all the available SSL/TLS versions if
51STRING is "tls", or for all the available DTLS versions if STRING is
52"dtls".  Otherwise, it returns the empty list.  The strings in the
53returned list can be used with B<alldisabled> and B<anydisabled>.
54
55=item B<alldisabled ARRAY>
56
57=item B<anydisabled ARRAY>
58
59In an array context returns an array with each element set to 1 if the
60corresponding feature is disabled and 0 otherwise.
61
62In a scalar context, alldisabled returns 1 if all of the features in
63ARRAY are disabled, while anydisabled returns 1 if any of them are
64disabled.
65
66=item B<config STRING>
67
68Returns an item from the %config hash in \$TOP/configdata.pm.
69
70=item B<have_IPv4>
71
72=item B<have_IPv6>
73
74Return true if IPv4 / IPv6 is possible to use on the current system.
75
76=back
77
78=cut
79
80our %available_protocols;
81our %disabled;
82our %config;
83my $configdata_loaded = 0;
84
85sub 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()
100sub 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()
108sub 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)
119sub check_disabled {
120    return map { exists $disabled{lc $_} ? 1 : 0 } @_;
121}
122
123# Exported functions #################################################
124
125# args:
126#  list of features to check
127sub 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
136sub 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
146sub disabled {
147    anydisabled(@_);
148}
149
150sub 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
159sub config {
160    load_configdata() unless $configdata_loaded;
161    return $config{$_[0]};
162}
163
164# IPv4 / IPv6 checker
165my $have_IPv4 = -1;
166my $have_IPv6 = -1;
167my $IP_factory;
168sub 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
216sub have_IPv4 {
217    if ($have_IPv4 < 0) {
218        $have_IPv4 = check_IP("127.0.0.1");
219    }
220    return $have_IPv4;
221}
222
223sub 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
232L<OpenSSL::Test>
233
234=head1 AUTHORS
235
236Stephen Henson E<lt>steve@openssl.orgE<gt> and
237Richard Levitte E<lt>levitte@openssl.orgE<gt>
238
239=cut
240
2411;
242