]>
Commit | Line | Data |
---|---|---|
0eed845c | 1 | #! {- $config{HASHBANGPERL} -} |
285e2991 RL |
2 | |
3 | use strict; | |
4 | use warnings; | |
5 | ||
6 | use File::Basename; | |
7 | use File::Spec::Functions; | |
8 | ||
0eed845c RL |
9 | BEGIN { |
10 | # This method corresponds exactly to 'use OpenSSL::Util', | |
11 | # but allows us to use a platform specific file spec. | |
12 | require {- | |
13 | use Cwd qw(abs_path); | |
14 | ||
15 | "'" . abs_path(catfile($config{sourcedir}, | |
16 | 'util', 'perl', 'OpenSSL', 'Util.pm')) . "'"; | |
17 | -}; | |
18 | OpenSSL::Util->import(); | |
19 | } | |
20 | ||
285e2991 RL |
21 | my $there = canonpath(catdir(dirname($0), updir())); |
22 | my $std_engines = catdir($there, 'engines'); | |
23 | my $std_providers = catdir($there, 'providers'); | |
3ab736ac | 24 | my $std_openssl_conf = catdir($there, 'apps/openssl.cnf'); |
285e2991 RL |
25 | my $unix_shlib_wrap = catfile($there, 'util/shlib_wrap.sh'); |
26 | ||
4e20d04e P |
27 | if ($ARGV[0] eq '-fips') { |
28 | $std_openssl_conf = {- | |
29 | use Cwd qw(abs_path); | |
30 | ||
31 | "'" . abs_path(catfile($config{sourcedir}, 'test/fips-and-base.cnf')) . "'"; | |
32 | -}; | |
33 | shift; | |
34 | ||
35 | my $std_openssl_conf_include = catdir($there, 'providers'); | |
36 | $ENV{OPENSSL_CONF_INCLUDE} = $std_openssl_conf_include | |
37 | if ($ENV{OPENSSL_CONF_INCLUDE} // '') eq '' | |
38 | && -d $std_openssl_conf_include; | |
39 | } | |
40 | ||
285e2991 RL |
41 | $ENV{OPENSSL_ENGINES} = $std_engines |
42 | if ($ENV{OPENSSL_ENGINES} // '') eq '' && -d $std_engines; | |
43 | $ENV{OPENSSL_MODULES} = $std_providers | |
44 | if ($ENV{OPENSSL_MODULES} // '') eq '' && -d $std_providers; | |
3ab736ac DMSP |
45 | $ENV{OPENSSL_CONF} = $std_openssl_conf |
46 | if ($ENV{OPENSSL_CONF} // '') eq '' && -f $std_openssl_conf; | |
285e2991 RL |
47 | |
48 | my $use_system = 0; | |
49 | my @cmd; | |
50 | ||
0eed845c RL |
51 | if ($^O eq 'VMS') { |
52 | # VMS needs the command to be appropriately quotified | |
53 | @cmd = fixup_cmd(@ARGV); | |
54 | } elsif (-x $unix_shlib_wrap) { | |
285e2991 RL |
55 | @cmd = ( $unix_shlib_wrap, @ARGV ); |
56 | } else { | |
57 | # Hope for the best | |
58 | @cmd = ( @ARGV ); | |
59 | } | |
60 | ||
61 | # The exec() statement on MSWin32 doesn't seem to give back the exit code | |
62 | # from the call, so we resort to using system() instead. | |
63 | my $waitcode = system @cmd; | |
64 | ||
65 | # According to documentation, -1 means that system() couldn't run the command, | |
66 | # otherwise, the value is similar to the Unix wait() status value | |
67 | # (exitcode << 8 | signalcode) | |
68 | die "wrap.pl: Failed to execute '", join(' ', @cmd), "': $!\n" | |
69 | if $waitcode == -1; | |
5f1adadc | 70 | |
bf16ee4f | 71 | # When the subprocess aborted on a signal, we simply raise the same signal. |
ef6d6e45 | 72 | kill(($? & 255) => $$) if ($? & 255) != 0; |
bf16ee4f RL |
73 | |
74 | # If that didn't stop this script, mimic what Unix shells do, by | |
5f1adadc RL |
75 | # converting the signal code to an exit code by setting the high bit. |
76 | # This only happens on Unix flavored operating systems, the others don't | |
77 | # have this sort of signaling to date, and simply leave the low byte zero. | |
78 | exit(($? & 255) | 128) if ($? & 255) != 0; | |
79 | ||
80 | # When not a signal, just shift down the subprocess exit code and use that. | |
a515c825 RL |
81 | my $exitcode = $? >> 8; |
82 | ||
83 | # For VMS, perl recommendations is to emulate what the C library exit() does | |
84 | # for all non-zero exit codes, except we set the error severity rather than | |
85 | # success. | |
86 | # Ref: https://perldoc.perl.org/perlport#exit | |
87 | # https://perldoc.perl.org/perlvms#$? | |
88 | if ($^O eq 'VMS' && $exitcode != 0) { | |
89 | $exitcode = | |
90 | 0x35a000 # C facility code | |
91 | + ($exitcode * 8) # shift up to make space for the 3 severity bits | |
92 | + 2 # Severity: E(rror) | |
93 | + 0x10000000; # bit 28 set => the shell stays silent | |
94 | } | |
95 | exit($exitcode); |