#=============================================================================
# Doloforge::Base : base object for all doloforge classes
#
# Implements really generic methods and functions for all to use...
#
# Full help :
#   perldoc Doloforge::Base
#=============================================================================


package Doloforge::Base;

use strict;
use warnings;

use POSIX qw(setgid setuid getpwnam getgrnam);
use Pod::Usage;
use File::Path;
use File::Copy::Recursive;
use File::Basename;
use Date::Format;
use Unix::Syslog qw(:subs :macros);


#=============================================================================
=encoding utf8

=head1 NAME

Doloforge::Base : Base object for all doloforge classes

=cut


#=============================================================================
# Initialize Unix::Syslog on first use of this module (early in doloforge
# command-line initiaization)
# All configuration is static for the moment...
# See _display_msg() for actual logging.
# cf. syslog(3) for macro definitions

openlog('doloforge', LOG_PID, LOG_USER);

# Debian package libunix-syslog-perl lacks the priorityname() function in Unix::Syslog
# These values are taken from /usr/include/sys/syslog.h
our @prioritynames = (
    'emerg',    # LOG_EMERG   0   /* system is unusable */
    'alert',    # LOG_ALERT   1   /* action must be taken immediately */
    'crit',     # LOG_CRIT    2   /* critical conditions */
    'err',      # LOG_ERR     3   /* error conditions */
    'warning',  # LOG_WARNING 4   /* warning conditions */
    'notice',   # LOG_NOTICE  5   /* normal but significant condition */
    'info',     # LOG_INFO    6   /* informational */
    'debug',    # LOG_DEBUG   7   /* debug-level messages */
);
# Levels of "--verbose" at which each priority is displayed on-screen (does not apply to syslog)
our @prioritydisplay = (
    0,          # LOG_EMERG   0   /* system is unusable */
    0,          # LOG_ALERT   1   /* action must be taken immediately */
    0,          # LOG_CRIT    2   /* critical conditions */
    0,          # LOG_ERR     3   /* error conditions */
    1,          # LOG_WARNING 4   /* warning conditions */
    0,          # LOG_NOTICE  5   /* normal but significant condition */
    2,          # LOG_INFO    6   /* informational */
    3,          # LOG_DEBUG   7   /* debug-level messages */
);


#=============================================================================
# Method new
#
# Creates a new object, giving it the general Doloforge configuration, along with
# the child class configuration.
#   $com = new Doloforge::Command($global, $config);

sub new {
    # Prototype (module) name, and constructor parameters
    my ($proto, $name, $global_config, $class_config) = @_;
    my $class = ref($proto) || $proto;

    # Class initialization
    my $self = {};

    # Instance properties
    $self->{class} = $class;
    $self->{name} = $name;
    $self->{global} = $global_config;
    $self->{config} = $class_config;

    # Return de create instance to the caller...
    return bless($self, $class);
}


#=============================================================================
# Class-method Factory
#
# Creates a new object from a base class name, giving it the general
# Doloforge configuration, and reading the class-specific config file.
# This class-method facilitates full instanciation : require + yaml + new
# Parameters:
#   base: base class name (ie. "Doloforge::Command")
#   name: child class name (ie. "client")
#   config: general doloforge config hash (YAML object)

sub Factory {
    my ($base, $name, $config) = @_;

    # Translate the command name into a full class name
    $name = lc($name);
    my $class = $base . '::' . ucfirst($name);

    # Dynamically Require the class source file (using eval bareword, see man perlmod)
    print "Loading $class\n" if ($config->{verbose} >= 4);
    eval "require $class";
    pod2usage(-exitstatus => 2, -message => $@) if ($@);

    # Read additionnal class-specific config parameters
    my $class_config;
    my $config_file = "$config->{dir}->{conf}/$name.yaml";
    print "Checking config $config_file\n" if ($config->{verbose} >= 4);

    if (-f $config_file) {
        print "Reading config $config_file\n" if ($config->{verbose} >= 4);
        $class_config = Config::YAML->new(config => $config_file);

        # Read the include'd files defined in the class-specific configuration under the "include:" array key
        foreach my $file (@{$class_config->{include}}) {
            # Read the file in a new hash object
            my $include = Config::YAML->new(config => "$config->{dir}->{conf}/$file");

            # The included configuration keys take precedence over all previously defined configuration keys.
            # Ignore the Config::YAML system specific keys (starting with "_" : "_infile", "_outfile", etc.)
            map {$class_config->{$_} = $include->{$_} unless ($_ =~ m/^_/)} keys(%$include);
        }
    }
    
    # Once an instance has been created, we are able to syslog : this is a great place to set the sysloglevel mask
    setlogmask(LOG_UPTO($config->{sysloglevel} + LOG_ERR));

    # Instanciate this class, with the global Doloforge configuration and class-specific one
    return $class->new($name, $config, $class_config);
}


