Home | History | Annotate | Line # | Download | only in util 
      1 #! {- $config{HASHBANGPERL} -}
      2 
      3 use strict;
      4 use warnings;
      5 
      6 use File::Basename;
      7 use File::Spec::Functions;
      8 
      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 
     21 sub quote_cmd_win32 {
     22     my $cmd = "";
     23 
     24     foreach my $arg (@_) {
     25         if ($arg =~ m{\A[\w,-./@]+\z}) {
     26             $cmd .= $arg . q{ };;
     27         } else {
     28             $cmd .= q{"} . quote_arg_win32($arg) . q{" };
     29         }
     30     }
     31     return substr($cmd, 0, -1);
     32 }
     33 
     34 sub quote_arg_win32 {
     35     my ($arg) = @_;
     36     my $val = "";
     37 
     38     pos($arg) = 0;
     39     while (1) {
     40         return $val if (pos($arg) == length($arg));
     41         if ($arg =~ m{\G((?:(?>[\\]*)[^"\\]+)+)}ogc) {
     42             $val .= $1;
     43         } elsif ($arg =~ m{\G"}ogc) {
     44             $val .= qq{\\"};
     45         } elsif ($arg =~ m{\G((?>[\\]+)(?="|\z))}ogc) {
     46             $val .= qq{\\} x (2 * length($1));
     47         } else {
     48             die sprintf("Internal error quoting: '%s'\n", $arg);
     49         }
     50     }
     51 }
     52 
     53 my $there = canonpath(catdir(dirname($0), updir()));
     54 my $std_engines = catdir($there, 'engines');
     55 my $std_providers = catdir($there, 'providers');
     56 my $std_openssl_conf = catdir($there, 'apps/openssl.cnf');
     57 my $unix_shlib_wrap = catfile($there, 'util/shlib_wrap.sh');
     58 my $std_openssl_conf_include;
     59 
     60 if ($ARGV[0] eq '-fips') {
     61     $std_openssl_conf = {-
     62          use Cwd qw(abs_path);
     63 
     64          "'" . abs_path(catfile($config{sourcedir}, 'test/fips-and-base.cnf')) . "'";
     65          -};
     66     shift;
     67 
     68     $std_openssl_conf_include = catdir($there, 'providers');
     69 }
     70 
     71 if ($ARGV[0] eq '-jitter') {
     72     $std_openssl_conf = {-
     73          use Cwd qw(abs_path);
     74 
     75          "'" . abs_path(catfile($config{sourcedir}, 'test/default-and-jitter.cnf')) . "'";
     76          -};
     77     shift;
     78 
     79     $std_openssl_conf_include = catdir($there, 'providers');
     80 }
     81 
     82 
     83 local $ENV{OPENSSL_CONF_INCLUDE} = $std_openssl_conf_include
     84     if defined $std_openssl_conf_include
     85        &&($ENV{OPENSSL_CONF_INCLUDE} // '') eq ''
     86        && -d $std_openssl_conf_include;
     87 local $ENV{OPENSSL_ENGINES} = $std_engines
     88     if ($ENV{OPENSSL_ENGINES} // '') eq '' && -d $std_engines;
     89 local $ENV{OPENSSL_MODULES} = $std_providers
     90     if ($ENV{OPENSSL_MODULES} // '') eq '' && -d $std_providers;
     91 local $ENV{OPENSSL_CONF} = $std_openssl_conf
     92     if ($ENV{OPENSSL_CONF} // '') eq '' && -f $std_openssl_conf;
     93 {-
     94      # For VMS, we define logical names to get the libraries properly
     95      # defined.
     96      use File::Spec::Functions qw(rel2abs);
     97 
     98      if ($^O eq "VMS") {
     99          my $bldtop = rel2abs($config{builddir});
    100          my %names =
    101              map { platform->sharedname($_) => $bldtop.platform->sharedlib($_) }
    102              grep { !$unified_info{attributes}->{libraries}->{$_}->{noinst} }
    103              @{$unified_info{libraries}};
    104 
    105          foreach (sort keys %names) {
    106              $OUT .= "local \$ENV\{'$_'\} = '$names{$_}';\n";
    107          }
    108      }
    109 -}
    110 my $use_system = 0;
    111 my @cmd;
    112 
    113 if ($^O eq 'VMS') {
    114     # VMS needs the command to be appropriately quotified
    115     @cmd = fixup_cmd(@ARGV);
    116 } elsif (-x $unix_shlib_wrap) {
    117     @cmd = ( $unix_shlib_wrap, @ARGV );
    118 } else {
    119     # Hope for the best
    120     @cmd = ( @ARGV );
    121 }
    122 
    123 # The exec() statement on MSWin32 doesn't seem to give back the exit code
    124 # from the call, so we resort to using system() instead.
    125 my $waitcode;
    126 if ($^O eq 'MSWin32') {
    127     $waitcode = system(quote_cmd_win32(@cmd));
    128 } else {
    129     $waitcode = system @cmd;
    130 }
    131 
    132 # According to documentation, -1 means that system() couldn't run the command,
    133 # otherwise, the value is similar to the Unix wait() status value
    134 # (exitcode << 8 | signalcode)
    135 die "wrap.pl: Failed to execute '", join(' ', @cmd), "': $!\n"
    136     if $waitcode == -1;
    137 
    138 # When the subprocess aborted on a signal, we simply raise the same signal.
    139 kill(($? & 255) => $$) if ($? & 255) != 0;
    140 
    141 # If that didn't stop this script, mimic what Unix shells do, by
    142 # converting the signal code to an exit code by setting the high bit.
    143 # This only happens on Unix flavored operating systems, the others don't
    144 # have this sort of signaling to date, and simply leave the low byte zero.
    145 exit(($? & 255) | 128) if ($? & 255) != 0;
    146 
    147 # When not a signal, just shift down the subprocess exit code and use that.
    148 my $exitcode = $? >> 8;
    149 
    150 # For VMS, perl recommendations is to emulate what the C library exit() does
    151 # for all non-zero exit codes, except we set the error severity rather than
    152 # success.
    153 # Ref: https://perldoc.perl.org/perlport#exit
    154 #      https://perldoc.perl.org/perlvms#$?
    155 if ($^O eq 'VMS' && $exitcode != 0) {
    156     $exitcode =
    157         0x35a000                # C facility code
    158         + ($exitcode * 8)       # shift up to make space for the 3 severity bits
    159         + 2                     # Severity: E(rror)
    160         + 0x10000000;           # bit 28 set => the shell stays silent
    161 }
    162 exit($exitcode);
    163