view release on metacpan or  search on metacpan

lib/EMDIS/ECS.pm  view on Meta::CPAN

                if $cfg->ECS_DEBUG > 0;	
            $result = "Process Timeout";
        }
    }

    # Restore STDIN, STDOUT, STDERR
    open(STDIN,  "<&OLDIN");
    open(STDOUT, ">&OLDOUT" );
    open(STDERR, ">&OLDERR" );

    if(0)
    {
        # just leave these hanging until next time around ...
        # (avoid potential deadlock waiting for child process to end)
        close(READ);
        close(OLDIN);
        close(OLDOUT);
        close(OLDERR);
    }


    if(open FILETEMP, "< $$.txt")
    {
        @msgs = <FILETEMP>;
        close FILETEMP;
        unlink "$$.txt";
        print "\n======== EXTERNAL BEGIN =============\n";
        print @msgs;
        print "========= EXTERNAL END ==============\n";
    }

    # set module-level variable containing command output
    if($#msgs >= 0) { $cmd_output = join('', @msgs); }
    else            { $cmd_output = ''; }

    return $result;
}


# ----------------------------------------------------------------------
# Unix version
# Execute specified command, with time limit and optional input data.
# Returns empty string if successful or error message if error encountered.
sub timelimit_cmd_unix
{
    my $timelimit = shift;
    my $cmd = shift;
    my $input_data = shift;

    # reset module-level variable containing command output
    $cmd_output = '';

    # initialize
    my ($reader, $writer) = (IO::Handle->new, IO::Handle->new);
    my ($pid, @msgs, $status);
    my $result = '';

    # set up "local" SIG_PIPE and SIG_ALRM handlers
    # (Note:  not using "local $SIG{PIPE}" because it ignores die())
    my $broken_pipe = '';
    my $oldsigpipe = $SIG{PIPE};
    $SIG{PIPE} = sub { $broken_pipe = 1; };
    my $oldsigalrm = $SIG{ALRM};
    $SIG{ALRM} = sub {
        die "timeout - $timelimit second processing time limit exceeded\n";
    };

    # use eval {}; to enforce time limit (see Perl Cookbook, 16.21)
    eval {
        alarm($timelimit);  # set time limit
        $broken_pipe = '';
        $pid = open2($reader, $writer, $cmd);
        print $writer $input_data if defined $input_data;
        close $writer;
        @msgs = $reader->getlines();
        close $reader;
        waitpid $pid, 0;
        $status = $?;
        die "broken pipe\n" if $broken_pipe;
        alarm(0);
    };
    if($@) {
        alarm(0);
        # detect runaway child from open2() fork/exec
        die "runaway child, probably caused by bad command\n"
            if (not defined $pid) and ($@ =~ /^open2/);
        # construct error message
        chomp $@;
        $result = "$@: $cmd\n";
    }
    elsif ($status) {
        my $exit_value = $status >> 8;
        my $signal_num = $status & 127;
        my $dumped_core = $status & 128;
        # construct error message
        $result = sprintf("Status 0x%04x (exit %d%s%s)",
                          $status, $exit_value,
                          ($signal_num ? ", signal $signal_num" : ''),
                          ($dumped_core ? ', core dumped' : ''));
    }
    $writer->close if $writer->opened;
    $reader->close if $reader->opened;
    if(defined $oldsigpipe) { $SIG{PIPE} = $oldsigpipe; }
    else                    { delete $SIG{PIPE}; }
    if(defined $oldsigalrm) { $SIG{ALRM} = $oldsigalrm; }
    else                    { delete $SIG{ALRM}; }
    $result .= "\n----------\n" . join("", @msgs) if($result and $#msgs >= 0);
    # set module-level variable containing command output
    if($#msgs >= 0) { $cmd_output = join('', @msgs); }
    else            { $cmd_output = ''; }
    return $result;
}

# ----------------------------------------------------------------------
# Unlink PID file.
sub remove_pidfile
{
    unlink $pidfile if $pidfile;
}

# ----------------------------------------------------------------------
# Return string value with leading and trailing whitespace trimmed off.
sub trim {
    my $str = shift;
    return if not defined $str;
    $str =~ s/^\s+//;
    $str =~ s/\s+$//;
    return $str;
}

# ----------------------------------------------------------------------
# Return boolean indicating whether specified encr_typ is valid.
sub valid_encr_typ
{
    my $encr_typ = shift;
    for ($encr_typ) {
        /PGP2/i and return 1;
        /OpenPGP/i and return 1;
    }
    return '';
}

1;

__DATA__

# embedded POD documentation
# for more info:  man perlpod


=head1 NAME

EMDIS::ECS - Perl implementation of EMDIS Communication System (ECS)

=head1 SYNOPSIS

 use vars qw($ECS $ECS_CFG $ECS_NODE_TBL);
 use EMDIS::ECS;
 $err = EMDIS::ECS::load_config("ecs.cfg");
 die "Unable to initialize ECS: $err\n" if $err;

 ECS::log_error("This is an error.");

 $err = EMDIS::ECS::send_admin_email("Something happened.\n",
     "Here are details.\n");