#  $HeadURL$ $LastChangedRevision$

#  Name of this module
package ADE;

########################################################################
#
#  Modules
#
########################################################################

use strict;
use warnings;
use Tie::RefHash;
use Cwd;
use Data::Dumper;
use Net::SMTP;
use IO::Handle;
use Sys::Syslog qw(:standard :macros);
use Getopt::Long;
Getopt::Long::Configure ('bundling', 'require_order');  #  immediately enable bundling (i.e. '-vax' is allowed and the same as '-v -a -x')
use POSIX;
use DBI;
use UUID;
use Time::HiRes;
use Sys::Hostname;
use File::Path;
use Fatal qw( close unlink );  #  obviate checking close()'s return code
use experimental 'smartmatch';

########################################################################
#
#  Characteristics of this module
#
########################################################################

#  Declare exports
BEGIN {
    use base qw( Exporter );
    #  This list was generated by trimming: egrep '^(our|sub [^_])' ADE.pm 
    our @EXPORT_OK = qw($OK $FAIL main set_messaging_parameters register_error_types display_error_stack internal error warning info debug encode_z decode_z extract_version validate_regexp show_help show_bad_usage show_version show_paths ask_question get_absolute_path check_readable check_writable create_uuid read_uuid write_uuid validate_uuid open_compressed_file_for_reading open_compressed_file_for_writing get_md5sum register_options process_options manage_rolling_status manage_cache fork_multi evaler register_exit_function deregister_exit_function register_temp_file deregister_temp_file execute_sql select_sql select_sql_count execute_sql_qm select_sql_qm select_sql_count_qm begin_sql_transaction end_sql_transaction assert_inside_sql_transaction assert_outside_sql_transaction connect_sqlite initialise_sqlite validate_sql_schema_version get_sql_schema_version set_sql_schema_version edit_sqlite upgrade_database lock unlock move_compressed_file get_progname get_simulate get_verboselevel set_progname set_simulate set_verboselevel set_callbacks blank_sql_null close_filehandle create_filehandle disconnect_sqlite filter funcname_to_funcref get_free_filehandle get_my_group global inherit lower_case open_string_for_reading show_sql_transaction split_string start_coproc upper_case validate_command write_sql);
}

END {
}

#  THERE IS A ONE-TO-ONE CORRESPONDENCE BETWEEN VARS HERE AND AT THE
#  BOTTOM! KEEP IT SO!

#  Public variables (see also the "Public variables" block below!)
our($OK);
our($FAIL);
#  Module-private variables with public access functions (see also the
#  "Module-private variables with public access functions" block below!)
my($_progname);
my($_simulate);
my($_verboselevel);
my($_paths_callback_ref);
my($_usage_callback_ref);
my($_version_callback_ref);
my(@_display_callback_refs);
#  Other module-private variables (see also the "Other module-private
#  variables" block below!)
my(%_defined_errors);
my(%_writer_id_to_function);
my($_dump_whole_error_stack_flag);
my($_display_error_stack_log_file_filename);
my($_display_error_stack_syslog_facility);
my($_show_paths_flag);
my($_show_help_flag);
my($_show_version_flag);
my($_inside_sql_transaction_flag);
my(%_registered_opt);
my(%_registers);
my(@_registered_defined_errors_hash_refs_array);
my(@_registered_opts);
my(%_replace_function_alerted);

########################################################################
#
#  Public functions
#
########################################################################

########################################################################
#
#  Public functions: entry point related
#
########################################################################

#DIFFSYNC: main
sub main   ##  no critic (RequireFinalReturn)
{
    my($app_main_ref) = @_;
    my($rc);
    my($errstack_ref) = [];

    #  Initialise a stack. Other stack related attributes (e.g. dumpall, 
    #  verbosity level) are initialised as module-private data at the top
    #  of this file.
    set_messaging_parameters($errstack_ref, stack=>$errstack_ref);

    #  This is a one-time loop! It allows us to jump forward on error.
    while (1) {
        #  Register the options ADE will handle and the functions to handle them.
        if (($rc=register_options($errstack_ref, 'Vd:ivhpn',  'version,debug:i,verbose,help,paths,simulate', '_handle_option_%s')) != $OK) {
            error($errstack_ref, 'ade_err_misc', 'register_options() call to register ADE options failed');
            last;
        }
    
        #  Call the application main().
        if(($rc=&{$app_main_ref}($errstack_ref)) != $OK) {
            error($errstack_ref, 'ade_err_misc', 'application\'s entry function failed');
            last;
        } 
   
        #  This 'last' makes it a one-time loop.
        last;
    }

    #  If necessary, display the error stack.
    if ($rc != $OK) {
        display_error_stack($errstack_ref);
        set_messaging_parameters($errstack_ref, stack=>$errstack_ref);
    }

    #  Convert $rc into a Unix exit code and exit.
    _exit2($errstack_ref, $rc);
}

########################################################################
#
#  Public functions: error stack related
#
########################################################################

#DIFFSYNC: register_error_types
sub register_error_types
{
    my($defined_errors_hash_ref) = @_;

    #  Currently there are no registration-time checks or actions other than
    #  the registration. We *could* check that the reference refers to a non-empty
    #  hash, or we could even copy the errors out of it, so that it becomes impossible
    #  to add or delete errors to the set of defined errors *after* registration.
    push @_registered_defined_errors_hash_refs_array, $defined_errors_hash_ref;

    return($OK);
}

