Parallel::Depend::Util - Parallel::Depend::Util documentation

	use Parallel::Depend::Util;

	# generate path relative to the #!'s $Bin directory.
	# these can be abs-pathed without regard to the
	# current working directory. The last path element
	# is looked up in $defaulz->{global}{basename} allowing
	# for simpler shared path names.

	my $path = localpath @path_components, $token;
	my $path = localpath @path_components, 'basename';

	# sanity check a set of paths.

	checkdir @dirlist;

	# send email, to can also be an array referent.
	# from defaults to current user at whatever
	# 'hostname' returns.

	send_mail
		To         => 'someone@someplace',
		From       => 'me@here',
		Subject    => 'Message subject',
		Data       => 'Message body',

		'X-Parallel::Depend' => 'Progress'
	;

	# defaults from $que->{user}->moduleconfig.

	progress_mail @message;

	nastygram @message;

########################################################################
# Parallel::Depend::Util shared utilities.
# these include logging, notification, and standard output formats.
########################################################################

########################################################################
# housekeeping
########################################################################

package Parallel::Depend::Util;

use v5.10.0;
use strict;
use subs qw( log_format );

our $VERSION=1.02;

use Carp;
use Data::Dumper;
use File::Basename;
use MIME::Lite;
use Symbol;

use File::Spec::Functions   qw( splitpath catpath splitdir catdir );

use Cwd             qw( abs_path );
use FindBin         qw( $Bin );
use Date::Format    qw( time2str );
use List::Util      qw( reduce );
use Scalar::Util    qw( blessed );

# avoid listing log_fatal, etc, as sources for errors.

push @::CARP_NOT, __PACKAGE__;

########################################################################
# package variables 
########################################################################

########################################################################
# exported subs
########################################################################

# deal with use. basic issue is to pollute the caller's
# namespace with our subs.

our @exportz
= qw
(
    log_format
    log_output
    log_message
    log_error
    log_warning
    log_fatal
    send_mail
    progress_mail
    nastygram
    localpath
    gendir
    genpath
    checkdir
);

sub import
{
    my $package = shift;
    my $caller  = caller;

    my $exportz
    = do
    {
        my $ref = qualify_to_ref 'exportz', $package;

        *{ $ref }{ ARRAY };
    }
    or die "Bogus import: $package has no exports";

    for( @_ ? @_ : @$exportz )
    {
        when( @$exportz )
        {
            my $ref = qualify_to_ref $_, $caller;

            if( *{ $ref }{ CODE } )
            {
                warn "Skip existing '$_' in $caller";
            }
            else
            {
                *$ref   = $package->can( $_ );
            }
        }

        default
        {
            croak "Bogus import: '$_' ($caller) not exported";
        }
    }
}

########################################################################
# package variables
########################################################################

our $defaultz = {};

########################################################################
# logging
########################################################################

# standardize log messages format.
# message arives in @_.

*log_format
= do
{
    my $tz      = $ENV{TZ} || '';
    my $time    = '';
    my $msgseq  = 0;

    sub
    {
        local $Data::Dumper::Purity           = 1;
        local $Data::Dumper::Terse            = 1;
        local $Data::Dumper::Indent           = 1;
        local $Data::Dumper::Deepcopy         = 0;
        local $Data::Dumper::Quotekeys        = 0;

        # handle accidentally treating this as a method.

        blessed $_[0] and shift;

        # i.e., iso8601

        my $time    = time2str '%Y.%m.%dT%TZ', time, 'GMT';

        my $header = join ' ', $$, ++$msgseq, $time;

        $header .= "\t" . shift
        unless ref $_[0];

        # prefixing lines with a newline reduces
        # the number of "floading" lines on the
        # display and reduces intermingling of 
        # messages.

        if( @_ )
        {
            join "\n", '',
            map
            {
                ref $_ ? Dumper $_ : $_
            }
            ( $header, @_, '' )
        }
        else
        {
            $header . "\n"
        }
    }
};

sub log_output
{
    my $fh  = shift;

    print $fh &log_format;

    return
}

sub log_message { print STDOUT  &log_format }
sub log_error   { print STDERR  &log_format }

sub log_warning { carp          &log_format }
sub log_fatal   { confess       &log_format }

########################################################################
# email notification
########################################################################

########################################################################
# this actually sends the mail.
# it provides sane defaults for the minimal headers.

