path: root/BuildCommon.pm

# Written by Zack Weinberg <zackw at panix.com> in 2017, 2020, 2021.
# To the extent possible under law, Zack Weinberg has waived all
# copyright and related or neighboring rights to this work.
#
# See https://creativecommons.org/publicdomain/zero/1.0/ for further
# details.

package BuildCommon;

use v5.14;    # implicit use strict, use feature ':5.14'
use warnings FATAL => 'all';
use utf8;
use open qw(:utf8);
no  if $] >= 5.018, warnings => 'experimental::smartmatch';
no  if $] >= 5.022, warnings => 'experimental::re_strict';
use if $] >= 5.022, re       => 'strict';

use Cwd qw(realpath);
use File::Spec::Functions qw(
    catfile
    catpath
    file_name_is_absolute
    path
    splitpath
);
use FindBin ();
use POSIX   ();

our @EXPORT_OK;
use Exporter qw(import);

BEGIN {
    @EXPORT_OK = qw(
        ensure_C_locale
        ensure_empty_stdin
        error
        get_status
        get_status_and_output
        popen
        run
        sh_split
        sh_quote
        subprocess_error
        which
    );
}

#
# Utilities for dealing with subprocesses.
#

# Diagnostics: report some kind of catastrophic internal error.
# Exit code 99 tells the Automake test driver to mark a test as
# 'errored' rather than 'failed'.
sub error {    ## no critic (Subroutines::RequireArgUnpacking)
    my $msg = join q{ }, @_;
    print {*STDERR} $FindBin::Script, ': ERROR: ', $msg, "\n";
    exit 99;
}

# Like 'error', but the problem was with a subprocess, detected upon
# trying to start the program named as @_.
sub invocation_error {    ## no critic (Subroutines::RequireArgUnpacking)
    my $err = "$!";
    my $cmd = join q{ }, @_;
    error("failed to invoke $cmd: $err");
}