#DIFFSYNC: display_error_stack
sub display_error_stack
{
    my($errstack_ref, $displayfunc_ref) = @_;
    my($framecount, @errpars, $defined_errors_hash_ref, $error_message);
    my($number_of_percent_signs_in_format, $number_of_parameters_supplied);

    #
    #  Check/sanitize parameters.
    #

    #  There is a default display function based on assumption most calls to display_error_stack
    #  are because of errors (not warnings).
    if (not defined $displayfunc_ref) {
        $displayfunc_ref = \&_error;
    }

    #
    #  For each error frame on the stack  ...
    #

    foreach my $i (0..$#{$errstack_ref}) {
        #  Skip all but the top frame if requested so to do
        next if ($i != 0 and not $_dump_whole_error_stack_flag);

        #
        #  ... Locate the description of the error message in one of the error message hashes ...
        #

        #  Locate which hash of defined error messages contains the key
        undef $defined_errors_hash_ref;
        foreach my $j (0..$#_registered_defined_errors_hash_refs_array) {
            if (defined ${$_registered_defined_errors_hash_refs_array[$j]}{${$errstack_ref}[$i]{'err'}}) {
                $defined_errors_hash_ref = $_registered_defined_errors_hash_refs_array[$j];
                last;
            }
        }
        if (not defined $defined_errors_hash_ref) {
            internal($errstack_ref, "${$errstack_ref}[$i]{'err'}: unknown error");
        }

        #
        #   Check sufficient parameters provided
        #

        $number_of_percent_signs_in_format = (${${$defined_errors_hash_ref}{${$errstack_ref}[$i]{'err'}}}{'fmt'} =~ tr/%//);
        $number_of_parameters_supplied = scalar @{${$errstack_ref}[$i]{'par'}};
        if ($number_of_percent_signs_in_format != $number_of_parameters_supplied) {
            #  errstack_ref refers to corrupt error stack; don't use it to report that it's corrupt! Instantiate a new stack with very limited scope.
            my($new_errstack_ref) = [];
            internal($new_errstack_ref, "error message argument count mismatch (tag: ${$errstack_ref}[$i]{'err'}, args supplied: $number_of_parameters_supplied, args requires: $number_of_percent_signs_in_format)");
        }

        #
        #   Expand the description's format with the parameters in the same stack frame
        #

        $error_message = sprintf ${${$defined_errors_hash_ref}{${$errstack_ref}[$i]{'err'}}}{'fmt'} , @{${$errstack_ref}[$i]{'par'}};

        #
        #  Display the error.
        #

        &{$displayfunc_ref}($errstack_ref, ($_dump_whole_error_stack_flag ? "frame#$i: " : '') . $error_message);
    }

    #
    #  If we get this far all is ok.
    #

    return($OK);
}

########################################################################
#
#  Public functions: string/stream manipulation functions
#
########################################################################

#DIFFSYNC: encode_z
sub encode_z
{
    my($errstack_ref, $src, $dst_ref, $safe_chars, $dangerous_chars) = @_;
    my($dst_local);

    $dst_local = '';
    foreach my $ochr (split //, $src) {
        if (defined $safe_chars and ($safe_chars =~ $ochr)) {
            ;
        } elsif (defined $dangerous_chars and ($dangerous_chars =~ /$ochr/)) {
            $ochr = sprintf 'Z%02X', ord $ochr;
        } elsif ($ochr =~ /[A-Ya-z0-9]/) {
            ;
        } else {
            $ochr = sprintf 'Z%02X', ord $ochr;
        }
        $dst_local .= $ochr;
    }

    ${$dst_ref} = $dst_local;

    return($OK);
}

#DIFFSYNC: decode_z
sub decode_z
{
    my($errstack_ref, $src, $dst_ref) = @_;

    $src =~ s/Z(..)/chr(hex($1))/ge;
    ${$dst_ref} = $src;

    return($OK);
}

#DIFFSYNC: extract_version
sub extract_version
{
    my($errstack_ref, $svnstring, $version_ref) = @_;
    my($rc);

    debug($errstack_ref, 50, "extract_version: sof (svnstring=\"$svnstring\")");
    #  Note that a 'svn mv' will result in LastChangedRevision being '-1' until it is commited.
    if ($svnstring !~ m/\$HeadURL: .*?\/(trunk|tags\/([^\/]+)|branches\/([^\/]+))\/.*?\$ \$LastChangedRevision: (-?\d+) \$/) { ## no critic (ProhibitComplexRegexes,ProhibitUnusedCapture)
        internal($errstack_ref, 'extract_version: failed to match');
    }

    #  We have to be a bit careful here: for reason I don't understand, if we reference and $2 and $2 has not
    #  been set by the above code (e.g. for trunk) then a debug statement saying;
    #
    #      debug($errstack_ref, 50, "extract_version: 1=$1, 2=$2, 3=$3, 4=$4");
    #
    #  results in this function returning non-zero; I'm not sure why it doesn't just bomb out.
    if ($1 eq 'trunk') {
        ${$version_ref} = "svn/trunk/$4";
    } elsif ($1 =~ /^tags\/(.*)/) {
        ${$version_ref} = "$1";
    } elsif ($1 =~ /^branches\/(.*)/) {
        ${$version_ref} = "svn/branch/$1";
    } else {
        internal($errstack_ref, "extract_version: handling of \"$1\" not implemented yet");
    }

    return($OK);
}

#DIFFSYNC: split_string
sub split_string
{
    internal([], "split_string: not implemented");
}

#DIFFSYNC: validate_regexp
sub validate_regexp
{
    my($errstack_ref, $regex) = @_;
    my($coderef);

    if ($coderef = eval { 'junk' =~ /$regex/ }) { }

    if (not defined $coderef) {
        error($errstack_ref, 'ade_err_invalid', $regex, 'regexp');
        return($FAIL);
    }

    return($OK);
}

#DIFFSYNC: upper_case
sub upper_case
{
    internal([], "upper_case: not implemented");
}

#DIFFSYNC: lower_case
sub lower_case
{
    internal([], "lower_case: not implemented");
}

########################################################################
#
#  Public functions: messaging functions
#
########################################################################

#DIFFSYNC: internal
sub internal
{
    my($errstack_ref, $message) = @_;

    #  The error frames on the stack may be relevant to solving the
    #  problem, so dump them.
    display_error_stack($errstack_ref);

    _internal($errstack_ref, $message);
    exit 5;
}

#DIFFSYNC: error
sub error
{
    my($errstack_ref, $defined_errors_hash_key, @errpars) = @_;
    my($rc);

    #  Deliberately no third parameter as we don't care about getting the
    #  definition frame at the moment.
    if (($rc=_validate_error_key($errstack_ref, $defined_errors_hash_key)) != $OK) {
        return($rc);
    }

    #  Create an anonymous hash consisting of the key leading to the
    #  error format etc and and an anonymous array for the error message's
    #  parameters. (Note that we *don't* note the hash in which the
    #  key is defined; we will look for it again when we come to print
    #  the stack out.
    push @{$errstack_ref}, { err => $defined_errors_hash_key, par => \@errpars };

    #
    #  If we get this far all is ok.
    #

    return($OK);
}

#DIFFSYNC: warning
sub warning
{
    my($errstack_ref, $defined_errors_hash_key, @errpars) = @_;
    my($rc);

    if (($rc=_validate_error_key($errstack_ref, $defined_errors_hash_key)) != $OK) {
        return($rc);
    }

    push @{$errstack_ref}, { err => $defined_errors_hash_key, par => \@errpars };

    #  Do an immediate stack dump and reset
    if (($rc=display_error_stack($errstack_ref, \&_warning)) != $OK) {
        return($rc);
    }
    set_messaging_parameters($errstack_ref, stack=>$errstack_ref);

    return($OK);
}

#DIFFSYNC: info
sub info
{
    my($errstack_ref, $message) = @_;

    #  We could stack the message and then demand its immediate display, like
    #  the error case, but here the $message is really free text and not something
    #  in the error stack. Therefore we make a shortcut. Perhaps in the future
    #  I could use a specially registered error with format as just '%s' to
    #  inject the message to the stack and then call the display function
    #  immediately - simply for conformancy, but for the moment not. See also
    #  debug().

    return(_info($errstack_ref, $message));
}

#DIFFSYNC: debug
sub debug
{
    my($errstack_ref, $level, $message) = @_;

    #  We could stack the message and then demand its immediate display, like
    #  the error case, but here the $message is really free text and not something
    #  in the error stack. Therefore we make a shortcut. Perhaps in the future
    #  I could use a specially registered error with format as just '%s' to
    #  inject the message to the stack and then call the display function
    #  immediately - simply for conformancy, but for the moment not. See also
    #  info().

    return(_debug($errstack_ref, $level, $message));
}

#DIFFSYNC: show_help
sub show_help    ##  no critic (RequireFinalReturn)
{
    my($errstack_ref) = @_;
    my($rc, $usage_short_text, $usage_long_text, $progname);
    
    #  Call callbacks to get text into $usage_short_text and $usage_long_text.
    if (($rc=&{$_usage_callback_ref}($errstack_ref, \$usage_short_text, \$usage_long_text)) != $OK) {
        return $rc;
    }

    get_progname($errstack_ref, \$progname);
    print "Usage:   $progname [ <options> ] ";
    if (defined $usage_short_text) {
        chomp $usage_short_text;
        print "$usage_short_text\n";
    }
    print "\n";
    print "Options: -V        | --version               display program version\n";
    print "         -v        | --verbose               verbose\n";
    print "         -d        | --debug=<level>         set debug level\n";
    print "         -h        | --help                  display this text\n";
    print "         -p        | --paths                 list used paths\n";
    print "         -n        | --simulate              simulate (limited effect!)\n";
    if (defined $usage_long_text) {
        chomp $usage_long_text;
        print "$usage_long_text\n";
    }
    print "\n";
    _exit2($errstack_ref, 0);
}

#DIFFSYNC: show_bad_usage
sub show_bad_usage
{
    my($errstack_ref) = @_;
    my($progname);
    
    get_progname($errstack_ref, \$progname);
    print STDERR "$progname: ERROR: type '$progname --help' for correct usage.\n";
    _exit2($errstack_ref, 1);
}

#DIFFSYNC: show_version
sub show_version   ##  no critic (RequireFinalReturn)
{
    my($errstack_ref) = @_;
    my($version_text, $rc);

    #  The shell equivalent checks that $version_returner_funcref is a function here. But
    #  out of laziness I've not done that yet here.

    if (($rc=&{$_version_callback_ref}($errstack_ref, \$version_text)) != $OK) {
        return $rc;
    }

    if (defined $version_text) {
        chomp $version_text;
        print "$_progname version $version_text\n"
    }

    _exit2($errstack_ref, 0);
}

#DIFFSYNC: show_paths
sub show_paths    ##  no critic (RequireFinalReturn)
{
    my($errstack_ref) = @_;
    my($listpaths_text, $rc, $unix_rc);

    $unix_rc = 0;

    if (($rc=&{$_paths_callback_ref}($errstack_ref, \$listpaths_text)) != $OK) {
        display_error_stack($errstack_ref);
        set_messaging_parameters($errstack_ref, stack=>$errstack_ref);
        $unix_rc = 1;
    }

    if (defined $listpaths_text) {
        chomp $listpaths_text;
        print "$listpaths_text\n";
    }

    _exit2($errstack_ref, $unix_rc);
}

#DIFFSYNC: ask_question
sub ask_question ## no critic (ProhibitManyArgs)
{
    my($errstack_ref, $hint, $prompt, $default, $validate_fnc, $rationalise_fnc, $rationalised_response_ref) = @_;
    my($response, $rc, $validated);

    if (defined $hint) {
        debug($errstack_ref, 20, 'ask_question: hint is defined; displaying ...');
        print "$hint\n";
    }

    while (1) {
        print "$_progname: QUESTION: $prompt [$default]: ";
        #  If this an error occurs below (e.g. 'cos user hits CTRL-D and this function
        #  returns err_eof) then the error output will arrive *before* the text
        #  printed above. This is due to it not having a new line and the output being
        #  buffered. To avoid this confusion we flush immediately. This uses IO::Handle.
        *STDOUT->flush();
        $response = <>;
        if (not defined $response) {
            error($errstack_ref, 'ade_err_eof', 'stdin');
            return($FAIL);
        }
        chomp $response;
        ($response eq '')  and ($response = $default);
        ($response eq '.') and ($response = '');
        debug($errstack_ref, 20, "ask_question: \$response=[$response]");
        if (($rc=&{$validate_fnc}($errstack_ref, $response, \$validated)) != $OK) {
            return($rc);
        } elsif ($validated) {
            last;
        }
        warning($errstack_ref, 'ade_err_misc', 'invalid response; please retry');
    }

    if (not defined $rationalise_fnc) {
        ${$rationalised_response_ref} = $response;
    } elsif (($rc=&{$rationalise_fnc}($errstack_ref, $response, $rationalised_response_ref)) != $OK) {
        return($rc);
    }

    return($OK);
}

########################################################################
#
#  Public functions: filename manipulation functions
#
########################################################################

#DIFFSYNC: get_absolute_path
sub get_absolute_path
{
    my($errstack_ref, $what, $cwd, $new_what_ref) = @_;
    my(@bits, @new_bits, $new_what);

    #  If not absolute prepend current directory. (Consulting $PWD is closest to
    #  what a bash user would expect.)
    chomp ($cwd = $ENV{'PWD'}) if (not defined $cwd);
    $what = "$cwd/$what" if ($what !~ /^\//);

    #  Discard leading / first (perl version does this inside processing loop but it's
    #  easier to ditch it early).
    $what =~ s/^\///;

    #  Chop up remainder.
    @bits = split /\//, $what;
    debug($errstack_ref, 20, 'get_absolute_path: bits=[' . (join ',', @bits) . ']');

    #  Process bits in sequence.
    @new_bits = ();
    foreach my $i (0..$#bits) {
        if ($bits[$i] eq '..') {
            #  If in subdir then .. takes us out. But if already at top then .. does
            #  nothing, it is not an error (i.e. "cd /.." works).
            if ($#new_bits+1 > 0) {
                pop @new_bits;
            }
        #  Double slash would give empty bit.
        } elsif ($bits[$i] eq '') {
        #  '.' gives empty bit.
        } elsif ($bits[$i] eq '.') {
        } else { 
            push @new_bits, $bits[$i];
        }

    }
    debug($errstack_ref, 20, 'get_absolute_path: new_bits=[' . (join ',', @new_bits) . ']');

    #  Remember above we said that we're working with the path *relative* to / (because
    #  we discard the leading '/') so now we need to prepend it back on again.
    $new_what = '/' . join '/', @new_bits;
    debug($errstack_ref, 20, "get_absolute_path: new_what=$new_what");
    ${$new_what_ref} = $new_what;

    return($OK);
}

#DIFFSYNC: check_readable
sub check_readable
{
    my($errstack_ref, $thing) = @_;

    if (not -f $thing or not -r $thing) {
        error($errstack_ref, 'ade_err_misc', "$thing: is not a readable file");
        return($FAIL);
    }
    return ($OK);
}

#DIFFSYNC: check_writable
sub check_writable
{
    my($errstack_ref, $thing) = @_;

    if ((-f $thing and not -w $thing) or not -w File::Basename::dirname($thing)) {
        error($errstack_ref, 'ade_err_misc', "$thing: is not a writable file");
        return($FAIL);
    }
    return ($OK);
}

########################################################################
#
#  Public functions: file handle manipulation functions
#
########################################################################

#DIFFSYNC: get_free_filehandle
sub get_free_filehandle
{
    internal([], "get_free_filehandle: not implemented");
}

#DIFFSYNC: open_string_for_reading
sub open_string_for_reading
{
    internal([], "open_string_for_reading: not implemented");
}

#DIFFSYNC: create_filehandle
sub create_filehandle
{
    internal([], "create_filehandle: not implemented");
}

#DIFFSYNC: close_filehandle
sub close_filehandle
{
    internal([], "close_filehandle: not implemented");
}

########################################################################
#
#  Public functions: UUID-related
#
########################################################################\

#DIFFSYNC: create_uuid
sub create_uuid
{
    my($errstack_ref, $uuid_ref) = @_;
    my($local_uuid, $rc);
    $local_uuid = lc UUID::uuid();
    debug($errstack_ref, 10, "create_uuid: local_uuid=$local_uuid");
    if (($rc=validate_uuid($errstack_ref, $local_uuid)) != $OK) {
        return $rc;
    }
    ${$uuid_ref} = $local_uuid;
    return($OK);
}

#DIFFSYNC: read_uuid
sub read_uuid
{
    my($errstack_ref, $file, $uuid_ref) = @_;
    my($local_uuid, $rc, $handle);

    if (not open $handle, '<', $file) {
        error($errstack_ref, 'ade_err_access', $file, 'open');
        return($FAIL);
    }
    $local_uuid = <$handle>;
    close $handle;

    chomp $local_uuid;
    if (($rc=validate_uuid($errstack_ref, $local_uuid)) != $OK) {
        return($rc);
    }

    ${$uuid_ref} = $local_uuid;
    return($OK);
}

#DIFFSYNC: write_uuid
sub write_uuid
{
    my($errstack_ref, $file, $uuid) = @_;
    my($rc, $handle);

    debug($errstack_ref, 10, "ade_write_uuid: file=$file, uuid=$uuid");
    if (($rc=validate_uuid($errstack_ref, $uuid)) != $OK) {
        return($rc);
    }
    if (not open $handle, '>', $file) {
        error($errstack_ref, 'ade_err_access', $file, 'open');
        return($FAIL);
    }

    printf $handle "$uuid\n";
    close $handle;

    return $OK;
}

#DIFFSYNC: validate_uuid
sub validate_uuid
{
    my($errstack_ref, $uuid) = @_;

    if ($uuid !~ /^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}$/) { ## no critic (ProhibitComplexRegexes)
        error($errstack_ref, 'ade_err_misc', $uuid . 'invalid uuid');
        return($FAIL);
    }

    return($OK);
}

########################################################################
#
#  Public functions: file content manipulation functions
#
########################################################################

#DIFFSYNC: open_compressed_file_for_reading
sub open_compressed_file_for_reading
{
    my($errstack_ref, $filename, $handle_ref) = @_;
    my($rc, $gunzip_cmd, $uncompress_cmd);

    return($FAIL) if (! -r $filename);

    if (! -r $filename) {
        error($errstack_ref, 'ade_err_access', $filename, 'read');
        return($FAIL);
    } elsif ($filename =~ /^.*\.gz$/) {
        if (not open ${$handle_ref}, '-|', "gunzip < $filename") {
            error($errstack_ref, 'ade_err_access', $filename, "open with '$gunzip_cmd'");
            return($FAIL);
        }
    } elsif ($filename =~ /^.*\.Z$/) {
        if (not open ${$handle_ref}, '-|', "uncompress < $filename") {
            error($errstack_ref, 'ade_err_access', $filename, "open with '$uncompress_cmd'");
            return($FAIL);
        }
    } else {
        if (not open ${$handle_ref}, '<', $filename) {
            error($errstack_ref, 'ade_err_access', $filename, 'open');
            return($FAIL);
        }
    }

    return($OK);
}

#DIFFSYNC: open_compressed_file_for_writing
sub open_compressed_file_for_writing
{
    my($errstack_ref, $filename, $handle_ref) = @_;
    my($rc, $gzip_cmd, $compress_cmd);

    if ($filename =~ /^.*\.gz$/) {
        if (not open ${$handle_ref}, '|-', "gzip > $filename") {
            error($errstack_ref, 'ade_err_access', $filename, "open with '$gzip_cmd'");
            return($FAIL);
        }
    } elsif ($filename =~ /^.*\.Z$/) {
        if (not open ${$handle_ref}, '|-', "compress > $filename") {
            error($errstack_ref, 'ade_err_access', $filename, "open with '$compress_cmd'");
            return($FAIL);
        }
    } else {
        if (not open ${$handle_ref}, '>', $filename) {
            error($errstack_ref, 'ade_err_access', $filename, 'open');
            return($FAIL);
        }
    }

    return($OK);
}

#DIFFSYNC: get_md5sum
sub get_md5sum
{
    my($errstack_ref, $file, $sum_ref) = @_;
    my($fp);

    if (not open $fp, '<', $file) {
        internal($errstack_ref, "get_md5sum: $file: failed to open");
    }

    #  Slurp
    local $/ = undef;
    ${$sum_ref} = Digest::MD5::md5_hex(<$fp>);
    close $fp;

    return($OK);
}

########################################################################
#
#  Public functions: option processing
#
########################################################################

#DIFFSYNC: register_options
sub register_options
{
    my($errstack_ref, $short_opts, $long_opts, $opt_func_template) = @_;
    my($opts, $opt, $re, $opt_suff, $opt_argc, $opt_argt, $opt_func, $subref, $dollar_2);

    $opt_func_template = 'option_handler_%s' if (not defined $opt_func_template);

    debug($errstack_ref, 10, sprintf 'register_options: short_opts=%s, long_opts=%s, opt_func_template=%s', defined $short_opts ? $short_opts : 'undef', defined $long_opts ? $long_opts : 'undef', defined $opt_func_template ? $opt_func_template : 'undef');

    #  Register the shorts and then the longs
    foreach my $opt_type ('short', 'long') {
        if ($opt_type eq 'short') {
            $opts = $short_opts;
            $re='^([a-zA-Z])(:[siof])?(.*)$'
        } else {
            $opts = $long_opts;
            $re='^([a-zA-Z][-a-zA-Z0-9]+)(:[siof])?,?(.*)$'
        }
        #  Allow caller so specify undef.
        next if (not defined $opts);
        debug($errstack_ref, 10, "register_options: opt_type=$opt_type, opts=$opts, re=$re");
        while ($opts =~ /$re/) {
            $opt = $1;
            #  Captures in regexps that capture nothing are undefined not blank. Fix for ease of use.
            $dollar_2 = defined $2 ? $2 : '';
            $opt_argc = ($dollar_2 eq '') ? 0 : 1;
            #  Get the character after the colon
            $opt_argt = (split //, $dollar_2)[1];
            #  Remaining opts are here
            $opts = $3; ## no critic (ProhibitCaptureWithoutTest)   perlcritic too stupid to see 'while' test above
            #  These substitutions reset $1, etc. So finish using $1, etc first.
            $opt_suff = $opt; $opt_suff =~ s/-/_/g;
            $opt_func = $opt_func_template; $opt_func =~ s/%s/$opt_suff/g;
            debug($errstack_ref, 10, sprintf 'register_options: opt=%s, opt_suff=%s, opt_argc=%s, opt_argt=%s, opt_func=%s, opts=%s', map { defined $_ ? $_ : 'undef' } ($opt, $opt_suff, $opt_argc, $opt_argt, $opt_func, $opts));
            if (!($subref = _validate_function($opt_func))) {
                error($errstack_ref, 'ade_err_undefined', $opt_func, 'function');
                return($FAIL);
            }
            debug($errstack_ref, 10, "register_options: registering callback $opt_func for $opt_type option '$opt' ...");
            #  Map <short-opt>  to (<handler-function>, <count-of-args-to-pass>, <colon-or-nothing>)
            #  (The <colon-or-nothing> will help when constructing the list of accepted options in
            #  the format that the normal getopt command wants - i.e. <opt><colon> or <opt>).
            #  Bash version 3 doesn't support hashes so use "eval VAR_SUFFIX" trick.
            $_registered_opt{$opt_suff} = [$opt_type, $subref, $opt_argc, $opt_argt];
            #  In addition, store the short option in an array with a fixed name,
            #  this will make it easier to process later.
            push @_registered_opts, $opt;
        }
    }

    return($OK);
}

#DIFFSYNC: process_options
sub process_options
{
    my($errstack_ref) = @_;
    my($opt_suff, $opt_type, $opt_func, $opt_argc, $opt_argt, $short_opts, $long_opts, $found, %opt_hash, $rc);

    #  Collect all the short options and long options together in format suitable for getopts.
    debug($errstack_ref, 10, 'process_options: assembling hash ...');
    foreach my $opt (@_registered_opts) {
        debug($errstack_ref, 10, "process_options: assembling hash entry for $opt ...");
        $opt_suff = $opt; $opt_suff =~ s/-/_/g;
        $opt_type = $_registered_opt{$opt_suff}[0];
        $opt_func = $_registered_opt{$opt_suff}[1];
        $opt_argc = $_registered_opt{$opt_suff}[2];
        $opt_argt = $_registered_opt{$opt_suff}[3];
        debug($errstack_ref, 10, sprintf 'process_options: opt=%s, opt_suff=%s, opt_argc=%s, opt_argt=%s, opt_func=%s', map { defined $_ ? $_ : 'undef' } ($opt, $opt_suff, $opt_argc, $opt_argt, $opt_func));
        if ($opt_argc == 0) {
            $opt_hash{$opt} = $opt_func;
        } elsif ($opt_argc == 1) {
            $opt_hash{"$opt=$opt_argt"} = $opt_func;
        } else {
            internal($errstack_ref, 'process_options: internal error');
        }
    }

    #  Redirect GetOptions's alerts to our alerter.
    debug($errstack_ref, 10, 'process_options: calling GetOptions ...');
    #  A rare occurrence: a signal handler that really can be local to the enclosing block.
    {
        local $SIG{'__WARN__'} = sub { 
            show_bad_usage($errstack_ref);
        };
        Getopt::Long::GetOptions(%opt_hash);
    }

    #  If help needs, or paths to be displayed or version info requested then handle that now.
    debug($errstack_ref, 10, 'process_options: checking whether to call message handlers ...');
    if ($_show_paths_flag) {
        $rc = show_paths($errstack_ref);
        internal($errstack_ref, "process_options: show_paths() unexpectedly returned (rc=$rc)");
    }
    if ($_show_help_flag) {
        $rc = show_help($errstack_ref);
        internal($errstack_ref, "process_options: show_help() unexpectedly returned (rc=$rc)");
    }
    if ($_show_version_flag) {
        $rc = show_version($errstack_ref);
        internal($errstack_ref, "process_options: show_version() unexpectedly returned (rc=$rc)");
    }

    return($OK);
}

#DIFFSYNC: funcname_to_funcref
sub funcname_to_funcref
{
    internal([], "funcname_to_funcref: not implemented");
}

########################################################################
#
#  Public functions: special functions
#
########################################################################

#DIFFSYNC: manage_rolling_status
sub manage_rolling_status ## no critic (ProhibitExcessComplexity,ProhibitManyArgs)
{
    my ($errstack_ref, $mode, $sched_file, $scan_funcref, $comp_funcref, $oldscan_stem, $oldscan_compext, $comparison_report_file, $scanarg) = @_;
    my($rc, $i, $newer_status_file, $older_status_file, $compressed_scan_handle);
    my($saved_stdout_handle, $comparison_report_handle, $sched_handle);

    $newer_status_file = "/tmp/$_progname.$$.snap";
    $older_status_file = sprintf '%s%s', $oldscan_stem, $oldscan_compext;

    #  For init, check or refresh, do a new scan.
    if ($mode eq 'init' or $mode eq 'check' or $mode eq 'refresh') {
        debug($errstack_ref, 10, 'manage_rolling_status: doing a scan ...');
        register_temp_file($errstack_ref, $newer_status_file);
        if (($rc=open_compressed_file_for_writing($errstack_ref, $newer_status_file, \$compressed_scan_handle)) != $OK) {
            error($errstack_ref, 'ade_err_access', $newer_status_file, 'open');
            return($rc);
        }
        if (($rc=&{$scan_funcref}($errstack_ref, $compressed_scan_handle, $scanarg)) != $OK) {
            close $compressed_scan_handle;
            return($rc);
        }
        close $compressed_scan_handle;
    }

    #  For check or refresh, compare the old and new scans.
    if ($mode eq 'check' or $mode eq 'refresh') {
        debug($errstack_ref, 40, 'manage_rolling_status: doing a comparision ...');
        if (! -f $newer_status_file) {
            error($errstack_ref, 'ade_err_access', $newer_status_file, 'access');
            return($FAIL);
        }
        if (! -f $older_status_file) {
            error($errstack_ref, 'ade_err_access', $older_status_file, 'access');
            return($FAIL);
        }
        if (not defined $comparison_report_file) {
            $comparison_report_handle = \*STDOUT;
        } elsif (($rc=open_compressed_file_for_writing($errstack_ref, $comparison_report_file, \$comparison_report_handle)) != $OK) {
            error($errstack_ref, 'ade_err_access', $comparison_report_file, 'open');
            return($rc);
        }
        if (($rc=&{$comp_funcref}($errstack_ref, $older_status_file, $newer_status_file, $comparison_report_handle)) != $OK) {
            return($rc);
        }
        debug($errstack_ref, 40, 'manage_rolling_status: comparing callback successful');
        if (defined $comparison_report_file) {
            close $comparison_report_handle;
        }
    }

    #  For check with schedule, or refresh, or init, make the new snap the
    #  old snap. Don't do it by moving or copying 'cos we may move a gzipped
    #  file to a non-gzipped name, which will cause problems.
    if (($mode eq 'check' and defined $sched_file and -f $sched_file) or $mode eq 'refresh' or $mode eq 'init') {
        if (! -f $newer_status_file) {
            error($errstack_ref, 'ade_err_access', $newer_status_file, 'access for stealing');
            return($FAIL);
        }
        if (($mode ne 'init') and (! -f $older_status_file)) {
            error($errstack_ref, 'ade_err_access', $older_status_file, 'access');
            return($FAIL);
        }
        if (($rc=move_compressed_file($errstack_ref, $newer_status_file, $older_status_file)) != $OK) {
            error($errstack_ref, 'ade_err_access', $newer_status_file, 'move');
            return($rc);
        }
        deregister_temp_file($errstack_ref, $newer_status_file);
        debug($errstack_ref, 40, 'manage_rolling_status: shuffling up done');
    }

    #  For check with schedule, or refresh, delete the schedule file.
    if (defined $sched_file and (($mode eq 'check' and -f $sched_file) or $mode eq 'refresh')) {
        debug($errstack_ref, 40, 'manage_rolling_status: removing sched file ...');
        unlink $sched_file;
    }

    #  For scheduling, create the schedule file.
    if ($mode eq 'schedule') {
        if (not defined $sched_file) {
            internal($errstack_ref, 'manage_rolling_status: called in \'schedule\' mode, but the schedule file is undefined');
        }
        debug($errstack_ref, 40, 'manage_rolling_status: creating sched file ...');
        if (not open $sched_handle, '>', $sched_file) {
            error($errstack_ref, 'ade_err_access', $sched_file, 'create');
            return($FAIL);
        }
        close $sched_handle;
    }

    #  For checks without a schedule file we can now delete the temporary snapshot.
    if ((not defined $sched_file) and ($mode eq 'check')) {
        unlink $newer_status_file;
        deregister_temp_file($errstack_ref, $newer_status_file);
    }

    return($OK);
}

#DIFFSYNC: manage_cache
sub manage_cache  ## no critic (ProhibitExcessComplexity,ProhibitManyArgs)
{
    my ($errstack_ref, $cache_file, $cache_expiry_period, $desired_cache_expiry, $new_cache_tester_fncref, $new_cache_getter_fncref, $cache_id) = @_;
    my ($actual_cache_expiry, $cache_dir, $refresh_cache, $rc, $tmp_cache_handle, $saved_stdout_handle, $cache_handle);

    #  Determine if cache actually expired
    $actual_cache_expiry = (time - (stat $cache_file)[9] >= 86400 * $cache_expiry_period);

    #  This is the logic for combining the desired cache expiry status and
    #  the actual cache expiry status to determine if the cache should be
    #  refreshed.
    #
    #                 DESIRED EXPIRY
    #             Y          N     don't care
    #        ----------+is-cache--+----------
    #       |          |          |          |
    #   A   |          |    no    |          |
    #   C   |          |  update  |          |
    #   T   |          |          |          |
    #   U Y |  update  |no-cache--|  update  |
    #   A   |          |          |          |
    #   L   |          |  update  |          |
    #       |          |          |          |
    #        ----------+----------+----------
    #   E   |          |          |          |
    #   X   |          |          |          |
    #   P   |          |          |          |
    #   I   |          |    no    |    no    |
    #   R N |  update  |  update  |  update  |
    #   Y   |          |          |          |
    #       |          |          |          |
    #       |          |          |          |
    #        ----------+----------+----------
    #
    #  And now here it is in code, using the usual 'bite off the big
    #  bits first' approach.

    if ($desired_cache_expiry) {
        $refresh_cache = 1;
    } elsif (not $actual_cache_expiry) {
        $refresh_cache = 0;
    } elsif (not defined $desired_cache_expiry) {
        $refresh_cache = 1;
    } elsif (-f $cache_file) {
        $refresh_cache = 0;
    } else {
        warning($errstack_ref, 'cache will be refreshed against user\'s desire because no cache file exists yet');
        $refresh_cache = 1;
    }

    debug($errstack_ref, 4, "manage_cache: desired_cache_expiry=$desired_cache_expiry, actual_cache_expiry=$actual_cache_expiry, refresh_cache=$refresh_cache");

    if ($refresh_cache) {
        $cache_dir = File::Basename($cache_file);

        # sanity check cache
        if (-f $cache_file) {
            if (! -w $cache_file) {
                error($errstack_ref, 'ade_err_misc', "$cache_file: cache file exists but is not writable!") if (! -w $cache_file);
                return($FAIL);
            }
        } elsif (-d $cache_dir) {
            if (! -w $cache_dir) {
                error($errstack_ref, 'ade_err_misc', "$cache_file: cannot create cache file") if (! -w $cache_dir);
                return($FAIL);
            }
        } else {
            error($errstack_ref, 'ade_err_misc', "$cache_dir: cache file's directory does not exist");
            return($FAIL);
        }

        #  Update cache
        info($errstack_ref, "updating '$cache_id' cache, please wait ... ");
        register_temp_file($errstack_ref, "/tmp/$_progname.$$.newcache");
        debug($errstack_ref, 4, "manage_cache: calling $new_cache_getter_fncref() ...");
        if (not open $tmp_cache_handle, '>', "/tmp/$_progname.$$.newcache") {
            error($errstack_ref, 'ade_err_access', "/tmp/$_progname.$$.newcache", 'open');
            return($FAIL);
        }
        #  Avoid names that might clash with user applications for the handle, since it is a global.
        open $saved_stdout_handle, '>&', \*STDOUT; ## no critic (RequireBriefOpen,RequireCheckedOpen,RequireCheckedSyscalls) we assume file handle duplication not error prone
        open STDOUT, '>&', $tmp_cache_handle; ## no critic (RequireCheckedOpen,RequireCheckedSyscalls) we assume file handle duplication not error prone
        &{$new_cache_getter_fncref}();
        open STDOUT, '>&', $saved_stdout_handle; ## no critic (RequireCheckedOpen,RequireCheckedSyscalls) we assume file handle duplication not error prone
        close $tmp_cache_handle;

        #  if tests pass, accept it.
        if (&{$new_cache_tester_fncref}("/tmp/$_progname.$$.newcache") == 0) {
            File::Copy::copy("/tmp/$_progname.$$.newcache", $cache_file);
            unlink "/tmp/$_progname.$$.newcache";
            deregister_temp_file($errstack_ref, "/tmp/$_progname.$$.newcache");
            info($errstack_ref, "'$cache_id' cache update succeeded");

        #  if tests fail but we have an old version, reject with warning
        } elsif (-f $cache_file) {
            deregister_temp_file($errstack_ref, "/tmp/$_progname.$$.newcache");
            warning($errstack_ref, "'$cache_id' cache update failed, old cache available (see /tmp/$_progname.$$.newcache for new data which failed acceptance test)");

        #  if tests fail and we don't have an old version, reject with error
        } else {
            deregister_temp_file($errstack_ref, "/tmp/$_progname.$$.newcache");
            error($errstack_ref, 'ade_err_misc', "'$cache_id' cache update failed, old cache not available (see /tmp/$_progname.$$.newcache for new data which failed acceptance test)");
            return($FAIL);
        }
    }

    #  Pass cache to parent by displaying it. (Previously done with system(cat ...).)

    if (not open $cache_handle, '<', $cache_file) {
        error($errstack_ref, 'ade_err_access', $cache_file, 'open');
        return($FAIL);
    }
    while (<$cache_handle>) {
        print;
    }
    close $cache_handle;

    return($OK);
}

#DIFFSYNC: fork_multi
sub fork_multi  ## no critic (ProhibitExcessComplexity)
{
    my($errstack_ref, $timeout, $threads, $cmds_ref, $exit_codes_ref) = @_;
    my($all_cmds_exited_or_killed_but_not_exited_yet_alarm_period);
    my(@jobs, %recently_reaped_pids, $now_time, $priorsigset, $blocksigset, @expired_jids, @pending_jids, @expiry_order_running_jids);
    my($pid, $alarm_period, @running_or_killed_jids, $jid, $exited_job_count);

    #  Configurable stuff
    $all_cmds_exited_or_killed_but_not_exited_yet_alarm_period = 60;

    #  Derivations
    @jobs = map { {cmd=>$_, state=>'pending', pid=>0, exit_code=>0, kill_time=>0} } @{$cmds_ref};

    #  Signal handlers - local as they're only needed for the duration of execution of this function.
    local $SIG{'CHLD'} = sub {
        my($jid2, $pid2, @local_errstack);
        while (($pid2 = waitpid -1, POSIX::WNOHANG) > 0) {
            #  We used to write the pid and exit code into a dict that was then read from and deleted from the dict
            #  by the main monitoring loop. But since discovering sigsuspend() which ensures that interrupts don't
            #  interrupt except when we allow them *and* can't happen at the same time as other code is running
            #  (because sigsuspend() only returns once handlers have returned) then we no longer need that and
            #  we can write information about the now-exited pid directly into the jobs table.
            $jid2 = (grep { $jobs[$_]{'pid'} == $pid2 } (0..$#jobs))[0];
            $jobs[$jid2]{'state'} = 'exited';
            $jobs[$jid2]{'kill_time'} = 0;
            $jobs[$jid2]{'pid'} = 0;
            $jobs[$jid2]{'exit_code'} = $?;
            _fork_multi_debug(\@local_errstack, undef, "sighandler_chld: $pid2 exited with exit code $jobs[$jid2]{'exit_code'}");
        }
    };
    local $SIG{'ALRM'} = sub {
        my(@local_errstack);
        _fork_multi_debug(\@local_errstack, undef, 'sighandler_alrm: dring!');
    };

    #  Guts
    #  Block signals; this doesn't ignore them, they don't get discarded, but delivery is delayed
    #  until we unblock (either by applying a mask with sigprocmask() or by calling sigsuspend()).
    $priorsigset = POSIX::SigSet->new;
    #  Note that 'POSIX::SIGCHLD', 'POSIX::SIGALRM' and 'POSIX::SIG_BLOCK' are function calls,
    #  not function references! POSIX(3perl) uses '&POSIX::SIGCHLD' etc, but perlcritic complains
    #  about the unnecessary '&'. I added a backslash because I thought these were function
    #  references and then spent a long time debugging! They are function calls! Yes, in fact
    #  https://docstore.mik.ua/orelly/perl3/cookbook/ch16_21.htm confirms this and actually says:
    #
    #      The POSIX module exports functions named after
    #      the signals, which return their signal numbers.
    #
    $blocksigset = POSIX::SigSet->new( POSIX::SIGCHLD, POSIX::SIGALRM );
    POSIX::sigprocmask(POSIX::SIG_BLOCK, $blocksigset, $priorsigset);

    #  Main loop
    while (1) {
        #  Execution of each line takes time. This means if we're trying to work out how long to
        #  sleep for based on when a job should be killed and the time at which the current line
        #  is being executed, then we can wind up with negative intervals. For this reason we
        #  take the current time only once per loop. The loop itself is *fast* (except for the
        #  final call to sigsuspend).
        $now_time = Time::HiRes::time();
        debug($errstack_ref, 40, 'fork_multi: ========== top of loop ===========');

        #  This is just for debugging but it's debugging with timestamps. So we use a special
        #  scoped function _fork_multi_debug().
        _fork_multi_debug($errstack_ref, undef, sprintf '%3s %7s %17s %5s %s', 'jid', 'state', 'kill_time', 'pid', 'cmd');
        foreach my $jid (0..$#jobs) {
            _fork_multi_debug($errstack_ref, undef, sprintf '%3d %7s %17.6f %5d %s', $jid, $jobs[$jid]{'state'}, $jobs[$jid]{'kill_time'}, $jobs[$jid]{'pid'}, $jobs[$jid]{'cmd'});
        }
        _fork_multi_debug($errstack_ref, undef, 'signal handler\'s list of recently exited pids: ' . join ', ', keys %recently_reaped_pids);

        #  Task #0: Quit if no jobs.
        #  Any action we do below (e.g. starting jobs, killing jobs) always sends
        #  us immediately back to the top of the loop so that I see the updated jobs table but
        #  also to do this check: can we quit?
        $exited_job_count = grep { $jobs[$_]{'state'} eq 'exited' } (0 .. $#jobs);
        last if ($exited_job_count == $#jobs+1);

        #  Task #1: kill jobs that are taking too long.
        #  Do tasks that *clean* the jobs table (i.e. killing and marking exited) *before* those
        #  than consume execution slots.
        @expired_jids = grep { $jobs[$_]{'state'} eq 'running' and $jobs[$_]{'kill_time'} > 0 and $jobs[$_]{'kill_time'} <= $now_time } (0..$#jobs);
        _fork_multi_debug($errstack_ref, undef, 'expired jobs: ' . join ', ', @expired_jids);
        foreach my $jid (@expired_jids) {
            if (not kill 'KILL', $jobs[$jid]{'pid'}) {
                error($errstack_ref, 'ade_err_access', "pid $jobs[$jid]{'pid'}", 'kill');
                return($FAIL);
            }
            $jobs[$jid]{'state'} = 'killed';
            $jobs[$jid]{'kill_time'} = 0;
        }
        next if ($#expired_jids+1 > 0);

        #  Task #2: if possible start a pending job.
        @pending_jids = grep { $jobs[$_]{'state'} eq 'pending'} (0..$#jobs);
        _fork_multi_debug($errstack_ref, undef, 'pending jobs: ' . join ', ', @pending_jids);
        @running_or_killed_jids = grep { $jobs[$_]{'state'} eq 'running' or $jobs[$_]{'state'} eq 'killed' } (0..$#jobs);
        _fork_multi_debug($errstack_ref, undef, 'running or killed jobs: ' . join ', ', @running_or_killed_jids);
        if ($#pending_jids+1 > 0 and ($threads == 0 or $#running_or_killed_jids+1 < $threads)) {
            _fork_multi_debug($errstack_ref, undef, "starting job id $pending_jids[0] ...");
            $pid = fork;
            if (not defined $pid) {
                internal($errstack_ref, "fork_multi: fork failed ($!)");
            } elsif ($pid != 0) {
                $jobs[$pending_jids[0]]{'state'} = 'running';
                $jobs[$pending_jids[0]]{'pid'} = $pid;
                $jobs[$pending_jids[0]]{'kill_time'} = ($timeout > 0) ? $now_time + $timeout : 0;
                next;
            } elsif (not exec $jobs[$pending_jids[0]]{'cmd'}) {
                internal($errstack_ref, 'fork_multi: exec failed');
            }
        }

        #  Task #3: work out how long we can sleep (although we don't actually use
        #  sleep) before the next job timeout is due. If there are no jobs that can
        #  timeout (because there are no timeouts or because all jobs have already
        #  exited or been killed but not actually exited yet) then fall back on a
        #  longer sleep interval (which will get interrupted very quickly by a
        #  killed job having exited).
        _fork_multi_debug($errstack_ref, undef, 'checking for when running jobs expire ...');
        @expiry_order_running_jids = sort { $jobs[$a]{'kill_time'} <=> $jobs[$b]{'kill_time'} } grep { $jobs[$_]{'state'} eq 'running' and $jobs[$_]{'kill_time'} > 0 } (0..$#jobs);
        _fork_multi_debug($errstack_ref, undef, 'expiry ordered jobs: ' . join ', ', @expiry_order_running_jids);
        if ($#expiry_order_running_jids+1 > 0) {
            _fork_multi_debug($errstack_ref, undef, sprintf 'next expiry: jid=%d; expiry time: %17.6f (now it is %17.6f)', $expiry_order_running_jids[0], $jobs[$expiry_order_running_jids[0]]{'kill_time'}, $now_time);
            $alarm_period = $jobs[$expiry_order_running_jids[0]]{'kill_time'} - $now_time;
        } else {
            $alarm_period = $all_cmds_exited_or_killed_but_not_exited_yet_alarm_period;
        }
        #  Time::HiRes::alarm() thinks values less than 0.000001 are zero. Bump up such values.
        if ($alarm_period > 0 and $alarm_period < 0.000001) {
            #  It could feasibly be that 0.000001 is not representable and actually gets stored
            #  as 0.00000099123456789. Therefore we are a little cautious and set the value to
            #  slightly above 0.000001 just in case.
            $alarm_period = 0.0000011;
        }

        #  Task #4: schedule an alarm for that period.
        #  Sleep period can be very slightly negative. Avoid complaints from Time::HiRes::sleep().
        if ($alarm_period > 0) {
            _fork_multi_debug($errstack_ref, undef, sprintf 'scheduling alarm for %.6f from now ...', $alarm_period);
            Time::HiRes::alarm($alarm_period);
        }

        #  Task #5: call sigsuspend(), which does the following *atomically*:
        #
        #  1) temporarily unblock signals allowing already-sent-but-blocked signals to be delivered
        #  2) wait for a signal (which will be very quick because the likelihood is that
        #     the signal was sent some time during the execution of tasks #1-#4.
        #  3) wait for the signal handlers to return
        #  4) reinstate signal block
        #  5) return
        _fork_multi_debug($errstack_ref, undef, 'calling sigsuspend() ...');
        POSIX::sigsuspend($priorsigset);
        _fork_multi_debug($errstack_ref, undef, 'returned from sigsuspend()');

        #  If SIGCHLD arrived first then we've got a scheduled alarm that we need to cancel.
        #  If SIGALRM arrived first then we don't have a scheduled alarm to cancel. So do
        #  we cancel or not? Just cancel! It's easier than working out if we should or not and
        #  does no harm.
        Time::HiRes::alarm(0);
    }

    #  Clean up - it should not be necessary to reset signal handlers, since they're defined local above.
    #  Note that that O'Reilly link about says to cleanup by calling:
    #
    #      sigprocmask(SIG_UNBLOCK, $priorsigset);
    #
    #  but that appears to be wrong. I *thought* it should be:
    #
    #      sigprocmask(POSIX::SIG_BLOCK, $priorsigset);
    #
    #  (meaning that only the signals previously blocked should now be blocked) but that seems to be
    #  wrong. This works:
    #
    #      POSIX::sigprocmask(POSIX::SIG_UNBLOCK, $blocksigset, undef);
    #
    #  But it is still wrong: I don't want to unblock the signals that I blocked because some
    #  of them may have been blocked already before I started. What I want is simply to restore
    #  things to how they were. The sigprocmask(2) explains it best:
    #
    #      SIG_BLOCK
    #              The set of blocked signals is the union of the current set and the
    #              set argument.
    #
    #      SIG_UNBLOCK
    #              The signals in set are removed from the current set of blocked
    #              signals.  It is permissible to attempt to  un‐ block a signal
    #              which is not blocked.
    #
    #      SIG_SETMASK
    #              The set of blocked signals is set to the argument set.
    #
    #  So it's clear, this is what I need:
    POSIX::sigprocmask(POSIX::SIG_SETMASK, $priorsigset, undef);

    #  Pass Unix exit codes up.
    @{$exit_codes_ref} = map { $jobs[$_]{'exit_code'} } (0..$#jobs);

    #  Tidy up
    return($OK);
}

########################################################################
#
#  Public functions: user related
#
########################################################################

#DIFFSYNC: get_my_group
sub get_my_group
{
    internal([], "get_my_group: not implemented");
}

########################################################################
#
#  Public functions: process management functions
#
########################################################################

#DIFFSYNC: validate_command
sub validate_command
{
    internal([], "validate_command: not implemented");
}

#DIFFSYNC: start_coproc
sub start_coproc
{
    internal([], "start_coproc: not implemented");
}

#DIFFSYNC: evaler
sub evaler
{
    my($errstack_ref, $command) = @_;

    if ($_simulate) {
        print "$command\n";
    } elsif ((system $command) != 0) {
        #  Remember that ($text =~ /<regexp-with-captures>/) *sets* $1, $2, etc
        #  but it also *returns* those as as an single item or an array (though,
        #  in this case we're only capturing one thing, so no need to use 
        #  '[0]' or whatever to access it.
        error($errstack_ref, 'ade_err_misc', sprintf '%s: command failed (hint: see messages above?)', ($command =~ /([^ ]*)/));
        return($FAIL);
    }
    return($OK);
}

########################################################################
#
#  Public functions: temporary file related functions
#
########################################################################

#DIFFSYNC: register_exit_function
sub register_exit_function
{
    my($errstack_ref, @items) = @_;

    push @{$_registers{'callonexit'}}, @items;
    return($OK);
}

#DIFFSYNC: deregister_exit_function
sub deregister_exit_function
{
    my($errstack_ref, @items) = @_;
    return(_pop_by_value($errstack_ref, 'callonexit', @items));
}

#DIFFSYNC: register_temp_file
sub register_temp_file
{
    my($errstack_ref, @items) = @_;
    my($item, $rc);

    #  We must enforce that registered items are absolute. This is to protect
    #  the cleanup routines from risking 'shell-init: getcwd failed' errors
    #  if the user presses CTRL-C.
    #  Note that same must be done at deregistration time or we'll not be able
    #  to make a match in the list of registered items.
    @items = map { ## no critic (ProhibitComplexMappings)
         if (($rc=get_absolute_path($errstack_ref, $_, undef, \$_)) != $OK) { return($rc); }
         $_;
    } @items;

    push @{$_registers{'delonexit'}}, @items;
    return($OK);
}

#DIFFSYNC: deregister_temp_file
sub deregister_temp_file
{
    my($errstack_ref, @items) = @_;
    my($rc);

    @items = map { ## no critic (ProhibitComplexMappings)
         if (($rc=get_absolute_path($errstack_ref, $_, undef, \$_)) != $OK) { return($rc); }
         $_;
    } @items;

    return(_pop_by_value($errstack_ref, 'delonexit', @items));
}

#DIFFSYNC: _deregister_all_exit_functions
sub _deregister_all_exit_functions
{
    my($errstack_ref) = @_;

    @{$_registers{'callonexit'}} = ();
    return($OK);
}

#DIFFSYNC: _deregister_all_temp_files
sub _deregister_all_temp_files
{
    my($errstack_ref) = @_;

    @{$_registers{'delonexit'}} = ();
    return($OK);
}

#DIFFSYNC: _delete_all_temp_files
sub _delete_all_temp_files
{
    my($errstack_ref) = @_;

    #  Avoid 'shell-init: error retrieving current directory'
    chdir '/';    ## no critic (RequireCheckedSyscalls)

    foreach my $item (@{$_registers{'delonexit'}}) {
        #  unlink is not enough, 'cos directories are sometimes registered,
        #  and what's more the caller does not expect to have to register
        #  the contents of directories one by one.
        File::Path::remove_tree($item);
    }
    return(_deregister_all_temp_files($errstack_ref));
}

#DIFFSYNC: _call_all_exit_functions
sub _call_all_exit_functions
{
    my($errstack_ref) = @_;

    foreach my $item (@{$_registers{'callonexit'}}) {
        &{$item}();
    }
    return(_deregister_all_exit_functions($errstack_ref));
}

########################################################################
#
#  Public functions: database related functions
#
########################################################################

#DIFFSYNC: write_sql
sub write_sql
{
    internal([], "write_sql: not implemented");
}

#DIFFSYNC: execute_sql
sub execute_sql
{
    my($errstack_ref, $dbh, $sql_command) = @_;

    debug($errstack_ref, 10, "execute_sql: running \"$sql_command\" ...");
    if (not defined $dbh->do($sql_command)) {
        error($errstack_ref, 'ade_err_misc', $dbh->errstr);
        return($FAIL);
    }

    return($OK);
}

#DIFFSYNC: select_sql
sub select_sql
{
    my($errstack_ref, $dbh, $select_results_arrayref, $sql_command) = @_;
    my($sth, @row);

    @{$select_results_arrayref} = ();
    debug($errstack_ref, 10, "select_sql: running \"$sql_command\" ...");
    $sth = $dbh->prepare($sql_command);
    $sth->execute();
    while (@row = $sth->fetchrow_array) {
         #  We can't push a reference to @row onto the caller's array, because
         #  @row will shortly be reset and that means the data in that is lost.
         #  (Oddly this doesn't result in multiple entries of the same anonymous
         #  array, but rather in empty arrays for all but the last element.)
         push @{$select_results_arrayref}, [@row];
    }

    return($OK);
}

#DIFFSYNC: select_sql_count
sub select_sql_count
{
    my($errstack_ref, $dbh, $count_ref, $sql_statement) = @_;
    my(@select_results, $rc);

    if (($rc=select_sql($errstack_ref, $dbh, \@select_results, $sql_statement)) != $OK) {
        return($rc);
    }
    foreach my $select_result (@select_results) {
        (${$count_ref}) = @{$select_result};
    }
    return($OK);
}

#DIFFSYNC: execute_sql_qm
sub execute_sql_qm
{
    my($errstack_ref, $dbh, $sql_command, $value_arrayref) = @_;

    debug($errstack_ref, 10, "execute_sql_qm: running \"$sql_command\" ...");
    if (not defined $dbh->do($sql_command, {}, @{$value_arrayref})) {
        error($errstack_ref, 'ade_err_misc', $dbh->errstr);
        return($FAIL);
    }

    return($OK);
}

#DIFFSYNC: select_sql_qm
sub select_sql_qm
{
    my($errstack_ref, $dbh, $select_results_arrayref, $sql_command, $value_arrayref) = @_;
    my($sth, @row);

    @{$select_results_arrayref} = ();
    debug($errstack_ref, 10, "select_sql_qm: sql_command=\"$sql_command\" ...");
    debug($errstack_ref, 10, sprintf 'select_sql_qm: sql_value=(%s)', join ', ', @{$value_arrayref});
    $sth = $dbh->prepare($sql_command);
    $sth->execute(@{$value_arrayref});
    while (@row = $sth->fetchrow_array) {
         #  We can't push a reference to @row onto the caller's array, because
         #  @row will shortly be reset and that means the data in that is lost.
         #  (Oddly this doesn't result in multiple entries of the same anonymous
         #  array, but rather in empty arrays for all but the last element.)
         push @{$select_results_arrayref}, [@row];
    }

    return($OK);
}

#DIFFSYNC: select_sql_count_qm
sub select_sql_count_qm
{
    my($errstack_ref, $dbh, $count_ref, $sql_statement, $value_arrayref) = @_;
    my(@select_results, $rc);

    if (($rc=select_sql_qm($errstack_ref, $dbh, \@select_results, $sql_statement, $value_arrayref)) != $OK) {
        return($rc);
    }
    foreach my $select_result (@select_results) {
        (${$count_ref}) = @{$select_result};
    }
    return($OK);
}

#DIFFSYNC: begin_sql_transaction
sub begin_sql_transaction
{
    my($errstack_ref, $dbh) = @_;
    my($sql_statement);

    assert_outside_sql_transaction($errstack_ref);
    $_inside_sql_transaction_flag = 1;

    $sql_statement = 'BEGIN IMMEDIATE TRANSACTION;';
    return(execute_sql($errstack_ref, $dbh, $sql_statement));
}

#DIFFSYNC: end_sql_transaction
sub end_sql_transaction
{
    my($errstack_ref, $dbh) = @_;
    my($sql_statement);


    assert_inside_sql_transaction($errstack_ref);
    $_inside_sql_transaction_flag = 0;

    $sql_statement = 'END TRANSACTION;';
    return(execute_sql($errstack_ref, $dbh, $sql_statement));
}

#DIFFSYNC: assert_inside_sql_transaction
sub assert_inside_sql_transaction
{
    my($errstack_ref) = @_;

    if (not $_inside_sql_transaction_flag) {
        internal($errstack_ref, 'assert_inside_sql_transaction: not inside a transaction!');
    }

    return($OK);
}

#DIFFSYNC: assert_outside_sql_transaction
sub assert_outside_sql_transaction
{
    my($errstack_ref) = @_;

    if ($_inside_sql_transaction_flag) {
        internal($errstack_ref, 'assert_outside_sql_transaction: not outside a transaction!');
    }

    return($OK);
}

#DIFFSYNC: show_sql_transaction
sub show_sql_transaction
{
    internal([], "show_sql_transaction: not implemented");
}

#DIFFSYNC: connect_sqlite
sub connect_sqlite
{
    my($errstack_ref, $db_file, $db_init_file, $dbh_ref) = @_;
    my($rc, $db_init_needed_flag, $sql_statement);

    debug($errstack_ref, 10, "connect_sqlite: checking $db_file is writable ...");
    if (($rc=check_writable($errstack_ref, $db_file)) != $OK) {
        return($rc);
    }

    $db_init_needed_flag = (-f $db_file) ? 0 : 1;
    debug($errstack_ref, 10, "connect_sqlite: db_init_needed_flag=$db_init_needed_flag");
    if ($db_init_needed_flag) {
        debug($errstack_ref, 10, 'connect_sqlite: initialising database ...');
        if (($rc=initialise_sqlite($errstack_ref, $db_file, $db_init_file, $dbh_ref)) != $OK) {
            return($rc);
        }
    } else {
        debug($errstack_ref, 10, 'connect_sqlite: connecting to existing database ...');
        #  DBI->connect() is noisy if it can't connect. '{PrintError=>0}' quietens it. Okay, we
        #  lose the error it reports but in any case (see next comment) ....
        ${$dbh_ref} = DBI->connect("dbi:SQLite:dbname=$db_file",'','',{PrintError=>0});
        if (not defined ${$dbh_ref}) {
            #  ... we can't examine $DBI::errstr because perlcritic complains and we can't examine
            #  $dbh->errstr because $dbh is undefined.
            error($errstack_ref, 'ade_err_misc', "$db_file: unable to connect to database");
            return($FAIL);
        }
    }
    debug($errstack_ref, 10, 'connect_sqlite: setting timeout and enabling foreign keys ...');
    $sql_statement = 'PRAGMA busy_timeout = 10000;';
    if (($rc=execute_sql($errstack_ref, ${$dbh_ref}, $sql_statement)) != $OK) {
        return($rc);
    }
    $sql_statement = 'PRAGMA foreign_keys = 1;';
    if (($rc=execute_sql($errstack_ref, ${$dbh_ref}, $sql_statement)) != $OK) {
        return($rc);
    }

    return($OK);
}

#DIFFSYNC: disconnect_sqlite
sub disconnect_sqlite
{
    internal([], "disconnect_sqlite: not implemented");
}

#DIFFSYNC: initialise_sqlite
sub initialise_sqlite
{
    my($errstack_ref, $db_file, $db_init_file, $dbh_ref) = @_;
    my($fp, $sql, $dn, $rc);

    info($errstack_ref, 'initialising database ...');

    #  slurp SQL from init file.
    if (not open $fp, '<', $db_init_file) {
        error($errstack_ref, 'ade_err_misc', "$db_init_file: failed to open DB init file");
        return($FAIL);
    }
    #  Scope for slurp.
    {
        local $/ = undef;
        $sql = <$fp>;
    }
    close $fp;

    #  Create database's parent directories if needed.
    debug($errstack_ref, 10, 'db_init: creating leading directories ...');
    $dn = File::Basename::dirname($db_file);
    if (-l $dn or (-e $dn and not -d $dn)) {
        error($errstack_ref, 'ade_err_misc', "$dn: exists already but is not a directory");
        return($FAIL);
    } elsif (not -d $dn and not mkdir $dn) {
        error($errstack_ref, 'ade_err_misc', "$dn: unable to make directory");
        return($FAIL);
    }
    register_temp_file($errstack_ref, $db_file);

    #  Connect to database for first time.
    debug($errstack_ref, 10, "db_init: connecting to database ($db_file) for first time ...");
    #  DBI->connect() is noisy if it can't connect. '{PrintError=>0}' quietens it. Okay, we
    #  lose the error it reports but in any case (see next comment) ....
    ${$dbh_ref} = DBI->connect("dbi:SQLite:dbname=$db_file",'','',{PrintError=>0});
    if (not defined ${$dbh_ref}) {
        #  ... we can't examine $DBI::errstr because perlcritic complains and we can't examine
        #  $dbh->errstr because $dbh is undefined.
        error($errstack_ref, 'ade_err_misc', "$db_file: unable to connect to database");
        return($FAIL);
    }

    #  Initialise to database with above-slurped SQL.
    debug($errstack_ref, 10, 'db_init: executing above-slurped SQL ...');
    #  Multiple SQL statements can't be executed at once, unless enclosed in BEGIN..END. See
    #  https://stackoverflow.com/questions/4217306/execute-sql-file-in-perl.
    ${$dbh_ref}->{'sqlite_allow_multiple_statements'} = 1;
    if (($rc=execute_sql($errstack_ref, ${$dbh_ref}, "BEGIN; $sql; END;" )) != $OK) {
        ${$dbh_ref}->disconnect;
        unlink $db_file;
        error($errstack_ref, 'ade_err_misc', "$db_init_file: failed to load DB init file (hint: is its syntax ok?)");
        return($rc);
    }
    ${$dbh_ref}->{'sqlite_allow_multiple_statements'} = 0;

    #  If we get this far then we initialised the database and should preserve it.
    deregister_temp_file($errstack_ref, $db_file);
    return($OK);
}

#DIFFSYNC: validate_sql_schema_version
sub validate_sql_schema_version
{
    my($errstack_ref, $dbh, $code_schema_conformancy, $progname) = @_;
    my($rc, $db_schema_conformancy);

    if (($rc=get_sql_schema_version($errstack_ref, $dbh, \$db_schema_conformancy)) != $OK) {
        return($rc);
    }

    if ($db_schema_conformancy < $code_schema_conformancy) {
        error($errstack_ref, 'ade_err_misc', "database schema is too old (do you need to run '$progname --upgrade'?)");
        return($FAIL);
    } elsif ($db_schema_conformancy > $code_schema_conformancy) {
        error($errstack_ref, 'ade_err_misc', "database schema is too new (do you need to upgrade $progname?)");
        return($FAIL);
    }

    return($OK);
}

#DIFFSYNC: get_sql_schema_version
sub get_sql_schema_version
{
    my($errstack_ref, $dbh, $db_schema_conformancy_ref) = @_;
    my($rc, $sql_statement, @select_results);

    $sql_statement = 'PRAGMA user_version;';

    #  PRAGMA isn't a SELECT, but execute() treats it like one, returning
    #  the output in a results-like array of tuples.
    if (($rc=select_sql($errstack_ref, $dbh, \@select_results, $sql_statement)) != $OK) {
        return($rc);
    }
    ${$db_schema_conformancy_ref} = ${$select_results[0]}[0];
    debug($errstack_ref, 10, "get_sql_schema_version: read conformancy ${$db_schema_conformancy_ref} from database");

    return($OK);
}

#DIFFSYNC: set_sql_schema_version
sub set_sql_schema_version
{
    my($errstack_ref, $dbh, $db_schema_conformancy) = @_;
    my($rc, $sql_statement);

    $sql_statement = "PRAGMA user_version = $db_schema_conformancy;";
    if (($rc=execute_sql($errstack_ref, $dbh, $sql_statement)) != $OK) {
        return($rc);
    }

    return($OK);
}

#DIFFSYNC: edit_sqlite
sub edit_sqlite  ## no critic (ProhibitExcessComplexity)
{
    my($errstack_ref, $dbh, $db_file) = @_;

    my($tmp_sql_file, $sqlite_cmdline, $rc, $editor_cmdline, $preedit_md5sum, $postedit_md5sum);
    my(@triggers, @indexes, @tables, $trigger, $index, $table, $sql_statement, @select_results, $view, @views);
    my($fp, $sql, $l);

    #  Guts
    #  Dump database to SQL file.
    debug($errstack_ref, 10, 'edit: dumping database ...');
    $tmp_sql_file = sprintf '%s/%s.%s.sql', "/tmp", $_progname, $$;
    #  sqlite3's stdin is a terminal, which will make it display
    #  '-- Loading resources from /home/alexis/.sqliterc'. '-batch'
    #  will prevent that. Note that other calls to sqlite3 in this
    #  script have stdin redirected for various reasons, and so do
    #  not need the '-batch' workaround.
    $sqlite_cmdline = sprintf 'sqlite3 -batch %s .dump > %s', $db_file, $tmp_sql_file;
    debug($errstack_ref, 10, "edit: sqlite_cmdline=[$sqlite_cmdline]");
    register_temp_file($errstack_ref, $tmp_sql_file);
    $rc = system $sqlite_cmdline;
    if ($rc != 0) {
        #  We don't know if tmp_sql_file was created or not, so remove quietly.
        if (-f $tmp_sql_file and not unlink $tmp_sql_file) {
            error($errstack_ref, 'rak_err_misc', 'unlink failed');
            return($FAIL);
        }
        deregister_temp_file($errstack_ref, $tmp_sql_file);
        error($errstack_ref, 'ade_err_misc', 'failed to dump database');
        return($FAIL);
    }

    #  Note checksum
    debug($errstack_ref, 10, 'edit: checksumming ...');
    if (($rc=get_md5sum($errstack_ref, $tmp_sql_file, \$preedit_md5sum)) != $OK) {
        unlink $tmp_sql_file;
        deregister_temp_file($errstack_ref, $tmp_sql_file);
        return($rc);
    }

    #  Edit.
    debug($errstack_ref, 10, 'edit: editing ...');
    $editor_cmdline = sprintf '%s %s', defined $ENV{'EDITOR'} ? $ENV{'EDITOR'} : 'vi', $tmp_sql_file;
    debug($errstack_ref, 10, "edit: editor_cmdline=[$editor_cmdline]");
    $rc = system $editor_cmdline;
    if ($rc != 0) {
        unlink $tmp_sql_file;
        deregister_temp_file($errstack_ref, $tmp_sql_file);
        error($errstack_ref, 'ade_err_misc', 'failed to edit');
        return($FAIL);
    }

    #  Note new checksum
    debug($errstack_ref, 10, 'edit: checksumming again ...');
    if (($rc=get_md5sum($errstack_ref, $tmp_sql_file, \$postedit_md5sum)) != $OK) {
        unlink $tmp_sql_file;
        deregister_temp_file($errstack_ref, $tmp_sql_file);
        return($FAIL);
    }
    debug($errstack_ref, 10, "edit: preedit_md5sum=$preedit_md5sum, postedit_md5sum=$postedit_md5sum");

    #  If no changes do nothing.
    if ($preedit_md5sum eq $postedit_md5sum) {
        info($errstack_ref, 'no changes detected');
        unlink $tmp_sql_file;
        deregister_temp_file($errstack_ref, $tmp_sql_file);
        return($OK);
    }

    #  Check changes are loadable (with foreign keys enforced).
    info($errstack_ref, 'changes detected; validating before applying ...');
    $sqlite_cmdline = "sh -c 'sed \"s/PRAGMA foreign_keys=OFF;/PRAGMA foreign_keys=ON;/\" $tmp_sql_file | sqlite3'";
    debug($errstack_ref, 10, "edit: sqlite_cmdline=[$sqlite_cmdline]");
    $rc = system $sqlite_cmdline;
    if ($rc != 0) {
        error($errstack_ref, 'ade_err_misc', 'validation failed (hint: did you introduce a syntax error?)');
        unlink $tmp_sql_file;
        deregister_temp_file($errstack_ref, $tmp_sql_file);
        return($FAIL);
    }

    #  Delete all tables and reload all from within a transaction to ensure database not emptied.
    #  No, that won't work because vacuuming (which is necessary else things appear to still exist
    #  at least to the point where their existence blocks their creation) is not allowed within
    #  a transaction.
    #
    #  How about we preserve the database just created as part of the load test and slide that
    #  into place? No, we can't do that because that would require closing the database before
    #  and reopening it after and this function doesn't want to be concerned with that kind
    #  of stuff; it just wants to use the passed cursor to do all database accesses.
    #
    #  Hmm ... okay, so let's load the new SQL into memory (so if it fails we've not deleted
    #  anything yet) and then delete and load.
    #
    #  Load SQL ...
    if (not open $fp, '<', $tmp_sql_file) {
        internal($errstack_ref, "edit: $tmp_sql_file: failed to open");
    }
    #  We will load the dump *inside* a transaction so we need to filter out the transaction
    #  delimiters from the dump. We also don't want the dump tampering with our foreign key
    #  settings.
    $sql = '';
    while ($l = <$fp>) {
        $sql .= $l if (not $l ~~ ["PRAGMA foreign_keys=OFF;\n", "BEGIN TRANSACTION;\n", "COMMIT;\n"]);
    }
    close $fp;
    unlink $tmp_sql_file;
    deregister_temp_file($errstack_ref, $tmp_sql_file);

    #  It looks like PRAGMA foreign_keys can't be changed inside a transaction.
    #  I only needed to do in order to ensure that *tables* can be dropped in
    #  any order. But by putting it outside the transaction the scope of the
    #  pragma is obviously increased. So it's just as well that the dump
    #  was already loaded earlier as a test *with* foreign_keys enabled.
    $sql_statement = 'PRAGMA foreign_keys = 0;';
    if (($rc=execute_sql($errstack_ref, $dbh, $sql_statement)) != $OK) {
        return($rc);
    }

    begin_sql_transaction($errstack_ref, $dbh);

    #  ... determine old content ...
    $sql_statement = "SELECT   name\n" .
                     "FROM     sqlite_master\n" .
                     'WHERE    type = \'view\';';
    if (($rc=select_sql($errstack_ref, $dbh, \@select_results, $sql_statement)) != $OK) {
        return($rc);
    }
    @views = map { ${$_}[0] } @select_results;
    $sql_statement = "SELECT   name\n" .
                     "FROM     sqlite_master\n" .
                     "WHERE    type = 'index' AND\n" .
                     '         name NOT LIKE \'sqlite_autoindex_%\';';
    if (($rc=select_sql($errstack_ref, $dbh, \@select_results, $sql_statement)) != $OK) {
        return($rc);
    }
    @indexes = map { ${$_}[0] } @select_results;
    $sql_statement = "SELECT   name\n" .
                     "FROM     sqlite_master\n" .
                     'WHERE    type = \'trigger\';';
    if (($rc=select_sql($errstack_ref, $dbh, \@select_results, $sql_statement)) != $OK) {
        return($rc);
    }
    @triggers = map { ${$_}[0] } @select_results;
    $sql_statement = "SELECT   name\n" .
                     "FROM     sqlite_master\n" .
                     "WHERE     type = 'table';\n";
    if (($rc=select_sql($errstack_ref, $dbh, \@select_results, $sql_statement)) != $OK) {
        return($rc);
    }
    @tables = map { ${$_}[0] } @select_results;

    #  ... drop old content ...
    foreach my $view (@views) {
        debug($errstack_ref, 10, "edit: dropping view $view ...");
        $sql_statement = "DROP VIEW $view;";
        if (($rc=execute_sql($errstack_ref, $dbh, $sql_statement)) != $OK) {
            return($rc);
        }
    }
    foreach my $index (@indexes) {
        debug($errstack_ref, 10, "edit: dropping index $index ...");
        $sql_statement = "DROP INDEX $index;";
        if (($rc=execute_sql($errstack_ref, $dbh, $sql_statement)) != $OK) {
            return($rc);
        }
    }
    foreach my $trigger (@triggers) {
        debug($errstack_ref, 10, "edit: dropping trigger $trigger ...");
        $sql_statement = "DROP TRIGGER $trigger;";
        if (($rc=execute_sql($errstack_ref, $dbh, $sql_statement)) != $OK) {
            return($rc);
        }
    }
    foreach my $table (@tables) {
        debug($errstack_ref, 10, "edit: dropping table $table ...");
        $sql_statement = "DROP TABLE $table;";
        if (($rc=execute_sql($errstack_ref, $dbh, $sql_statement)) != $OK) {
            return($rc);
        }
    }

    #  ... load new SQL ...
    debug($errstack_ref, 10, 'edit: enabling multi-statement execute in order to load dump ...');
    $dbh->{'sqlite_allow_multiple_statements'} = 1;
    if (($rc=execute_sql($errstack_ref, $dbh, $sql)) != $OK) {
        return($rc);
    }
    debug($errstack_ref, 10, 'edit: disabling multi-statement execute now that dump has been loaded ...');
    $dbh->{'sqlite_allow_multiple_statements'} = 0;

    #  See comment at beginning of transaction regarding why
    #  transaction ended and *then* PRAGMA foreign_keys modified.

    debug($errstack_ref, 10, 'edit: ending transaction ...');
    end_sql_transaction($errstack_ref, $dbh);

    debug($errstack_ref, 10, 'edit: enforcing foreign keys ...');
    $sql_statement = 'PRAGMA foreign_keys = 1;';
    if (($rc=execute_sql($errstack_ref, $dbh, $sql_statement)) != $OK) {
        return($rc);
    }

    return($OK);
}

#DIFFSYNC: upgrade_database
sub upgrade_database
{
    my($errstack_ref, $dbh, $db_file, $code_schema_conformancy, $upgrade_fncs_ref) = @_;
    my($rc, $db_schema_conformancy, $old_db_schema_conformancy, $db_file_backup);

    debug($errstack_ref, 10, 'upgrade_database: disabling foreign keys ...');
    execute_sql($errstack_ref, $dbh, 'PRAGMA foreign_keys = 0;');
    if (($rc=begin_sql_transaction($errstack_ref, $dbh)) != $OK) {
        return($rc);
    }

    debug($errstack_ref, 10, 'upgrade_database: get database conformancy ...');
    if (($rc=get_sql_schema_version($errstack_ref, $dbh, \$db_schema_conformancy)) != $OK) {
        #  Don't end transaction! We want to roll back!
        return($rc);
    }
    debug($errstack_ref, 10, "upgrade_database: db_schema_conformancy=$db_schema_conformancy, code_schema_conformancy=$code_schema_conformancy");

    if ($db_schema_conformancy == $code_schema_conformancy) {
        #  Don't end transaction! We want to roll back!
        error($errstack_ref, 'ade_err_misc', 'no upgrade necessary');
        return($FAIL);
    }

    #  Back up database before starting.
    $db_file_backup = "$db_file.$$";
    info($errstack_ref, "backing up database to $db_file_backup ...");
    $rc = system 'cp', $db_file, $db_file_backup;
    if ($rc != 0) {
        internal($errstack_ref, 'upgrade_database: failed to back up database prior to upgrade');
    }

    #  Loop applying upgrades.
    while ($db_schema_conformancy != $code_schema_conformancy) {
        info($errstack_ref, sprintf 'upgrading database schema from version %d to version %d ...', $db_schema_conformancy, $db_schema_conformancy+1);

        #debug($errstack_ref, 10, 'upgrade_database: calling %s() ...' % (upgrade_fncs[db_schema_conformancy].__name__))
        if (($rc=${$upgrade_fncs_ref}[$db_schema_conformancy]($errstack_ref, $dbh)) != $OK) {
            #  Don't end transaction! We want to roll back!
            return($rc);
        }

        #  Refresh old and new schema conformancy values.
        $old_db_schema_conformancy = $db_schema_conformancy;
        if (($rc=get_sql_schema_version($errstack_ref, $dbh, \$db_schema_conformancy)) != $OK) {
            #  Don't end transaction! We want to roll back!
            return($rc);
        }

        #  Check the upgrade function bumped the database schema conformancy.
        if ($db_schema_conformancy == $old_db_schema_conformancy) {
            internal($errstack_ref, 'upgrade_database: partial upgrade failed to change db_schema_conformancy');
        }
    }

    if (($rc=end_sql_transaction($errstack_ref, $dbh)) != $OK) {
        return($rc);
    }

    execute_sql($errstack_ref, $dbh, 'PRAGMA foreign_keys = 1;');
    return($OK);
}

#DIFFSYNC: filter
sub filter
{
    internal([], "filter: not implemented");
}

#DIFFSYNC: blank_sql_null
sub blank_sql_null
{
    internal([], "blank_sql_null: not implemented");
}

########################################################################
#
#  Public functions: variable related functions
#
########################################################################

#DIFFSYNC: inherit
sub inherit
{
    internal([], "inherit: not implemented");
}

#DIFFSYNC: global
sub global
{
    internal([], "global: not implemented");
}

########################################################################
#
#  Public functions: locking related functions
#
########################################################################

#DIFFSYNC: lock
sub lock
{
    my($errstack_ref, $lock_file) = @_;
    my($tmp_lock_file, $old_umask, $rc, $running_flag, $lock_handle, $pid);

    #  Create world-readable temporary lock
    $tmp_lock_file = $lock_file . ".$$";
    unlink $tmp_lock_file if (-f $tmp_lock_file);
    $old_umask = umask 0022;
    register_temp_file($errstack_ref, $tmp_lock_file);
    if (not open $lock_handle, '>', $tmp_lock_file) {
        deregister_temp_file($errstack_ref, $tmp_lock_file);
        error($errstack_ref, 'ade_err_access', $tmp_lock_file, 'create');
        return($FAIL);
    }
    umask $old_umask;  ## no critic (RequireCheckedSyscalls)
    print $lock_handle "$$\n";
    close $lock_handle;

    #  If can easily lock, return
    if (link $tmp_lock_file, $lock_file) {
        #  We haven't registered LOCK_FILE before now 'cos weren't certain it was ours. We are now.
        register_temp_file($errstack_ref, $lock_file);
        unlink $tmp_lock_file;
        deregister_temp_file($errstack_ref, $tmp_lock_file);
        return($OK);
    }

    #  If lock file not empty and not stale; return
    if (not open $lock_handle, '<', $lock_file) {
        ade_err_error($errstack_ref, 'ade_err_access', $lock_file, 'open');
        return($FAIL);
    }
    $pid = <$lock_handle>;
    close $lock_handle;
    chomp $pid;
    if ($pid =~ /^[1-9][0-9]*$/ and -d "/proc/$pid") {
        unlink $tmp_lock_file;
        deregister_temp_file($errstack_ref, $tmp_lock_file);
        error($errstack_ref, 'ade_err_misc', "lock held by pid $pid");
        return($FAIL);
    }

    #  Remove corrupt or stale lock file
    warning($errstack_ref, 'ade_err_misc', "$lock_file: empty or stale; removing ...");
    unlink $lock_file;

    #  Try to lock again (this time we are sure that the lock file will be ours so register now)
    register_temp_file($errstack_ref, $lock_file);
    if (link $tmp_lock_file, $lock_file) {
        unlink $tmp_lock_file;
        deregister_temp_file($errstack_ref, $tmp_lock_file);
        return($OK);
    }

    #  It failed in a way we don't understand
    internal($errstack_ref, "lock: locking failed in way not understood");
}

#DIFFSYNC: unlock
sub unlock
{
    my($errstack_ref, $lock_file) = @_;

    unlink $lock_file;

    #
    #  If we get this far everything is ok.
    #

    return($OK);
}

########################################################################
#
#  Public functions: directory content management functions
#
########################################################################

#DIFFSYNC: move_compressed_file
sub move_compressed_file
{
    my($errstack_ref, $srcname, $dstname) = @_;
    my($rc, $src_handle, $dst_handle);

    debug($errstack_ref, 50, "move_compressed_file: sof (srcname=$srcname, dstname=$dstname");

    if (($srcname =~ /\.gz$/ and $dstname =~ /\.gz$/) or
            ($srcname =~ /\.Z$/ and $dstname =~ /\.Z$/) or
            ($srcname !~ /\.(?:Z|gz)$/ and $dstname  !~ /\.(?:Z|gz)$/)) {
        debug($errstack_ref, 50, 'move_compressed_file: using mv ...');
        #  Linux 'mv' can go interactive, so stdin redirected to avoid this.
        if (($rc=File::Copy::move($srcname, $dstname)) != 0) {
            debug($errstack_ref, 50, sprintf 'move_compressed_file: exit: %d, sig: %d, dump: %d', ($rc>>8), ($rc&127), ($rc&128));
            error($errstack_ref, 'ade_err_access', $srcname, 'mv');
            return($FAIL);
        }
        debug($errstack_ref, 50, 'move_compressed_file: using mv done');
    } else {
        debug($errstack_ref, 50, 'move_compressed_file: using open_compressed_file_for_reading|open_compressed_file_for_writing ...');
        if (($rc=open_compressed_file_for_reading($errstack_ref, $srcname, \$src_handle)) != $OK) {
            error($errstack_ref, 'ade_err_access', $srcname, 'open');
            return($rc);
        }
        if (($rc=open_compressed_file_for_writing($errstack_ref, $dstname, \$dst_handle)) != $OK) {
            error($errstack_ref, 'ade_err_access', $dstname, 'open');
            return($rc);
        }
        while (<$src_handle>) {
            #  See 'perldoc -f print' for why $_ must be specified even though default.
            print $dst_handle $_;
        }
        close $src_handle;
        close $dst_handle;
        if (not unlink $srcname) {
            error($errstack_ref, 'ade_err_access', $srcname, 'unlink');
            return($FAIL);
        }
    }

    return($OK);
}

########################################################################
#
#  Public functions: miscellaneous
#   
########################################################################

#  (none - and ADE should keep it that way!)

########################################################################
#
#  Public functions: access module-private variable
#
########################################################################

#DIFFSYNC: get_progname
sub get_progname
{
    my($errstack_ref, $progname_ref) = @_;

    ${$progname_ref} = $_progname;

    return($OK);
}

#DIFFSYNC: get_simulate
sub get_simulate
{
    my ($errstack_ref, $verboselevel_ref) = @_;

    ${$verboselevel_ref} = $_simulate;

    return($OK);
}

#DIFFSYNC: get_verboselevel
sub get_verboselevel
{
    my ($errstack_ref, $verboselevel_ref) = @_;

    ${$verboselevel_ref} = $_verboselevel;

    return($OK);
}

#DIFFSYNC: set_progname
sub set_progname
{
    my($errstack_ref, $progname) = @_;

    $_progname = $progname;

    return($OK);
}

#DIFFSYNC: set_simulate
sub set_simulate
{
    my($errstack_ref, $simulate) = @_;

    $_simulate = $simulate;

    return($OK);
}

#DIFFSYNC: set_verboselevel
sub set_verboselevel
{
    my($errstack_ref, $verboselevel) = @_;

    $_verboselevel = $verboselevel;

    return($OK);
}

#DIFFSYNC: set_callbacks
sub set_callbacks
{
    my($errstack_ref, $usage_text_getter_ref, $version_text_getter_ref, $listpaths_text_getter_ref) = @_;
    my($subref);

    $_usage_callback_ref = $usage_text_getter_ref;
    $_version_callback_ref = $version_text_getter_ref;
    $_paths_callback_ref = $listpaths_text_getter_ref;

    foreach my $func_ref ($_usage_callback_ref, $_version_callback_ref, $_paths_callback_ref) {
        if (!($subref = _validate_function($func_ref))) {
            internal($errstack_ref, 'set_callbacks: one of usage/version/listpaths: not a function');
        }
    }

    return $OK;
}

#DIFFSYNC: set_messaging_parameters
sub set_messaging_parameters
{
    my($errstack_ref, %parameters) = @_;

    #  Look at what was passed
    foreach my $key (keys %parameters) {
        if ($key eq 'stack') {
            @{$parameters{$key}} = ();
        } elsif ($key eq 'dumpall') {
            $_dump_whole_error_stack_flag = $parameters{$key};
        } elsif ($key eq 'facility') {
            $_display_error_stack_syslog_facility = $parameters{$key};
        } elsif ($key eq 'logfile') {
            $_display_error_stack_log_file_filename = $parameters{$key};
        } elsif ($key eq 'level') {
            $_verboselevel = $parameters{$key};
        } elsif ($key eq 'writers') {
            @_display_callback_refs = map { $_writer_id_to_function{$_} } @{$parameters{$key}};
        } else {
            internal($errstack_ref, "set_messaging_parameters: $key: unexpected key");
        }
    }

    return($OK);
}

########################################################################
#
#  Module-private functions
#
########################################################################

#DIFFSYNC: _handle_option_V
sub _handle_option_V ## no critic (RequireArgUnpacking, ProhibitUnusedPrivateSubroutines,Capitalization)
{
    return(_handle_option_version(@_));
}

#DIFFSYNC: _handle_option_d
sub _handle_option_d ## no critic (RequireArgUnpacking, ProhibitUnusedPrivateSubroutines)
{
    return(_handle_option_debug(@_));
}

#DIFFSYNC: _handle_option_v
sub _handle_option_v ## no critic (RequireArgUnpacking, ProhibitUnusedPrivateSubroutines)
{
    return(_handle_option_verbose(@_));
}

#DIFFSYNC: _handle_option_h
sub _handle_option_h ## no critic (RequireArgUnpacking, ProhibitUnusedPrivateSubroutines)
{
    return(_handle_option_help(@_));
}

#DIFFSYNC: _handle_option_p
sub _handle_option_p ## no critic (RequireArgUnpacking, ProhibitUnusedPrivateSubroutines)
{
    return(_handle_option_paths(@_));
}

#DIFFSYNC: _handle_option_n
sub _handle_option_n ## no critic (RequireArgUnpacking, ProhibitUnusedPrivateSubroutines)
{
    return(_handle_option_simulate(@_));
}

#DIFFSYNC: _handle_option_version
sub _handle_option_version
{
    $_show_version_flag = 1;
    return($OK);
}

#DIFFSYNC: _handle_option_debug
sub _handle_option_debug
{
    my($errstack_ref, $verboselevel) = @_;

    return(set_verboselevel($errstack_ref, $verboselevel));
}

#DIFFSYNC: _handle_option_verbose
sub _handle_option_verbose
{
    my($errstack_ref) = @_;

    return(set_verboselevel($errstack_ref, 3));
}

#DIFFSYNC: _handle_option_help
sub _handle_option_help
{
    my($errstack_ref) = @_;

    $_show_help_flag = 1;
    return($OK);
}

#DIFFSYNC: _handle_option_paths
sub _handle_option_paths
{
    $_show_paths_flag = 1;
    return($OK);
}

#DIFFSYNC: _handle_option_simulate
sub _handle_option_simulate
{
    my($errstack_ref) = @_;

    return(set_simulate($errstack_ref, 1));
}

#DIFFSYNC: _handle_signal
sub _handle_signal   ##  no critic (RequireFinalReturn)
{
    my($errstack_ref) = [];

    set_messaging_parameters($errstack_ref, stack=>$errstack_ref);

    info($errstack_ref, 'clearing up ...');
    _exit2($errstack_ref, 4);
}

#DIFFSYNC: _validate_error_key
sub _validate_error_key
{

    my($errstack_ref, $defined_errors_hash_key) = @_;
    my($i, $found);

    #  Scan over the list of registered hashes ...
    $found = 0;
    foreach my $i (0..$#_registered_defined_errors_hash_refs_array) {
        if (defined ${$_registered_defined_errors_hash_refs_array[$i]}{$defined_errors_hash_key}) {
            $found = 1;
            last;
        }
    }
    internal($errstack_ref, "$defined_errors_hash_key: unknown error") if (not $found);

    return($OK);
}

#DIFFSYNC: _call_registered_message_writers
sub _call_registered_message_writers
{
    my($errstack_ref, $template, $message, $level, $syslog_level) = @_;

    $template =~ s/%MESSAGE/$message/;
    $template =~ s/%LEVEL/$level/;

    foreach my $writerfunc_ref (@_display_callback_refs) {
        &{$writerfunc_ref}($errstack_ref, $template, $level, $syslog_level);
    }

    return($OK);
}

#DIFFSYNC: _push
sub _push
{
    internal([], "_push: not implemented");
}

#DIFFSYNC: _pop
sub _pop
{
    internal([], "_pop: not implemented");
}

#DIFFSYNC: _pop_by_value
sub _pop_by_value
{
    my($errstack_ref, $listname, @items) = @_;

    foreach my $item (@items) {
        @{$_registers{$listname}} = grep { $_ ne $item } @{$_registers{$listname}};
    }
    return($OK);
}

#DIFFSYNC: _pop_all
sub _pop_all
{
    internal([], "_pop_all: not implemented");
}

#DIFFSYNC: _join
sub _join
{
    internal([], "_join: not implemented");
}

#DIFFSYNC: _internal
sub _internal
{
    my($errstack_ref, $message) = @_;

    return(_call_registered_message_writers($errstack_ref, 'INTERNAL ERROR: %MESSAGE', $message, 0, 'crit'));
}

#DIFFSYNC: _error
sub _error
{
    my($errstack_ref, $message) = @_;

    return(_call_registered_message_writers($errstack_ref, 'ERROR: %MESSAGE', $message, 1, 'err'));
}

#DIFFSYNC: _warning
sub _warning
{
    my($errstack_ref, $message) = @_;

    return(_call_registered_message_writers($errstack_ref, 'WARNING: %MESSAGE', $message, 2, 'warning'));
}

#DIFFSYNC: _info
sub _info
{
    my($errstack_ref, $message) = @_;

    return(_call_registered_message_writers($errstack_ref, 'INFO: %MESSAGE', $message, 3, 'info'));
}

#DIFFSYNC: _debug
sub _debug
{
    my($errstack_ref, $level, $message) = @_;

    return(_call_registered_message_writers($errstack_ref, 'DEBUG[%LEVEL]: %MESSAGE', $message, $level, 'debug'));
}

#DIFFSYNC: _display_error_stack_stderr
sub _display_error_stack_stderr
{
    my($errstack_ref, $text, $level, $syslog_level) = @_;

    if ($level > $_verboselevel) {
        return($OK);
    }
    print STDERR "$_progname: $text\n";

    return($OK);
}

#DIFFSYNC: _display_error_stack_log_file
sub _display_error_stack_log_file
{
    my($errstack_ref, $text, $level, $syslog_level) = @_;
    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst,$handle);

    if (not defined $_display_error_stack_log_file_filename) {
        return($OK) 
    }

    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
    if (not open $handle, '>>', $_display_error_stack_log_file_filename) {
        error($errstack_ref, 'ade_err_access', $_display_error_stack_log_file_filename, 'open');
        return($FAIL);
    }
    printf $handle "%04d/%02d/%02dT%02d:%02d:%02d: %s\n", $year+1900, $mon+1, $mday, $hour, $min, $sec, $text;
    close $handle;

    return($OK);
}

#DIFFSYNC: _display_error_stack_syslog
sub _display_error_stack_syslog
{
    my($errstack_ref, $text, $level, $syslog_level) = @_;

    if ($level > $_verboselevel) {
        return($OK);
    }
    #  openlog() wants a facility (according to docs) even though it can be specified when
    #  calling syslog().
    openlog($_progname, 'pid', $_display_error_stack_syslog_facility);
    syslog("$_display_error_stack_syslog_facility|$syslog_level", $text);
    closelog();

    return($OK);
}

#DIFFSYNC: _display_error_stack_dev_null
sub _display_error_stack_dev_null
{
    my($errstack_ref, $text, $level, $syslog_level) = @_;

    return($OK);
}

#DIFFSYNC: _initialise
sub _initialise
{
    #  Register the error types that ADE itself will handle. (Note that this function
    #  does not take an error stack, because what error code would it use if it wanted
    #  to report an error, when the error codes have not already been registered!?)
    register_error_types(\%_defined_errors);

    #  Set up auto-clean-up. *THESE ARE DELIBERATELY NOT LOCAL* because we do
    #  not wish to limit their effect to inside this function.
    $SIG{'HUP'}  = \&_handle_signal;   ## no critic (RequireLocalizedPunctuationVars)
    $SIG{'INT'}  = \&_handle_signal;   ## no critic (RequireLocalizedPunctuationVars)
    $SIG{'TERM'} = \&_handle_signal;   ## no critic (RequireLocalizedPunctuationVars)

    #  Function replacements.
    #_replace_function([], 'old_name', 'new_name');
    _replace_function([], 'reset_error_stack', 'set_messaging_parameters');
    _replace_function([], 'eval', 'evaler');
    _replace_function([], 'lock_simple', 'lock');
    _replace_function([], 'unlock_simple', 'unlock');
}

#DIFFSYNC: _validate_function
sub _validate_function {
    #no strict 'refs';
    my $funcname = shift;
    return \&{$funcname} if defined &{$funcname};
    return;
}

#DIFFSYNC: _replace_function
sub _replace_function
{
    my($errstack_ref, $old_fncname, $new_fncname) = @_;
    
    eval "sub $old_fncname
          {
              my(\$errstack_ref, \@other_arguments) = \@_;
              my(\@call_stack, \$subroutine);
              if (defined \$ENV{'ADE_REPLACE_FUNCTION_SILENT'} and \$ENV{'ADE_REPLACE_FUNCTION_SILENT'} ne '') {
              } elsif (defined \$_replace_function_alerted{\$old_fncname}) {
              } else {
                  \@call_stack = map { defined (\$subroutine=(caller(\$_))[3]) ? \$subroutine : () } (0..100);
                  warning(\$errstack_ref, 'ade_err_misc', '$old_fncname() has been superceded by $new_fncname(), call stack is: ' . join ', ', \@call_stack);
                  \$_replace_function_alerted{\$old_fncname} = 1;
              }
              return($new_fncname(\$errstack_ref, \@other_arguments));
          }"
}

#DIFFSYNC: _fork_multi_debug
sub _fork_multi_debug
{
    my($errstack_ref, $now_time, $text) = @_;

    $now_time = Time::HiRes::time() if (not defined $now_time);
    debug($errstack_ref, 40, sprintf 'fork_multi: %02d:%02d:%02d: %s', (localtime $now_time)[2,1,0], $text);

    return;
}

#DIFFSYNC: _exit
#  This contains the *only* call to exit. It may not be called '_exit' as that
#  would trigger "Subroutine _exit redefined at .../ADE.pm line ..." (though
#  I find no documentation for a builtin '_exit()').
sub _exit2
{
    my($errstack_ref, $rc) = @_;

    #  Should be expanded as the shell version to call all
    #  registered functions.

    _delete_all_temp_files($errstack_ref);
    _call_all_exit_functions($errstack_ref);

    #  This line maps ADE function return codes into Unix program exit codes.
    #  It should be the only call to 'exit' anywhere.
    exit(($rc==$OK)?0:1);
}

########################################################################
#
#  Public variables
#
########################################################################

#  This is complicated! $OK, $FAIL, etc are module public
#  variables; accordingly they are listed in the @EXPORT_OK array at the 
#  top of this file. *Other* scripts - those that use this module -
#  *must* refer to them as $ADE::OK, $ADE::FAIL, etc.
#  However, what code *inside* this module has two choices:
#
#  Either the code inside this module *also* refers to them with 
#  $ADE:: prefixes, or we make an *early* call to our(...) to say that 
#  references without the prefix are references to the variable in the 
#  same - i.e. package - scope. The documentation says of our(...):
#
#      "our" makes a lexical alias to a package (i.e. global) variable
#      of the same name in the current package for use within the
#      current lexical scope.
#
#  If we do use our(...) then it has to be done *before* the first reference
#  in this file*, e.g. after the BEGIN{...} and END{...} stanzas.
#
#  A similar situation exists for module-private variables declared with
#  my(...). That declaration must come before the first reference.
#
#  I had hoped to put the only not-inside-function-definitions 
#  references to module-public and module-private variables in the
#  blocks below, but that just won't work. (It does work for the 
#  module-private, as explained above, but not for module-private,
#  about which perl complains about references as missing scope
#  declarations, e.g. with my(...).) Therefore what I have chosen to
#  do is as follows:
#
#  Module-public variables are aliased with our(...) above (remember
#  that aliasing is what our(...) does) but are initialised in this
#  block; module-private variables are declared module-private with my(...)
#  above but are initialised in the block after. So:
#
#  THERE IS A ONE-TO-ONE CORRESPONDENCE BETWEEN VARS HERE AND AT THE
#  TOP! KEEP IT SO!

$OK   = 0;
$FAIL = 1;

########################################################################
#
#  Module-private variables with public access functions
#
########################################################################

($_progname) = ($0 =~ /.*\/([^\/]*)$/);
$_simulate = 0;
$_verboselevel = 2;
$_paths_callback_ref = undef;
$_usage_callback_ref = undef;
$_version_callback_ref = undef;
@_display_callback_refs = (\&_display_error_stack_stderr);

########################################################################
#
#  Other module-private variables
#
########################################################################

%_defined_errors = (
    ade_err_undefined       => { fmt => '%s: undefined %s' },
    ade_err_access          => { fmt => '%s: can\'t %s' },
    ade_err_convert         => { fmt => '%s: couldn\'t convert from %s to %s' },
    ade_err_seeabove        => { fmt => 'error detected; see higher frames for more information' },
    ade_err_invalid         => { fmt => '%s: invalid %s' },
    ade_err_misc            => { fmt => '%s' },
    ade_err_eof             => { fmt => '%s: end of file' },
    ade_err_notimplemented  => { fmt => '%s: not implemented' },
);

%_writer_id_to_function = (
    'stderr'    => \&_display_error_stack_stderr,
    'devnull'   => \&_display_error_stack_dev_null,
    'syslog'    => \&_display_error_stack_syslog,
    'logfile'   => \&_display_error_stack_log_file,
);

$_dump_whole_error_stack_flag = 0;
$_display_error_stack_log_file_filename = undef;
$_display_error_stack_syslog_facility = 'local0';
$_show_paths_flag = 0;
$_show_help_flag = 0;
$_show_version_flag = 0;
$_inside_sql_transaction_flag = 0;
%_registered_opt = ();
%_registers = ();  
@_registered_defined_errors_hash_refs_array = ();
@_registered_opts = ();
%_replace_function_alerted = ();

########################################################################
#
#  Actual code
#
########################################################################

_initialise();

#  Non-zero module exit code
1;