sub send_mail
{
    my %mailargz = ref $_[0] ? %{$_[0]} : @_;

    unless( $mailargz{To} )
    {
        $mailargz{To} = (getpwuid $>)[0] . '@localhost';

        log_error "Bogus send_mail: defaulting email to '$mailargz{To}'";
    }

    $mailargz{To} = join ',', @{ $mailargz{To} }
    if ref $mailargz{To};

    # other things can reasonably be defaulted...

    $mailargz{'X-Parallel::Depend'} ||= "Generic";

    $mailargz{From} ||=
    do
    {
        my $user = (getpwuid $>)[0];
        chomp ( my $host = qx(hostname) );

        join '@', $user, $host
    };

    $mailargz{'Reply-to'} ||= $mailargz{From};

    $mailargz{Subject} ||= "Email from $mailargz{From}";

    $mailargz{Subject} =~ s/^/[Unknown-Notify]/
    unless $mailargz{Subject} =~ /^\[/;

    $mailargz{Data} ||= 'This is an automatic notification';

    # mail is flakey enough that this needs to log
    # any failurs. also saves people from complaing
    # that the mail wasn't delivered: at least we
    # know why from this end...

    eval { MIME::Lite->new( %mailargz )->send };

    log_error "Failed sending email: $@" if( $@ );

    # caller gets back the subject and name list.

    "$mailargz{Subject} -> $mailargz{To}"
}

########################################################################
# que_mail is for sending email from w/in the schedule.
# it is intended to handle automated progress notification.
# use send_mail with a more specific message in order to
# transmit error/recovery information.

sub progress_mail
{
    my $que = shift
    or croak "Bogus progress_mail: missing que object";

    my $job = shift
    or croak "Bogus notify: missing job argument";

    my $config  = $que->{user}->moduleconfig
    or die "$$: Bogus notify: que missing user data.";

    my $quename = $config->{quename} || 'Unknown';

    my $names = $config->{notify}{$job}
    or die "$$: Bogus notify: no '$job' name list configured.";

    my $fromid = $config->{mail_from}
    or die "$$: Bogus notify: no 'mail_from' entry configured.";

    my %mailargz =
    (
    # use to detect test email in mail rules.
    # setting the rules to detect specific programs
    # makes it easeir to segregate based on what is
    # being tested.

    'X-Parallel::Depend'      => "$quename-$job",

    # set from command line w/ default.

    To              => $names,
    'Reply-to'      => $fromid,
    From            => $fromid,

    Subject         => "[$quename-Progress] $job",

    Data            => 'This is an automated progress message.',
    );

    # caller gets back result of sending the mail.

    send_mail %mailargz
}

########################################################################
# log & email fatal messages.
#
# Note:  this cannot die until the end in order to guarantee
# that the log entries and email are sent. it has to be
# entirely tolerant of bogus configs and arguments.

sub nastygram
{
    # log the stuff first, this guarantees
    # that at least something will be recorded.

    log_error "Roadkill:", @_;

    # without a que object, use the global defaults
    # to find things instead.

    my $global = $defaultz->{global};

    my $config = $defaultz->{$global}
    or warn "Bogus config: missing global 'Parallel::Depend' entry";

    my $quename = $config->{quename} || 'Unknown';

    my $fatal = "$quename-Fatal";

    my $notify = $config->{notify}
    or warn "Bogus config:  global missing 'notify' entry";

    my $subject = shift || 'Bad news, boss...';

    $subject =~ s/^/[$fatal]/ unless $subject =~ /^\[/;

    my $message = &log_format;

    my $mailargz =
    {
        'X-Parallel_Depend'    => $fatal,

        To      => $notify->{fatal} || 'schedule_depend@localhost',

        From    => $config->{mail_from} || 'schedule_depend@localhost',

        Subject => $subject,

        Data    => $message,
    };

    # die with the message subject and notify list.
    # this will be the last line of the job's .err file.

    die send_mail $mailargz;
}

########################################################################
# directory operations
########################################################################

# various standard file paths based on $Bin.
# empty arg's gives $Bin with a trailing '/'.
#
# note that the directory can be anything, including
# subdir's or file basenames.
#
# make non-absolute paths relative to $Bin instead
# of the current working directory.
#
# creating the file is unlikely to succeed
# unless the directory already exists...

sub localpath
{
    my $global = $defaultz->{global} ||= {};

    # make a local copy of the last argument; replace
    # symbolic names from the defaults with real
    # basenames. making the copy avoids modifying
    # another argument in place via @_.

    @_ and my $name = $_[-1];

    # default directory is '../var/tmp'.

    unshift @_, '../var/tmp' unless grep m{/}, @_;

    my $path = join '/', ( @_ ? @_ : '' );

    $path = "$Bin/$path" unless $path =~ m{^/};

    # this is a hack and should be configured via
    # values in the default config. that or this
    # should use parsefile to default the extension
    # if none is given.

    $path .= '.dump' if ! -e $path && -e "$path.dump";

    # caller gets back the path, which may not
    # exist, yet.

    $path
}

# validate/create a directory.
# default mods are 02775.
#
# simpler but doesn't play nice with the profiler:
#
#    abs_path
#    reduce
#    {
#        $a  = catdir $a, $b;
#
#        -e $a || mkdir $a, 02755
#        or confess "Failed mkdir: $a, $!", \@_;
#
#        $a
#    }
#    splitdir catdir @_

sub gendir
{
    my $path    = catdir @_;

    if( -e $path )
    {
        $path
    }
    else
    {
        my $dir    = '';

        for( splitdir $path )
        {
            $dir    = catdir $dir, $_;

            -e $dir || mkdir $dir, 02755
            or confess "Failed mkdir: $dir, $!", \@_;
        }

        abs_path $dir
    }

}

sub genpath
{
    my ( $vol, $dir, $base ) = splitpath $_[0];

    catpath $vol, ( gendir $dir ), $base
}

sub checkdir
{
    -e or gendir $_ for @_;

    return
}

########################################################################
# keep require happy

1

__END__