#=============================================================================
# Various methods for general use
#
# Show a message, optionally aborting the current process...
# call : $self->_display_msg(LOG_ERR, "first line", "second line"...);

sub _display_msg {
    my $self = shift;
    my $priority = shift;
    my @lines = @_;

    # Prepend the object name to the prefix, as in:
    #   "cron notice 2007-03-21 11:58:01 (+1s.) [24752]:"
    #   "bulkmail info:"
    my $prefix = "$self->{name} $prioritynames[$priority]";

    # If we wanted to always show timestamps, go on and generate the full prefix...
    if (defined($self->{timestamp})) {
        my $now = time;
        # format = [2007-03-21 11:58:01] (+1s) [24752]
        #$prefix .= ' [' . time2str("%Y-%m-%d %H:%M:%S", $now) . '] (+' . ($now - $self->{timestamp}) . "s) [$$]";
        $prefix .= ' (+' . ($now - $self->{timestamp}) . 's)';
    }

    # If the verbosity level is high enough, print the message, either just be silent
    # Unknown message types (LOG_NOTICE) are always printed, even if they do not exit...
    #if (($priority == LOG_NOTICE) or ($priority <= $self->{global}->{verbose} + LOG_ERR)) {
    if ($prioritydisplay[$priority] <= $self->{global}->{verbose}) {
        # Print each line of the error message, prefixed by the first parameter ($prefix)
        map {print "$prefix: $_\n"} @lines;
    }

    # Always log to syslog: one call for each line, after escaping the %X format-string chars, because we do not use this functionality...
    map {s/%/%%/g} @lines; # this map changes the array cells, so we must not work directly on @_, which can hold read-only values
    map {syslog($priority, "$prefix: $_")} @lines;

    # If $retcode is low enough, then exit. If not (informative message), just continue with the process.
    exit 2 if ($priority <= LOG_ERR);
}

# Shortcuts for the various $self->_display_msg() levels..
sub debug   {_display_msg(shift, LOG_DEBUG, @_)}    # displayed when verbose = 4
sub info    {_display_msg(shift, LOG_INFO, @_)}     # displayed when verbose = 3
sub message {_display_msg(shift, LOG_NOTICE, @_)}   # always displayed
sub warn    {_display_msg(shift, LOG_WARNING, @_)}  # displayed when verbose = 1
sub error   {_display_msg(shift, LOG_ERR, @_)}      # always displayed because verbose >= 0

# If the message must be prefixed by a formatted timestamp, just say it by first calling this method.
# Il will also store the starting timestamp, in order to show the duration of the process (real seconds)
sub show_timestamps {
    my $self = shift;
    $self->{timestamp} = time;
}

# This will log another set of messages directly to the syslog system, specifying
# an independent "facility", no check of the verbose level, etc.
# This is used mainly ("at first") to log invalid recipient addresses for the Bulkmail
# service, which are forwarded by syslog to a central processing server.
sub tosyslog {
    my $self = shift;
    my ($facility, $priority, $format, @formatargs) = @_;

    openlog('doloforge', LOG_PID, $facility);                           # Switch to the specified "facility"...
    setlogmask(LOG_UPTO(LOG_DEBUG));                                    # ...and enable every level
    syslog($priority, $format, @formatargs);                            # Use the standard syslog() call
    openlog('doloforge', LOG_PID, LOG_USER);                            # Then switch back to the "doloforge normal" facility...
    setlogmask(LOG_UPTO($self->{global}->{sysloglevel} + LOG_ERR));     # ...and level (see Factory() and above for the global settings)
}


#=============================================================================
# Return the current date and time in (nearly) ISO format : YYYY-MM-DD hh:mm:ss
# This is much more readable than scalar(localtime)

