xref: /openssl/test/recipes/02-test_errstr.t (revision b6461792)
1#! /usr/bin/env perl
2# Copyright 2018-2024 The OpenSSL Project Authors. All Rights Reserved.
3#
4# Licensed under the Apache License 2.0 (the "License").  You may not use
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
9use strict;
10no strict 'refs';               # To be able to use strings as function refs
11use OpenSSL::Test;
12use OpenSSL::Test::Utils;
13use Errno qw(:POSIX);
14use POSIX qw(:limits_h strerror);
15
16use Data::Dumper;
17
18setup('test_errstr');
19
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.
25plan skip_all => 'This is unsupported for cross compiled configurations'
26    if config('CROSS_COMPILE');
27
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.
31plan skip_all => 'This is unsupported on MSYS/MinGW or MSWin32'
32    if $^O eq 'msys' or $^O eq 'MSWin32';
33
34plan skip_all => 'OpenSSL is configured "no-autoerrinit" or "no-err"'
35    if disabled('autoerrinit') || disabled('err');
36
37# OpenSSL constants found in <openssl/err.h>
38use constant ERR_SYSTEM_FLAG => INT_MAX + 1;
39use constant ERR_LIB_OFFSET => 23; # Offset of the "library" errcode section
40
41# OpenSSL "library" numbers
42use constant ERR_LIB_NONE => 1;
43
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
49plan tests => scalar @Errno::EXPORT_OK
50    +1                          # Checking that error 128 gives 'reason(128)'
51    +1                          # Checking that error 0 gives the library name
52    +1;                         # Check trailing whitespace is removed.
53
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
57foreach 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.
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;
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;
76
77      &ok(match_syserr_reason($errcode));
78    }
79}
80
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"));
87&ok(match_any("Trailing whitespace  \n\t", "?", ( "Trailing whitespace" )));
88
89exit 0;
90
91# For an error string "error:xxxxxxxx:lib:func:reason", this returns
92# the following array:
93#
94# ( "xxxxxxxx", "lib", "func", "reason" )
95sub 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}
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()
110sub match_any {
111    my $first = shift;
112    my $desc = shift;
113    my @strings = @_;
114
115    # ignore trailing whitespace
116    $first =~ s/\s+$//;
117
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
125    return ( scalar(
126                 grep { ref $_ eq 'Regexp' ? $first =~ $_ : $first eq $_ }
127                 @strings
128             ) > 0,
129             $desc );
130}
131
132sub match_opensslerr_reason {
133    my $errcode = shift;
134    my @strings = @_;
135
136    my $errcode_hex = sprintf "%x", $errcode;
137    my @res = run(app([ qw(openssl errstr), $errcode_hex ]), capture => 1);
138    return 0 unless $#res >= 0;
139    my $reason = $res[0];
140    $reason =~ s|\R$||;
141    $reason = ( split_error($reason) )[3];
142
143    return match_any($reason, $errcode_hex, @strings);
144}
145
146sub 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    };
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';
160    # The OpenSSL fallback string
161    push @strings, "reason($errcode)";
162
163    return match_opensslerr_reason(ERR_SYSTEM_FLAG | $errcode, @strings);
164}
165