test/recipes/02-test_errstr.t

   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
   9 use strict;
  10 no strict 'refs';               # To be able to use strings as function refs
  11 use OpenSSL::Test;
  12 use OpenSSL::Test::Utils;
  13 use Errno qw(:POSIX);
  14 use POSIX qw(:limits_h strerror);
  15
  16 use Data::Dumper;
  17
  18 setup('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.
  25 plan 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.
  31 plan skip_all => 'This is unsupported on MSYS/MinGW or MSWin32'
  32     if $^O eq 'msys' or $^O eq 'MSWin32';
  33
  34 plan 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>
  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;
  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
  49 plan 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
  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.
  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
  89 exit 0;
  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 }
 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
 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
 132 sub 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
 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     };
 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 }