log_environment

#! /usr/bin/perl

# Log the environment in which this script is running.
# Each entry in @ARGV is a program of interest, which is invoked with the
# --version option.

# Copyright (C) 2021 Free Software Foundation, Inc.

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

use v5.14;    # implicit use strict, use feature ':5.14'
use warnings FATAL => 'all';
use utf8;
use open qw(:utf8);

use Cwd qw(getcwd);
use FindBin ();
use POSIX ();

use lib $FindBin::Bin;
use BuildCommon qw(
    ensure_C_locale
    ensure_empty_stdin
    error
    get_status
    get_status_and_output
    run
    sh_quote
    which
);

# C library detection for Linux.  Algorithm from NPM package 'detect-libc',
# <https://github.com/lovell/detect-libc>; currently only supports GNU and
# musl libc.  If cross-compiling, the result is for the build environment,
# not the host or target.  Does not use a C compiler.
sub report_linux_libc {
    # Try getconf.
    my ($gcstat, @gcout) = get_status_and_output('getconf', 'GNU_LIBC_VERSION');
    if ($gcstat == 0) {
       my $gcver = $gcout[0];
       chomp $gcver;
       print "C library: $gcver\n\n";
       return;
    } elsif ($gcstat == -1) {
       print "getconf: command not found\n";
    }

    # Try ldd --version.
    my ($ldstat, @ldout) = get_status_and_output('ldd', '--version');
    if ($ldstat == 0 || $ldstat == 1) {
        my $ld1 = $ldout[0];
        my $ld2 = $ldout[1];
        if ($ld1 =~ /\bmusl\b/ia) {
            $ld2 =~ s/^version\s+(\S+).*$/$1/i;
            print "C library: musl $ld2\n\n";
            return;
        }
        if ($ld2 =~ /^copyright.*free software foundation/i) {
            $ld1 =~ s/^\S+\s+\([^\)]+\)\s+//;
            $ld1 =~ s/\s+\z//;
            print "C library: glibc $ld1\n\n";
            return;
        }

        print "WARNING: ldd --version output not recognized:\n";
        for my $line (@ldout) {
            print '> ', $line;
        }
        print "\n";

    } elsif ($ldstat == -1) {
        print "ldd: command not found\n";
    } else {
        print "WARNING: ldd --version exit $ldstat\n";
        for my $line (@ldout) {
            print '> ', $line;
        }
        print "\n";
    }

    # detect-libc goes on to poke around in /lib, which I don't think is
    # solid enough to base an actual detection on, but we may as well list
    # contents that may be relevant.
    print "C library: unknown\n\n";
    run("ls", "-l", glob('/lib*/{libc[.-],ld[-.]*.so}*'));
    print "\n";
}

sub report_machine {
    print "## Machine information:\n\n";

    my ($sysname, undef, $release, $version, $machine) = POSIX::uname();
    print '$(uname -m) = ', sh_quote($machine || 'unknown'), "\n";
    print '$(uname -r) = ', sh_quote($release || 'unknown'), "\n";
    print '$(uname -s) = ', sh_quote($sysname || 'unknown'), "\n";
    print '$(uname -v) = ', sh_quote($version || 'unknown'), "\n";
    print "\n";

    if ($sysname eq 'Linux') {
        report_linux_libc();

        my $npstat = get_status('nproc');
        if ($npstat != 0) {
            print "nproc: exit $npstat\n";
        }

    } elsif ($sysname eq 'FreeBSD') {
        run('sysctl', 'kern.sched.topology_spec');

    } else {
        print "WARNING: don't know how to probe #CPUs on this OS\n";
    }

    print "\n";
    my $cwd = getcwd();
    my $qcwd = sh_quote($cwd);
    print '$(pwd) = ', $qcwd, "\n";
    print "WARNING: working directory requires quotation\n"
        if $cwd ne $qcwd;
    print "\n";

    # -h = "human" scaled sizes (K, M, G, etc.)
    # -T = print filesystem type
    # These options are both nonstandard, so if this fails,
    # fall back to df -k (print sizes in kilobytes).  In that
    # case we won't get filesystem type information. Oh well.
    my $dfstat = get_status(qw(df -h -T), $cwd);
    if ($dfstat != 0) {
        print "df -h -T: exit $dfstat\n";
        $dfstat = get_status(qw(df -k), $cwd);
        if ($dfstat != 0) {
            print "df -k: exit $dfstat\n";
        }
    }
    print "\n";
}

sub report_ENV {
    my $envp = $_[0];
    print "## Environment variables:\n\n";
    for my $key (sort keys %$envp) {
        print '  ', sh_quote($key), '=', sh_quote($envp->{$key}), "\n";
    }
    print "\n";
}

sub report_programs {
    print "## Programs used during build:\n\n";

    for my $prog (@_) {
        my ($absprog) = which($prog);
        if ($absprog) {
            print sh_quote($prog), ' is ', sh_quote($absprog), "\n";

            # Try various options that might get a program to print its
            # version number, in order of likelihood.
            # mawk only recognizes -Wversion
            # -qversion is in AC_PROG_CC's list of things to try
            for my $vopt (qw(--version -V -v -Wversion -qversion)) {
                my $status = get_status($absprog, $vopt);
                last if $status == 0;
                if ($status == -1) {
                    # 'no such file or directory' doesn't make sense here
                    print "$absprog $vopt: exit 126\n";
                } else {
                    print "$absprog $vopt: exit $status\n";
                }
            }
        } else {
            print "WARNING: $prog not found in \$PATH\n";
        }
        print "\n";
    }
}

sub main {
    my %orig_env = %ENV;
    ensure_C_locale();
    ensure_empty_stdin();
    STDOUT->autoflush(1);
    STDERR->autoflush(1);

    print "# CI environment report\n";
    report_machine();
    report_ENV(\%orig_env);
    report_programs(@_) if scalar(@_);
};

eval {
    main(@ARGV);
    exit(0);
};
error("$@");