sub now {
    my $self = shift;

    #my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime;
    #return sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec);

    # This one is from the Date::Format package :
    return time2str("%Y-%m-%d %H:%M:%S", time);
}

sub date {
    my $self = shift;

    # This one is from the Date::Format package :
    return time2str("%Y-%m-%d", time);
}


#=============================================================================
# Format a proper GECOS-formated string, from the passed parameters

sub gecos_string {
    my $self = shift;

    # Get a copy of each desired field, in order to fix their syntax (non-lvalue won't pass s///)
    my @gecos = @_[0..4];

    # chfn(1) : the only restriction placed on the contents of the fields is that no control characters may be present, nor any of comma, colon, or equal sign.
    foreach (@gecos) {
        $_ = '' unless defined; # avoid "Use of uninitialized value in substitution (s///)" / "... in join or string" below
        s/[,:=]+/./g;
    }
    return join(',', @gecos);
}


#=============================================================================
# Check and create the named directory, which belongs to the named gid, with proper setgid+write permissions
# Parameters :
#   $create : 0 or 1, just check or create/update
#   $descr : description of the directory, used when checking, in the message
#   $dirname : directory name to check/create
#   $perm : desired permission (octal number)
#   $user, $group : desired user name and group name for the owner of the directory
#   $skel : skeleton directory to copy upon creation of the directory (never used upon update)

