1#! /usr/bin/env perl 2# Copyright 2018-2021 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 $reason = 138 ( run(app([ qw(openssl errstr), $errcode_hex ]), capture => 1) )[0]; 139 $reason =~ s|\R$||; 140 $reason = ( split_error($reason) )[3]; 141 142 return match_any($reason, $errcode_hex, @strings); 143} 144 145sub match_syserr_reason { 146 my $errcode = shift; 147 148 my @strings = (); 149 # The POSIX reason string 150 push @strings, eval { 151 # Set $! to the error number... 152 local $! = $errcode; 153 # ... and $! will give you the error string back 154 $! 155 }; 156 # Occasionally, we get an error code that is simply not translatable 157 # to POSIX semantics on VMS, and we get an error string saying so. 158 push @strings, qr/^non-translatable vms error code:/ if $^O eq 'VMS'; 159 # The OpenSSL fallback string 160 push @strings, "reason($errcode)"; 161 162 return match_opensslerr_reason(ERR_SYSTEM_FLAG | $errcode, @strings); 163} 164