da35b14955b1c7a6ab1f339e940705805be9e5b4
[openssl.git] / 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 bldtop_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 bldtop_file() complain that setup() hasn't
79     # been run yet.
80     my $configdata = bldtop_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;