sub dir_entry {
    my $self = shift;
# 20080917/NH    my ($create, $descr, $dirname, $perm, $user, $group, $skel) = @_;
    my ($create, $descr, $dirname, $perm, $user, $group, $skel, $chown_subdirs, $user_subdirs, $group_subdirs) = @_;

    $self->info("Checking $descr directory '$dirname'");

    # If the username begins with a dash, the user actually doesn't matter, so we do not check or modify it...
    # It is still used at creation-time (without its dash), for the beauty-factor of proprer ownership
    my $checkuid = ($user !~ s/^-//);
    my $userid = getpwnam($user);
    my $groupid = getgrnam($group);

    unless (-d $dirname) {
        if ($create) {
            $self->message(sprintf("Creating $descr directory '$dirname', user $user, ownership $userid:$groupid, permissons %04o", $perm));
            mkpath($dirname);
            chown($userid, $groupid, $dirname);
            chmod($perm, $dirname); # Change mod after change group, because setgid may be lost when changing group
# 20080917/NH
#            if ($skel && (-d $skel)) {
#                # Copy the initial skeleton, if provided and existing (a class may provide a non existing skeleton, which is a shortcut for an empty skeleton)
#                # (copy all files in $skel to the new $dirname, unlike "cp -r")
#                $File::Copy::Recursive::KeepMode = undef;
#                File::Copy::Recursive::dircopy($skel, $dirname)
#                    or $self->error($!);
#            }
# 20080917/NH
            $self->skel_copy($skel, $dirname, $chown_subdirs, $user_subdirs, $group_subdirs);
        } else {
            $self->message("Missing $descr directory '$dirname'");
        }
    } else {
        my ($mode, $uid, $gid) = (stat($dirname))[2,4,5];
        $mode &= 07777;
        if (($checkuid and (not defined($userid) or ($uid != $userid))) or (not defined($groupid) or ($gid != $groupid))) {
            if ($create) {
                $self->message("Changing ownership $uid:$gid on $descr directory '$dirname'");
                chown($userid, $groupid, $dirname);
            } else {
                $self->message("Wrong ownership $uid:$gid on $descr directory '$dirname'");
            }
        }
        unless ($mode == $perm) {
            if ($create) {
                $self->message(sprintf("Changing permissons %04o on $descr directory '$dirname'", $mode));
                chmod($perm, $dirname);
            } else {
                $self->message(sprintf("Wrong permissons %04o on $descr directory '$dirname'", $mode));
            }
        }
    }
}


#=============================================================================
# Recursively copy a skeleton directory, not doing it twice, but copying missing entries
# Copies $skel/* files and directories into $dest/ directory (which must exist),
# testing each * entry : do not copy if the same already exist in $dest.
# Parameters :
#   $skel : skeleton directory to copy (files and directories in there are copied in $dest)
#   $dest : destination directory, receiving files and directories from $skel
#   $chown_dirs : developer directories which must be group-writable by developers, thus chown'ed
#   $user : new user to chown, if the item is newly created (do not touch old entries)
#   $group : new group to chown, if the item is newly created (do not touch old entries)

sub skel_copy {
    my $self = shift;
    my ($skel, $dest, $chown_dirs, $user, $group) = @_;

    # Copy the initial skeleton, if it exists (a class may provide a non existing skeleton, which is a shortcut for an empty skeleton)
# 20080917/NH    if (-d $skel) {
    if ($skel && (-d $skel)) {
        # Check each piece of the skeleton for presence in the destination.
        # If already present, don't copy. If not present, copy and change group ownership if necessary.
        $File::Copy::Recursive::KeepMode = undef;

        foreach (glob("$skel/*")) {
            my $item = basename($_);
            unless (-e "$dest/$item") {
                $self->info("Copying skeleton item '$skel/$item' into directory '$dest'");
                File::Copy::Recursive::rcopy("$skel/$item", "$dest/$item");

                # If the newly created item is part of the @dev_dirs arrayref, then developers are allowed access : change ownership of the whole new tree
                if (defined($chown_dirs)) {
                    # $item = 'apache' whereas @chown_dirs = 'apache/htdocs', etc. so we have to match the beginning of the dirs (yes, the regexp should match up to / or $)
                    my @items = grep(/^$item/, @{$chown_dirs});
                    # Add the base directory to each name...
                    @items = map("$dest/$_", @items);
                    # Test each directory, getting rid of missing ones (configuration error, empty trees, etc.)...
                    @items = grep {-d $_} @items;
                    if ($#items >= 0) {
                        $self->info("Changing ownership of " . join(', ', @items) . " to $user:$group");
                        system('/bin/chown', '--recursive', "$user:$group", @items);
                    }
                }                
            }
        }
        # Each file or directory present in the $skel directory will be copied to $dest if it doesn't already exist
        # Silently fail if items are already present...
    }
}


#=============================================================================
# Check the effective userid of the running process, return true if it matches
# the required username (ex. "root").
# For discussion about real/effective ids: http://www.lst.de/~okir/blackhats/node23.html
# "...compare the real user ID to the name badges people wear, and the
# effective user ID to the set of keys they've been given."
# Real ID is the one you logued in. Effective ID are used to check file accessibility.
# Sudo or setuid executables modify the effective UID.

sub check_uid {
    my $self = shift;
    my ($user) = @_;

    return ($> == getpwnam($user)); # $EFFECTIVE_USER_ID
}


#=============================================================================
# Read the contents of the file(s) and return an array of strings containing them
# Each element in the array is a single line that has been run through chomp().
# When passed back to write_file functions, the newline character is added back
# on before being written to disk.
# This behaviour is similar to ConfHelper(3) found in the libconfhelper-perl
# Debian package.

sub read_files {
    my $self = shift;

    my @content;
    
    # Simply read the files content. No file = no problem, the array will be empty...
    foreach my $file (@_) {
        open(FILE, "<$file") or next; # On the development host, NFS rootsquash prevents reading the config files, so just ignore it and jump to the next one without reading... (warning is "readline() on closed filehandle FILE")
        while (<FILE>) {
            # Each line gets it's trailing \n removed, and enters the returned array
            chomp;
            push @content, $_;
        }
        close(FILE);
    }

    return @content;
}


#=============================================================================
# Write the contents of the scalar(s) into the named file
#   write_file($diff_only, 'filename.txt', "first line", "second\nthird line");
# A newline character is added back to each array element before being written
# to disk. If the final line (array element), already have it's trailing \n
# none is added to the final line.
# This behaviour is similar to ConfHelper(3) found in the libconfhelper-perl
# Debian package.
# The first argument diff_only, if true, just outputs a diff between the current
# file contents, and the contents about to be written.
# The function returns true if the files were different, or false if they were
# identical. This is independent of the diff_only behaviour (ie. always return
# true if different, whether we wanted a simple diff, or to fully replace the
# original file).

sub write_file {
    my $self = shift;
    my $diff_only = shift;
    my $file = shift;
    my $are_different = 1; # unless proven otherwise...

    my $new_contents = join("\n", @_);
    $new_contents .= "\n" unless ($_[$#_] =~ /\n$/);

    # FIXME : "cannot write file /srv/doloforge/shared/uptime/fazendasantahelena/_conf/apache_httpd.conf: Aucun fichier ou répertoire de ce type at /usr/lib/doloforge/perl/Doloforge/Base.pm line 435." / "... 419."

    if ($diff_only) {
        # Only showing the diff result, and reporting the diff status (the configured diff command must behave like diff(1))
        open(FILE, ">$file.dolo-new") or die "cannot write file $file.dolo-new: $!";
        print FILE $new_contents;
        close(FILE);
        if (-f $file) {
            $are_different = (system(split(' ', $self->{global}->{commands}->{diff}), $file, "$file.dolo-new") != 0);
        }
        unlink("$file.dolo-new");
    } else {
        # Read the existing file, and just compare it's contents with the new one...
        if (-f $file) {
            open(FILE, "<$file") or die "cannot read file $file: $!";
            my $old_contents = join('', <FILE>);
            close(FILE);
            $are_different = ($new_contents ne $old_contents);
        }
        # ...before overwriting the file contents...
        open(FILE, ">$file") or die "cannot write file $file: $!";
        print FILE $new_contents;
        close(FILE);
    }

    return $are_different;
}


#=============================================================================
# Check whether the host we're running on has the role we ask for.
# All is done using the global configuration hash.

sub has_role {
    my $self = shift;
    my ($role) = @_;

    # Returns the number of matches in the roles array : either 0 or 1, nothing else...
    my $allowed = grep(/^$role$/, @{$self->{global}->{cluster}->{$self->{global}->{host}}->{roles}});

    # Additionnal check (ie. only checked if the host may have the role)
    # Checks are Perl code snippets defined in the configuration files under the role:[role] key
    # The code is eval'd : typical code snippet is simply '-d "$self->{global}->{dir}->{shared}"'
    # If the code snippet is not defined, it is assumed to be "true". Revoking a role is thus
    # denoted as a value of "0" in the configuration ("appserv_role: 0")
    if ($allowed and (ref($self->{global}->{role}) eq 'HASH') and defined($self->{global}->{role}->{$role})) {
        $allowed = eval $self->{global}->{role}->{$role};
    }
    
    # The result is the static configuration lazy-logical-AND the dynamic additionnal check
    return $allowed;
}


#=============================================================================
# Run a subcommand as a client UID/GID, setting the proper project environment.
# This is used to run cron jobs, bulkmail data-retrieval commands, etc.
# Arguments:
#   - $client, $project : client and project hashes containing every configuration entries for them
#   - $script_glob : glob representing all the commands to run consecutively (ex. "cron/daily/*")
#   - $argv : arrayref to the list of arguments to pass to each command (ex. [$date, $interval])
#   - $environ : hashref of an additionnal set of environment variables (added to the project_env.yaml variables)
# What it does:
#   - fork a subprocess, and wait for it to finish
#   - in the subprocess, change UID/GID to the client's ones
#   - set the environment from the project_env.* filled-in template + other specials
#   - run all the executables matching the passed glob
#   - send output (STDERR, STDOUT) to either a file, or email to the project's admin

sub run_job {
    my $self = shift;
    my ($client, $project, $script_glob, $argv, $environ) = @_;

    # Get a configuration hash for every service used by that project (and keep them in cache...)
    # 20080928/NH : it seems this is useless, and clashes with Doloforge::Command::Report (closure or something like that...)
#    foreach my $service (keys(%{$project->{services}})) {
#        $self->{service_instance}->{$service} ||= &Doloforge::Service::Factory($service, $self->{global});
#    }

    $self->debug("Will run jobs '$script_glob' for client $client->{name}, project $project->{name}.");

    # Read the environment from the prepared YAML configuration file, specific to the project
    my $working_dir = "$self->{global}->{dir}->{shared}/$project->{client}/$project->{name}";
    my $project_env = Config::YAML->new(config => "$working_dir/_conf/project_env.yaml");

    # Jobs output will be sent via email to...
    my $email = $self->{global}->{email};
    $email = $client->{webmaster}->{email} if (exists($client->{webmaster}->{email}));
    $email = $project->{webmaster}->{email} if (exists($project->{webmaster}->{email}));

    # Fork a child that will run jobs for the specified client/project/interval directory
    #   - change uid/gid, chdir, close stdin
    #   - populate ENV (serialize scalars in the $project+general YAML config)
    #   - list the candidate scripts to run
    #   - check for execution bit on each script
    #   - upon script execution, redirect stdout-err, mail output
    defined(my $pid = fork) or die("Can't fork: $!");
    if ($pid) {
        # In the parent process, we just have to wait for completion...
        waitpid($pid, 0);
    } else {
        # We're in the child : do everything needed...
        my $msg_details = "$client->{name}/$project->{name}\@$self->{global}->{stage}.$self->{global}->{host}";
        $self->debug("Subprocess started for $msg_details");

        # Each key of the environment configuration file becomes an environment variable, except for keys starting with an underscore
        foreach (keys(%{$project_env})) {
            next if (m/^_/);
            # We don't mind if the developer changed the environment (ie. "added a new PATH") in the configuration,
            # since his script will eventually get full control, and we're already running with the client's IDs
            # ($project_env->{$_} || '') because Config::YAML does not initialise empty values, leading to "Use of uninitialized value in scalar assignment" warnings...
            $ENV{$_} = ($project_env->{$_} || '');
        }
        # Ditto for the environment variables passed to the function call
        if (ref($environ) eq 'HASH') {
            foreach (keys(%{$environ})) {
                $ENV{$_} = $environ->{$_};
            }
        }

        # We override some setting from the environment configuration file...
        $ENV{HOSTNAME} = $self->{global}->{host};

        # First change GID, since changing it after having changed UID is not allowed...
        my ($logname, $uid, $gid, $home) = (getpwnam($client->{name}))[0,2,3,7];
        # Use the internal $) or $EGID variable, that will change both the GID and supplemental groups that POSIX::setgid() won't reset...
        $) = "$gid $gid";
        if ($) eq "$gid $gid") {
            # If we can't set the group, we will continue without changing ID (we're a regular user).
            # This is useful for the bulkmail service, whereas the cron service does not want to run without being root.

            # Now modify both effective and real IDs, in order to prevent coming back from there...
            setgid($gid) or die("Can't setgid to $gid ($logname): $!");
            setuid($uid) or die("Can't setuid to $uid ($logname): $!");

            # The following environment entries depends on the UID, set just above
            $ENV{HOME} = $home;
            $ENV{LOGNAME} = $logname;
        }

        # Change working directory, for easy project file retrieval inside the job script (ie. "./apache/htdocs/index.html")
        chdir($working_dir) or die("Can't chdir to '$working_dir': $!");
        $ENV{PWD} = $working_dir;

        # Close STDIN (we won't need it anymore), and save current STDOUT/ERR for future use (we will overwrite them later when sending output via mail)
        open(STDIN, '< /dev/null') or die("Can't close STDIN: $!");;
        open(SAVEOUT, '>&STDOUT') or die("Can't dup STDOUT: $!");
        open(SAVEERR, '>&STDERR') or die("Can't dup STDERR: $!");

        # List each executable script file (file or link to a file, excluding subdirs etc.)
        # from the script directory (scripts that are executable by the effective uid of the current child process)
        # FIXME : if one of the jobs (ie. publish job) changes the -x permission of another script, it will trigger an error
        #   Can't exec "cron/daily/univadis_expire_edocs.pl": Permission non accordée at /usr/lib/doloforge/perl/Doloforge/Base.pm line 605. (now 607)
        #   Sep  1 06:53:17 dolojim doloforge[20084]: cron warning: Failed to execute jim/jim3@mirror.localhost cron/daily/univadis_expire_edocs.pl: Permission non accordée
        #foreach my $job (grep {-x and -f} glob($script_glob)) {
        foreach my $job (glob($script_glob)) {
            # FIXME : probably do (also check for symlinks to executable files)
            next unless (-x $job and -f $job);

            # Locally tweak the email recipient, if declared per-job in the service configuration:
            my $job_email = ((exists($project->{services}->{$self->{name}}) and exists($project->{services}->{$self->{name}}->{email}) and exists($project->{services}->{$self->{name}}->{email}->{$job}))
                ? $project->{services}->{$self->{name}}->{email}->{$job}
                : $email
            );
            $self->info("Running $working_dir/ $job ".join(' ', @{$argv})." output to $job_email");
            my $elapsed = time;

            # Fork a mail command for the job output : -e ("if the body is empty skip the mail") -s "subject" to-addr ...
            open(STDOUT, '|-', 'mail', '-e', '-s', "Doloforge $self->{name} <$msg_details> $job", $job_email) or die("Can't pipe to mail: $!");
            open(STDERR, '>&STDOUT') or die("Can't dup STDERR to STDOUT: $!");

            # ...then actually run the job...
            my $rc = system($job, @{$argv});
            my $error = $!; # Get the error very early, because it can be changed by the following file operations

            # Get back to the previous STDOUT/ERR, since we must report to the administrator just below...
            open(STDOUT, '>&SAVEOUT') or die("Can't undup STDOUT: $!");
            open(STDERR, '>&SAVEERR') or die("Can't undup STDERR: $!");

            # Test for return code et al, and report to the doloforge administrator
            if ($rc == -1) {
                $self->warn("Failed to execute $msg_details $job: $error");
            } elsif ($rc & 127) {
                $self->warn("Child $msg_details $job died with signal=".($rc & 127)." elapsed=".(time - $elapsed)." (".(($rc & 128) ? 'with' : 'without')." coredump)");
            } elsif ($rc >= 256) {
                $self->warn("Child $msg_details $job exited with rc=".($rc >> 8)." elapsed=".(time - $elapsed));
            } else {
                $self->info("Finished $msg_details $job ".join(' ', @{$argv})." rc=$rc elapsed=".(time - $elapsed));
            }
        }

        close(SAVEOUT);
        close(SAVEERR);

        # At the end of it's job, the child dies...
        $self->debug("Subprocess finished for $msg_details");
        exit;
    }
}


#=============================================================================
# Run a Perl subroutine as another UID/GID, much like run_job, but tuned to switch
# from "root" to "doloforge" user (used by cron maintenance jobs), and run Perl
# code from the subprocess.
# Arguments:
#   - warning message details to print out if needed (name of the subroutine, or anything useful will do)
#   - numeric uid/gid to change to before running the Perl subroutine
#   - an anonymous subroutine to be called (proper/optimal syntax is not clear here, but it works...)
# What it does:
#   - fork a subprocess, and wait for it to finish
#   - in the subprocess, change UID/GID to the desired ones
#   - run the Perl code provided as arguments

sub run_sub {
    my $self = shift;
    my ($msg_details, $uid, $gid, $code) = @_;

    # Make sure we are provided non-0 IDs, as 0 or missing IDs (because user name doesn't exist in call to getpwnam) would not make sense...
    unless (($#_ == 3) and ($uid > 0) and ($gid > 0)) {
        $self->warn("Subprocess gracefully aborting for $msg_details, because of bad uid=".(defined($uid) ? "'$uid'" : '(undef)')." or gid=".(defined($gid) ? "'$gid'" : '(undef)'));
        return;
    }

    # Fork a child that will run the subroutine
    defined(my $pid = fork) or die("Can't fork: $!");
    if ($pid) {
        # In the parent process, we just have to wait for completion...
        waitpid($pid, 0);
    } else {
        # We're in the child : do everything needed...
        $self->debug("Subprocess started for $msg_details, changing ID to $uid:$gid");

        # First change GID, since changing it after having changed UID is not allowed...
        # Use the internal $) or $EGID variable, that will change both the GID and supplemental groups that POSIX::setgid() won't reset...
        $) = "$gid $gid";
        $self->error("Can't change GID to $gid ($))")
            unless ($) eq "$gid $gid");
        # Now modify both effective and real IDs, in order to prevent coming back from there...
        setgid($gid) or die("Can't setgid to $gid: $!");
        setuid($uid) or die("Can't setuid to $uid: $!");

        # Call the subroutine passed as argument to this function
        &$code;

        # At the end of it's job, the child dies...
        $self->debug("Subprocess finished for $msg_details");
        exit;
    }
}


#=============================================================================
# Display or log memory usage, for debugging purposes
#
#   sub method_to_monitor {
#       $self->memory_usage("method_to_monitor");
#       ...
#       $self->memory_usage("method_to_monitor END");
#   }

sub memory_usage {
    my $self = shift;
    $self->warn(@_, "MEMORY USAGE >>>", map {"\t$_"} $self->read_files("/proc/$$/status"), "<<< END");
}



1;
__END__

=head1 AUTHOR

Nicolas Huillard <F<nicolas@huillard.net>>, Dolomède

=head1 SEE ALSO

doloforge(1)

=cut