# Like 'error', but the problem was with a subprocess, detected upon
# termination of the program named as @_; interpret both $! and $?
# appropriately.
sub subprocess_error {    ## no critic (Subroutines::RequireArgUnpacking)
    my $syserr = $!;
    my $status = $?;
    my $cmd    = join q{ }, @_;
    if ($syserr) {
        error("system error with $cmd: $syserr");

    } elsif ($status == 0) {
        return;

    } elsif (($status & 0xFF) == 0) {
        # we wouldn't be here if the exit status was zero
        error("$cmd: exit " . ($status >> 8));

    } else {
        my $sig = ($status & 0x7F);
        # Neither Perl core nor the POSIX module exposes strsignal.
        # This is the least terrible kludge I can presently find;
        # it decodes the numbers to their <signal.h> constant names
        # (e.g. "SIGKILL" instead of "Killed" for signal 9).
        # Linear search through POSIX's hundreds of symbols is
        # acceptable because this function terminates the process,
        # so it can only ever be called once per run.
        my $signame;
        while (my ($name, $glob) = each %{'POSIX::'}) {
            if ($name =~ /^SIG(?!_|RT)/ && (${$glob} // -1) == $sig) {
                $signame = $name;
                last;
            }
        }
        $signame //= "signal $sig";
        error("$cmd: killed by $signame");
    }
}

# Split a string into words, exactly the way the Bourne shell would do
# it, with the default setting of IFS, when the string is the result
# of a variable expansion.  If any of the resulting words would be
# changed by filename expansion, throw an exception, otherwise return
# a list of the words.
#
# Note: the word splitting process does *not* look for nested
# quotation, substitutions, or operators.  For instance, if a
# shell variable was set with
#    var='"ab cd"'
# then './a.out $var' would pass two arguments to a.out:
# '"ab' and 'cd"'.
sub sh_split {
    my @words = split /[ \t\n]+/, shift;
    for my $w (@words) {
        die "sh_split: '$w' could be changed by filename expansion"
            if $w =~ / (?<! \\) [\[?*] /ax;
    }
    return @words;
}

# Quote a string, or list of strings, so that they will pass
# unmolested through the shell.  Avoids adding quotation whenever
# possible.  Algorithm copied from Python's shlex.quote.
sub sh_quote {    ## no critic (Subroutines::RequireArgUnpacking)
    my @quoted;
    for my $w (@_) {
        if ($w =~ m{[^\w@%+=:,./-]}a) {
            my $q = $w;
            $q =~ s/'/'\\''/g;
            $q =~ s/^/'/;
            $q =~ s/$/'/;
            push @quoted, $q;
        } else {
            push @quoted, $w;
        }
    }
    return wantarray ? @quoted : $quoted[0];
}

# Emit a logging message for the execution of a subprocess whose
# argument vector is @_.
sub log_execution {    ## no critic (Subroutines::RequireArgUnpacking)
    print {*STDERR} '+ ', join(q{ }, sh_quote(@_)), "\n";
    return;
}

# Run, and log execution of, a subprocess, with no I/O redirection.
# @_ should be an argument vector.
# Calls invocation_error() and/or subprocess_error() as appropriate.
# Does *not* call which(); do that yourself if you need it.
sub run {    ## no critic (Subroutines::RequireArgUnpacking)
    die 'run: no command to execute'
        if scalar(@_) == 0;
    log_execution(@_);

    my $pid = fork
        // invocation_error($_[0]);

    if ($pid == 0) {
        # child
        { exec {$_[0]} @_; };
        print {*STDERR} "exec $_[0] failed: $!\n";
        exit(127);
    }

    # parent
    waitpid $pid, 0;
    undef $!;
    subprocess_error(@_) if $?;
}

# Run, and log execution of, a subprocess.  @_ should be one of the
# open modes that creates a pipe, followed by an argument vector.
# An anonymous filehandle for the pipe is returned.
# Calls invocation_error() if open() fails.
# Does *not* call which(); do that yourself if you need it.
sub popen {
    my ($mode, @args) = @_;
    die "popen: inappropriate mode argument '$mode'"
        unless $mode eq '-|' || $mode eq '|-';
    die 'popen: no command to execute'
        if scalar(@args) == 0;

    log_execution(@args);
    open my $fh, $mode, @args
        or invocation_error($args[0]);
    return $fh;
}

# Run, and log execution of, a subprocess.  @_ should be an argument vector.
# If the subprocess exits normally (successful or unsuccessful),
# returns the exit status.
# If the subprocess could not be started because there is no such command,
# returns -1.
# Otherwise invocation_error/subprocess_error are called as appropriate.
sub get_status {
    die 'run: no command to execute'
        if scalar(@_) == 0;
    log_execution(@_);

    my $pid = fork
        // invocation_error($_[0]);

    if ($pid == 0) {
        # child
        { exec {$_[0]} @_; };
        exit(126) if $!{ENOENT};
        print {*STDERR} "exec $_[0] failed: $!\n";
        exit(127);
    }

    # parent
    waitpid $pid, 0;
    undef $!;
    if ($? == 0x7F00 || ($? & 0x7F) != 0) {
        subprocess_error(@_);
    }
    my $status = $? >> 8;
    return -1 if $status == 126;
    return $status;
}

# Run, and log execution of, a subprocess.  Capture all of its output,
# including both stdout and stderr.
# @_ should be an argument vector.
# If the subprocess exits normally (successful or unsuccessful),
# returns a list whose first element is the exit status, followed by
# all the lines of output from the subprocess (stdout and stderr are
# intermingled).
# If the subprocess could not be started because there is no such command,
# returns (-1,).
# Otherwise invocation_error/subprocess_error are called as appropriate.
sub get_status_and_output {
    die 'get_status_and_output: no command to execute'
        if scalar(@_) == 0;
    log_execution(@_);

    my $pid = open(my $fh, '-|')
        // invocation_error($_[0]);

    if ($pid == 0) {
        # child
        open(STDERR, ">&STDOUT") or do {
            print {*STDERR} "Can't dup STDOUT: $!\n";
            exit(127);
        };
        { exec {$_[0]} @_; };
        exit(126) if $!{ENOENT};
        print {*STDERR} "exec $_[0] failed: $!\n";
        exit(127);
    }

    # parent
    my @lines = <$fh>;
    close $fh or do {
        if ($! != 0 || ($? & 0x7F) != 0) {
            subprocess_error(@_);
        }
    };
    my $status = $? >> 8;
    if ($status == 127) {
        subprocess_error(@_);
    }
    if ($status == 126) {
        $status = -1;
    }
    return ($status, @lines);
}

# Force use of the C locale for this process and all subprocesses.
# This is necessary because subprocesses' output may be locale-
# dependent.  If the C.UTF-8 locale is available, it is used,
# otherwise the plain C locale.  Note that we do *not*
# 'use locale' here or anywhere else!
sub ensure_C_locale {
    use POSIX qw(setlocale LC_ALL);

    for my $k (keys %ENV) {
        if ($k eq 'LANG' || $k eq 'LANGUAGE' || $k =~ /^LC_/) {
            delete $ENV{$k};
        }
    }
    if (defined(setlocale(LC_ALL, 'C.UTF-8'))) {
        $ENV{LC_ALL} = 'C.UTF-8'; ## no critic (RequireLocalizedPunctuationVars)
    } elsif (defined(setlocale(LC_ALL, 'C'))) {
        $ENV{LC_ALL} = 'C';       ## no critic (RequireLocalizedPunctuationVars)
    } else {
        error("could not set 'C' locale: $!");
    }
    return;
}

# Close standard input at the OS level and reopen it on /dev/null.
# This ensures that no subprocesses will get stuck trying to read from
# standard input.
sub ensure_empty_stdin {
    use POSIX qw(open close dup2 O_RDONLY);
    my $fd = open('/dev/null', O_RDONLY) // die "open('/dev/null'): $!\n";
    dup2($fd, 0) // die("dup2($fd, 0): $!\n");
    close($fd);
}

# Clean up $ENV{PATH}, and return the cleaned path as a list.
sub clean_PATH {
    state @path;
    if (!@path) {
        for my $d (path()) {
            # Discard all entries that are not absolute paths.
            next unless file_name_is_absolute($d);
            # Discard all entries that are not directories, or don't
            # exist.  (This is not just for tidiness; realpath()
            # behaves unpredictably if called on a nonexistent
            # pathname.)
            next unless -d $d;
            # Resolve symlinks in all remaining entries.
            $d = realpath($d);
            # Discard duplicates.
            push @path, $d unless grep { $_ eq $d } @path;
        }
        error('nothing left after cleaning PATH')
            unless @path;

        # File::Spec knows internally whether $PATH is colon-separated
        # or semicolon-separated, but it won't tell us.  Assume it's
        # colon-separated unless the first element of $PATH has a
        # colon in it (and is therefore probably a DOS-style absolute
        # path, with a drive letter).
        my $newpath;
        if ($path[0] =~ /:/) {
            $newpath = join ';', @path;
        } else {
            $newpath = join ':', @path;
        }
        $ENV{PATH} = $newpath;    ## no critic (RequireLocalizedPunctuationVars)
    }
    return @path;
}

# Locate a program that we need.
# $_[0] is the name of the program along with any options that are
# required to use it correctly.  Split this into an argument list,
# exactly as /bin/sh would do it, and then search $PATH for the
# executable.  If we find it, return a list whose first element is
# the absolute pathname of the executable, followed by any options.
# Otherwise return an empty list.
sub which {
    my ($command) = @_;
    my @PATH = clean_PATH();

    # Split the command name from any options attached to it.
    my ($cmd, @options) = sh_split($command);
    my ($vol, $path, $file) = splitpath($cmd);

    if ($file eq 'false') {
        # Special case: the command 'false' is never considered to be
        # available.  Autoconf sets config variables like $CC and $NM to
        # 'false' if it can't find the requested tool.
        return ();

    } elsif ($file ne $cmd) {
        # $cmd was not a bare filename.  Do not do path search, but do
        # verify that $cmd exists and is executable, then convert it
        # to a canonical absolute path.
        #
        # Note: the result of realpath() is unspecified if its
        # argument does not exist, so we must test its existence
        # first.
        #
        # Note: if $file is a symlink, we must *not* resolve that
        # symlink, because that may change the name of the program,
        # which in turn may change what the program does.
        # For instance, suppose $CC is /usr/lib/ccache/cc, and this
        # 'cc' is a symlink to /usr/bin/ccache.  Resolving the symlink
        # will cause ccache to be invoked as 'ccache' instead of 'cc'
        # and it will error out because it's no longer being told
        # it's supposed to run the compiler.
        if (-f -x $cmd) {
            return (catfile(realpath(catpath($vol, $path, q{})), $file),
                @options);
        } else {
            return ();
        }

    } else {
        for my $d (@PATH) {
            my $cand = catfile($d, $cmd);
            if (-f -x $cand) {
                # @PATH came from clean_PATH, so all of the directories
                # have already been canonicalized.  If the last element
                # of $cand is a symlink, we should *not* resolve it (see
                # above).  Therefore, we do not call realpath here.
                return ($cand, @options);
            }
        }
        return ();

    }
}

1;