Home | History | Annotate | Line # | Download | only in recipes 
      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 }
    165