]>
Commit | Line | Data |
---|---|---|
4b801fdc | 1 | #! /usr/bin/env perl |
b6461792 | 2 | # Copyright 2018-2024 The OpenSSL Project Authors. All Rights Reserved. |
4b801fdc | 3 | # |
909f1a2e | 4 | # Licensed under the Apache License 2.0 (the "License"). You may not use |
4b801fdc RL |
5 | # this file except in compliance with the License. You can obtain a copy |
6 | # in the file LICENSE in the source distribution or at | |
7 | # https://www.openssl.org/source/license.html | |
8 | ||
9 | use strict; | |
10 | no strict 'refs'; # To be able to use strings as function refs | |
11 | use OpenSSL::Test; | |
0777de15 | 12 | use OpenSSL::Test::Utils; |
4b801fdc | 13 | use Errno qw(:POSIX); |
1b726e9b | 14 | use POSIX qw(:limits_h strerror); |
4b801fdc | 15 | |
1b726e9b | 16 | use Data::Dumper; |
4b801fdc RL |
17 | |
18 | setup('test_errstr'); | |
19 | ||
0777de15 RL |
20 | # In a cross compiled situation, there are chances that our |
21 | # application is linked against different C libraries than | |
22 | # perl, and may thereby get different error messages for the | |
23 | # same error. | |
24 | # The safest is not to test under such circumstances. | |
25 | plan skip_all => 'This is unsupported for cross compiled configurations' | |
26 | if config('CROSS_COMPILE'); | |
27 | ||
565a19ee RL |
28 | # The same can be said when compiling OpenSSL with mingw configuration |
29 | # on Windows when built with msys perl. Similar problems are also observed | |
30 | # in MSVC builds, depending on the perl implementation used. | |
31 | plan skip_all => 'This is unsupported on MSYS/MinGW or MSWin32' | |
32 | if $^O eq 'msys' or $^O eq 'MSWin32'; | |
33 | ||
f1d49ed9 RL |
34 | plan skip_all => 'OpenSSL is configured "no-autoerrinit" or "no-err"' |
35 | if disabled('autoerrinit') || disabled('err'); | |
36 | ||
1b726e9b RL |
37 | # OpenSSL constants found in <openssl/err.h> |
38 | use constant ERR_SYSTEM_FLAG => INT_MAX + 1; | |
39 | use constant ERR_LIB_OFFSET => 23; # Offset of the "library" errcode section | |
40 | ||
41 | # OpenSSL "library" numbers | |
42 | use constant ERR_LIB_NONE => 1; | |
6e68f244 | 43 | |
1b726e9b RL |
44 | # We use Errno::EXPORT_OK as a list of known errno values on the current |
45 | # system. libcrypto's ERR should either use the same string as perl, or if | |
46 | # it was outside the range that ERR looks at, ERR gives the reason string | |
47 | # "reason(nnn)", where nnn is the errno number. | |
48 | ||
49 | plan tests => scalar @Errno::EXPORT_OK | |
4b801fdc RL |
50 | +1 # Checking that error 128 gives 'reason(128)' |
51 | +1 # Checking that error 0 gives the library name | |
8e78da06 | 52 | +1; # Check trailing whitespace is removed. |
4b801fdc | 53 | |
1b726e9b RL |
54 | # Test::More:ok() has a sub prototype, which means we need to use the '&ok' |
55 | # syntax to force it to accept a list as a series of arguments. | |
56 | ||
57 | foreach my $errname (@Errno::EXPORT_OK) { | |
58 | # The error names are perl constants, which are implemented as functions | |
59 | # returning the numeric value of that name. | |
c88f6f0e RL |
60 | my $errcode = "Errno::$errname"->(); |
61 | ||
62 | SKIP: { | |
63 | # On most systems, there is no E macro for errcode zero in <errno.h>, | |
64 | # which means that it seldom comes up here. However, reports indicate | |
65 | # that some platforms do have an E macro for errcode zero. | |
66 | # With perl, errcode zero is a bit special. Perl consistently gives | |
67 | # the empty string for that one, while the C strerror() may give back | |
68 | # something else. The easiest way to deal with that possible mismatch | |
69 | # is to skip this errcode. | |
70 | skip "perl error strings and ssystem error strings for errcode 0 differ", 1 | |
71 | if $errcode == 0; | |
41385f27 RL |
72 | # On some systems (for example Hurd), there are negative error codes. |
73 | # These are currently unsupported in OpenSSL error reports. | |
74 | skip "negative error codes are not supported in OpenSSL", 1 | |
75 | if $errcode < 0; | |
c88f6f0e RL |
76 | |
77 | &ok(match_syserr_reason($errcode)); | |
78 | } | |
4b801fdc RL |
79 | } |
80 | ||
1b726e9b RL |
81 | # OpenSSL library 1 is the "unknown" library |
82 | &ok(match_opensslerr_reason(ERR_LIB_NONE << ERR_LIB_OFFSET | 256, | |
83 | "reason(256)")); | |
84 | # Reason code 0 of any library gives the library name as reason | |
85 | &ok(match_opensslerr_reason(ERR_LIB_NONE << ERR_LIB_OFFSET | 0, | |
86 | "unknown library")); | |
8e78da06 | 87 | &ok(match_any("Trailing whitespace \n\t", "?", ( "Trailing whitespace" ))); |
4b801fdc | 88 | |
1b726e9b | 89 | exit 0; |
7e47db5b RL |
90 | |
91 | # For an error string "error:xxxxxxxx:lib:func:reason", this returns | |
92 | # the following array: | |
93 | # | |
94 | # ( "xxxxxxxx", "lib", "func", "reason" ) | |
95 | sub split_error { | |
96 | # Limit to 5 items, in case the reason contains a colon | |
97 | my @erritems = split /:/, $_[0], 5; | |
98 | ||
99 | # Remove the first item, which is always "error" | |
100 | shift @erritems; | |
101 | ||
102 | return @erritems; | |
103 | } | |
1b726e9b RL |
104 | |
105 | # Compares the first argument as string to each of the arguments 3 and on, | |
106 | # and returns an array of two elements: | |
107 | # 0: True if the first argument matched any of the others, otherwise false | |
108 | # 1: A string describing the test | |
109 | # The returned array can be used as the arguments to Test::More::ok() | |
110 | sub match_any { | |
111 | my $first = shift; | |
112 | my $desc = shift; | |
113 | my @strings = @_; | |
114 | ||
8e78da06 SL |
115 | # ignore trailing whitespace |
116 | $first =~ s/\s+$//; | |
117 | ||
1b726e9b RL |
118 | if (scalar @strings > 1) { |
119 | $desc = "match '$first' ($desc) with one of ( '" | |
120 | . join("', '", @strings) . "' )"; | |
121 | } else { | |
122 | $desc = "match '$first' ($desc) with '$strings[0]'"; | |
123 | } | |
124 | ||
e7137c84 RL |
125 | return ( scalar( |
126 | grep { ref $_ eq 'Regexp' ? $first =~ $_ : $first eq $_ } | |
127 | @strings | |
128 | ) > 0, | |
1b726e9b RL |
129 | $desc ); |
130 | } | |
131 | ||
132 | sub match_opensslerr_reason { | |
133 | my $errcode = shift; | |
134 | my @strings = @_; | |
135 | ||
136 | my $errcode_hex = sprintf "%x", $errcode; | |
ffda5af3 DDO |
137 | my @res = run(app([ qw(openssl errstr), $errcode_hex ]), capture => 1); |
138 | return 0 unless $#res >= 0; | |
139 | my $reason = $res[0]; | |
1b726e9b RL |
140 | $reason =~ s|\R$||; |
141 | $reason = ( split_error($reason) )[3]; | |
142 | ||
e7313323 | 143 | return match_any($reason, $errcode_hex, @strings); |
1b726e9b RL |
144 | } |
145 | ||
146 | sub match_syserr_reason { | |
147 | my $errcode = shift; | |
148 | ||
149 | my @strings = (); | |
150 | # The POSIX reason string | |
151 | push @strings, eval { | |
152 | # Set $! to the error number... | |
153 | local $! = $errcode; | |
154 | # ... and $! will give you the error string back | |
155 | $! | |
156 | }; | |
e7137c84 RL |
157 | # Occasionally, we get an error code that is simply not translatable |
158 | # to POSIX semantics on VMS, and we get an error string saying so. | |
159 | push @strings, qr/^non-translatable vms error code:/ if $^O eq 'VMS'; | |
1b726e9b RL |
160 | # The OpenSSL fallback string |
161 | push @strings, "reason($errcode)"; | |
162 | ||
163 | return match_opensslerr_reason(ERR_SYSTEM_FLAG | $errcode, @strings); | |
164 | } |