File Coverage

blib/lib/Unix/ScriptUtil.pm

Criterion	Covered	Total	%
statement	52	53	98.1
branch	23	36	63.8
condition	6	11	54.5
subroutine	15	15	100.0
pod	9	9	100.0
total	105	124	84.6

# -*- Perl -*-
#
# some utility routines for scripts

package Unix::ScriptUtil;
our $VERSION = '0.02';

use 5.10.0;
use strict;
use warnings;
use Carp qw(croak);
use POSIX qw(setsid);

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK =
  qw(cd brun diropen fileopen pipe_close pipe_from pipe_to solitary timeout);

sub cd { chdir($_[0]) or croak("chdir $_[0] failed: $!") }
sub brun { system({ $_[0] } @_) == 0 or croak("system '@_' failed: $?") }

sub diropen {
    opendir(my $dh, $_[0]) or croak("opendir $_[0] failed: $!");
    return $dh;
}

# fileopen - kind of like what File::Open provides?
{
    # more or less stolen from fopen(3)
    my %fomap = (
        'r'  => '<',
        'w'  => '>',
        'r+' => '+<',
        'w+' => '+>',
        'a'  => '>>',
        'a+' => '+>>',
    );

    sub fileopen {
        my ($file, $how) = @_;
        my $way = $fomap{ $how // 'r' } // croak("unknown open method $how");
        open(my $fh, $way, $file) or croak("open $how '$file' failed: $!");
        return $fh;
    }
}

sub pipe_close {
    close($_[0]) or croak($! ? "close failed: $!" : "pipe command failed: $?");
}

# NOTE these next two may invoke sh in certain cases
sub pipe_from {
    open(my $fh, '-|', @_) or croak("exec '@_' failed: $!");
    return $fh;
}

sub pipe_to {
    open(my $fh, '|-', @_) or croak("exec '@_' failed: $!");
    return $fh;
}

# similar to disown (as seen in ZSH) but also with a chdir because where
# the process lives probably needs to be thought about (where *.core
# files may go, could be on a network mount, ...). the double-fork
# prevents the chdir/etc from altering the original process and should
# help disassociate things from any controlling terminal
sub solitary {
    my $dir = shift;
    my $pid = fork() // croak("fork failed: $!");    # child 1
    if ($pid == 0) {
        chdir($dir) or croak("chdir $dir failed: $!");
        open(*STDIN,  '<', '/dev/null') or croak("can read /dev/null: $!\n");
        open(*STDOUT, '>', '/dev/null') or croak("can write /dev/null: $!\n");
        my $pid = fork() // croak("fork failed: $!\n");    # child 2
        exit if $pid;                                      # child 1

        # NOTE beyond here original process will have no idea whether
        # the solitary process (child 2) fails any of these
        setsid() == -1 and die("setsid failed: $!\n");
        open(*STDERR, '>&', *STDOUT) or die("dup failed: $!\n");
        exec { $_[0] } @_;
        die("exec failed: $!\n");
    } else {
        wait();    # for child 1
        croak("child error: $?") if $? != 0;
    }
}

sub timeout {
    my ($duration, $fn) = @_;
    eval {
        local $SIG{ALRM} = sub { die("timeout\n") };
        alarm($duration);
        $fn->();
        alarm(0);
    };
    if ($@) {
        die unless $@ eq "timeout\n";
        croak($@);
    }
}

1;
__END__