# SPDX-License-Identifier: GPL-2.0-or-later

package Amavis::Boot;
use strict;
use re 'taint';
use Errno qw(ENOENT EACCES);

# replacement for a 'require' with a more informative error handling
#sub my_require($) {
# my $filename = $_[0];
# my $result;
# if (exists $INC{$filename} && !$INC{$filename}) {
#   die "Compilation failed in require\n";
# } elsif (exists $INC{$filename}) {
#   $result = 1;  # already loaded
# } else {
#   my $found = 0;
#   for my $prefix (@INC) {
#     my $full_fname = "$prefix/$filename";
#     my(@stat_list) = stat($full_fname);  # symlinks-friendly
#     my $errn = @stat_list ? 0 : 0+$!;
#     if ($errn != ENOENT) {
#       $found = 1;
#       $INC{$filename} = $full_fname;
#       my $owner_uid = $stat_list[4];
#       my $msg;
#       if ($errn)         { $msg = "is inaccessible: $!" }
#       elsif (-d _)       { $msg = "is a directory" }
#       elsif (!-f _)      { $msg = "is not a regular file" }
#       elsif ($> && -o _) { $msg = "should not be owned by EUID $>"  }
#       elsif ($> && -w _) { $msg = "is writable by EUID $>, EGID $)" }
#       elsif ($owner_uid) { $msg = "should be owned by root (uid 0) "}
#       !defined($msg) or die "Requiring $full_fname, file $msg,\n";
#       $! = 0;
#       $result = do $full_fname;
#       if (!defined($result) && $@ ne '') {
#         undef $INC{$filename}; chomp($@);
#         die "Error in file $full_fname: $@\n";
#       } elsif (!defined($result) && $! != 0) {
#         undef $INC{$filename};
#         die "Error reading file $full_fname: $!\n";
#       } elsif (!$result) {
#         undef $INC{$filename};
#         die "Module $full_fname did not return a true value\n";
#       }
#       last;
#     }
#   }
#   die sprintf("my_require: Can't locate %s in \@INC (\@INC contains: %s)\n",
#               $filename, join(' ',@INC))  if !$found;
# }
# $result;
#}

# Fetch all required modules (or nicely report missing ones), and compile them
# once-and-for-all at the parent process, so that forked children can inherit
# and share already compiled code in memory. Children will still need to 'use'
# modules if they want to inherit from their name space.
#
sub fetch_modules($$@) {
  my($reason, $required, @modules) = @_;
  my(@missing);
  for my $m (@modules) {
    if (ref $m eq 'ARRAY') {
        # interpret as alternatives
        my $missing = fetch_modules($reason, 0, @$m);
        if (@$missing == @$m) {
            local $" = ' | ';
            push @missing, "(@$missing)";
        }
        next
    }
    local $_ = $m;
    $_ .= /^auto::/ ? '.al' : '.pm'  if !m{^/} && !m{\.(?:pm|pl|al|ix)\z};
    s{::}{/}g;
    eval {
      require $_;
    # my_require $_;  # more informative on err, but some problems reported
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      push(@missing,$m);
      $eval_stat =~ s/^/  /gms;  # indent
      printf STDERR ("fetch_modules: error loading %s module %s:\n%s\n",
                     $required ? 'required' : 'optional',  $_, $eval_stat)
        if $eval_stat !~ /\bCan't locate \Q$_\E in \@INC\b/;
    };
  }
  die "ERROR: MISSING $reason:\n" . join('', map("  $_\n", @missing))
    if $required && @missing;
  \@missing;
}

BEGIN {
  if ($] <= 5.008) {  # deal with a glob() taint bug (perl 5.6.1, 5.8.0)
    fetch_modules('REQUIRED BASIC MODULES', 1, qw(File::Glob));
    File::Glob->import(':globally');  # use the same module as Perl 5.8 uses
  }
  fetch_modules('REQUIRED BASIC MODULES', 1, qw(
    Exporter POSIX Fcntl Socket Errno Carp Time::HiRes
    IO::Handle IO::File IO::Socket IO::Socket::UNIX
    Digest::MD5 Unix::Syslog File::Basename
    Compress::Zlib MIME::Base64 MIME::QuotedPrint MIME::Words
    MIME::Head MIME::Body MIME::Entity MIME::Parser MIME::Decoder
    MIME::Decoder::Base64 MIME::Decoder::Binary MIME::Decoder::QuotedPrint
    MIME::Decoder::NBit MIME::Decoder::UU MIME::Decoder::Gzip64
    Net::Server Net::Server::PreFork
  ), [qw[Net::LibIDN2 Net::LibIDN]]);
  # with earlier versions of Perl one may need to add additional modules
  # to the list, such as: auto::POSIX::setgid auto::POSIX::setuid ...
  fetch_modules('OPTIONAL BASIC MODULES', 0, qw(
    PerlIO PerlIO::scalar Unix::Getrusage
    Carp::Heavy auto::POSIX::setgid auto::POSIX::setuid
    auto::POSIX::SigAction::new auto::POSIX::SigAction::safe
    MIME::Decoder::BinHex
  ));
  1;
}

1;