File Coverage

blib/lib/IPC/System/Options.pm

Criterion	Covered	Total	%
statement	165	284	58.1
branch	93	194	47.9
condition	21	43	48.8
subroutine	19	21	90.4
pod	4	5	80.0
total	302	547	55.2

package IPC::System::Options;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-01-31'; # DATE
our $DIST = 'IPC-System-Options'; # DIST
our $VERSION = '0.340'; # VERSION

use strict 'subs', 'vars';
use warnings;

use Proc::ChildError qw(explain_child_error);

my $log;
our %Global_Opts;

sub import {
    my $self = shift;

    my $caller = caller();
    my $i = 0;
    while ($i < @_) {
        # backtick is the older, deprecated name for readpipe
        if ($_[$i] =~ /\A(system|readpipe|backtick|run|start|import)\z/) {
            no strict 'refs';
            *{"$caller\::$_[$i]"} = \&{"$self\::" . $_[$i]};
        } elsif ($_[$i] =~ /\A-(.+)/) {
            die "$_[$i] requires an argument" unless $i < @_-1;
            $Global_Opts{$1} = $_[$i+1];
            $i++;
        } else {
            die "$_[$i] is not exported by ".__PACKAGE__;
        }
        $i++;
    }
}

sub _args2cmd {
    if (@_ == 1) {
        return $_[0];
    }
    if ($^O eq 'MSWin32') {
        require Win32::ShellQuote;
        return Win32::ShellQuote::quote_system_string(
            map { ref($_) eq 'SCALAR' ? $$_ : $_ } @_);
    } else {
        require String::ShellQuote;
        return join(
            " ",
            map { ref($_) eq 'SCALAR' ? $$_ : String::ShellQuote::shell_quote($_) } @_
        );
    }
}

sub _system_or_readpipe_or_run_or_start {
    my $which = shift;
    my $opts = ref($_[0]) eq 'HASH' ? shift : {};
    for (keys %Global_Opts) {
        $opts->{$_} = $Global_Opts{$_} if !defined($opts->{$_});
    }
    my @args = @_;

    # check known options
    for (keys %$opts) {
        die "Unknown option '$_'"
            unless /\A(
                        capture_stdout|capture_stderr|capture_merged|
                        tee_stdout|tee_stderr|tee_merged|
                        chdir|dies?|dry_run|env|lang|log|max_log_output|shell|
                        exit_code_success_criteria|
                        fail_log_level|
                        stdin # XXX: only for run()
                    )\z/x;
    }

    # defaults
    $opts->{fail_log_level} ||= 'error';

    my $opt_die = $opts->{die} || $opts->{dies};

    my $child_error;
    my $os_error = "";
    my $exit_code_is_success;
    my $extra_error;

    my $code_exit_code_is_success = sub {
        my $exit_code = shift;
        if (defined $opts->{exit_code_success_criteria}) {
            if    (ref $opts->{exit_code_success_criteria} eq ''      ) { return $exit_code == $opts->{exit_code_success_criteria} }
            elsif (ref $opts->{exit_code_success_criteria} eq 'ARRAY' ) { return (grep { $exit_code==$_ } @{ $opts->{exit_code_success_criteria} }) ? 1:0 }
            elsif (ref $opts->{exit_code_success_criteria} eq 'Regexp') { return $exit_code =~ $opts->{exit_code_success_criteria} }
            elsif (ref $opts->{exit_code_success_criteria} eq 'CODE'  ) { return $opts->{exit_code_success_criteria}->($exit_code) }
            else { die "exit_code_success_criteria must be a number, array of numbers, Regexp, or coderef" }
        } else {
            return $exit_code == 0;
        }
    };

    if ($opts->{log}) {
        require Log::ger::Format::MultilevelLog; # just so scan_prereqs can detect it
        require Log::ger::Format;
        Log::ger::Format->set_for_current_package(MultilevelLog => (sub_name => 'logger'));
        require Log::ger;
        Log::ger->import;
    }

    my $cwd;
    if ($opts->{chdir}) {
        require Cwd;
        $cwd = Cwd::getcwd();
        if (!defined $cwd) { # checking $! is always true here, why?
            $log->error("Can't getcwd: $!") if $log;
            $child_error = -1;
            $exit_code_is_success = 0;
            $os_error = $!;
            $extra_error = "Can't getcwd";
            goto CHECK_RESULT;
        }
        unless (chdir $opts->{chdir}) {
            $log->error("Can't chdir to '$opts->{chdir}': $!") if $log;
            $child_error = -1;
            $exit_code_is_success = 0;
            $os_error = $!;
            $extra_error = "Can't chdir";
            goto CHECK_RESULT;
        }
    }

    # set ENV
    my %save_env;
    my %set_env;
    if ($opts->{lang}) {
        $set_env{LC_ALL}   = $opts->{lang};
        $set_env{LANGUAGE} = $opts->{lang};
        $set_env{LANG}     = $opts->{lang};
    }
    if ($opts->{env}) {
        $set_env{$_} = $opts->{env}{$_} for keys %{ $opts->{env} };
    }
    if (%set_env) {
        for (keys %set_env) {
            $save_env{$_} = $ENV{$_};
            $ENV{$_} = $set_env{$_};
        }
    }

    my $wa;
    my $res;

    my $capture_stdout_was_false;
    my $emulate_backtick;
    my $tmp_capture_stdout;

    my $code_capture = sub {
        my $doit = shift;

        if ($opts->{capture_stdout} && $opts->{capture_stderr}) {
            require Capture::Tiny;
            (${ $opts->{capture_stdout} }, ${ $opts->{capture_stderr} }) =
                &Capture::Tiny::capture($doit);
        } elsif ($opts->{capture_merged}) {
            require Capture::Tiny;
            ${ $opts->{capture_merged} } =
                &Capture::Tiny::capture_merged($doit);
        } elsif ($opts->{capture_stdout}) {
            require Capture::Tiny;
            ${ $opts->{capture_stdout} } =
                &Capture::Tiny::capture_stdout($doit);
        } elsif ($opts->{capture_stderr}) {
            require Capture::Tiny;
            ${ $opts->{capture_stderr} } =
                &Capture::Tiny::capture_stderr($doit);

        } elsif ($opts->{tee_stdout} && $opts->{tee_stderr}) {
            require Capture::Tiny;
            (${ $opts->{tee_stdout} }, ${ $opts->{tee_stderr} }) =
                &Capture::Tiny::tee($doit);
        } elsif ($opts->{tee_merged}) {
            require Capture::Tiny;
            ${ $opts->{tee_merged} } =
                &Capture::Tiny::tee_merged($doit);
        } elsif ($opts->{tee_stdout}) {
            require Capture::Tiny;
            ${ $opts->{tee_stdout} } =
                &Capture::Tiny::tee_stdout($doit);
        } elsif ($opts->{tee_stderr}) {
            require Capture::Tiny;
            ${ $opts->{tee_stderr} } =
                &Capture::Tiny::tee_stderr($doit);
        } else {
            $doit->();
        }
    };

    if ($which eq 'system') {

        if ($opts->{log} || $opts->{dry_run}) {
            if ($opts->{log}) {
                no strict 'refs';
                my $routine;
                my $label = "";
                if ($opts->{dry_run}) {
                    $label = "[DRY RUN] ";
                    $routine = "log_info";
                } else {
                    $routine = "log_trace";
                }
                $routine->("%ssystem(%s), env=%s", $label, \@args, \%set_env);
            } else {
                warn "[DRY RUN] system("._args2cmd(@args).")\n";
            }
            if ($opts->{dry_run}) {
                $child_error = 0;
                $exit_code_is_success = 1;
                $res = "";
                goto CHECK_RESULT;
            }
        }

        my $doit = sub {
            if ($opts->{shell}) {
                # force the use of shell
                $res = system _args2cmd(@args);
            } elsif (defined $opts->{shell}) {
                # forbid shell
                $res = system {$args[0]} @args;
            } else {
                # might or might not use shell (if @args == 1)
                $res = system @args;
            }
            $child_error = $?;
            $exit_code_is_success = $code_exit_code_is_success->($? < 0 ? $? : $? >> 8);
            $os_error = $!;
        };
        $code_capture->($doit);

    } elsif ($which eq 'readpipe') {

        $wa = wantarray;

        if ($opts->{log} || $opts->{dry_run}) {
            if ($opts->{log}) {
                no strict 'refs';
                my $routine;
                my $label = "";
                if ($opts->{dry_run}) {
                    $label = "[DRY RUN] ";
                    $routine = "log_info";
                } else {
                    $routine = "log_trace";
                }
                $routine->("%sreadpipe(%s), env=%s", $label, _args2cmd(@args), \%set_env);
            } else {
                warn "[DRY RUN] readpipe("._args2cmd(@args).")\n";
            }
            if ($opts->{dry_run}) {
                $child_error = 0;
                $exit_code_is_success = 1;
               $res = "";
                goto CHECK_RESULT;
            }
        }

        # we want to avoid the shell, so we don't use the builtin backtick.
        # instead, we emulate backtick by system + capturing the output
        if (defined $opts->{shell} && !$opts->{shell}) {
            $emulate_backtick++;
            die "Currently cannot backtick() with options shell=0 and capture_merged|tee_*"
                if $opts->{capture_merged} || $opts->{tee_stdout} || $opts->{tee_stderr} || $opts->{tee_merged};
            if (!$opts->{capture_stdout}) {
                $capture_stdout_was_false++;
                $opts->{capture_stdout} = \$tmp_capture_stdout;
            }
        }

        my $doit = sub {
            if ($emulate_backtick) {
                # we don't want shell so we have to emulate backtick with system
                # + capture the output ourselves
                system {$args[0]} @args;
            } else {
                my $cmd = _args2cmd(@args);
                #warn "cmd for backtick: " . $cmd;
                # use backtick, which uses the shell
                if ($wa) {
                    $res = [`$cmd`];
                } else {
                    $res = `$cmd`;
                }
            }
            $child_error = $? < 0 ? $? : $? >> 8;
            $exit_code_is_success = $code_exit_code_is_success->($? < 0 ? $? : $? >> 8);
            $os_error = $!;
        };
        $code_capture->($doit);

        if ($emulate_backtick) {
            $res = $capture_stdout_was_false ? $tmp_capture_stdout :
                ${ $opts->{capture_stdout} };
            $res = [split /^/m, $res] if $wa;
            $opts->{capture_stdout} = undef if $capture_stdout_was_false;
        }

        # log output
        if ($opts->{log}) {
            my $res_show;
            if (defined $opts->{max_log_output}) {
                $res_show = '';
                if ($wa) {
                    for (@$res) {
                        if (length($res_show) + length($_) >=
                                $opts->{max_log_output}) {
                            $res_show .= substr(
                                $_,0,$opts->{max_log_output}-length($res_show));
                            last;
                        } else {
                            $res_show .= $_;
                        }
                    }
                } else {
                    if (length($res) > $opts->{max_log_output}) {
                        $res_show = substr($res, 0, $opts->{max_log_output});
                    }
                }
            }
            log_trace("result of readpipe(): %s (%d bytes)",
                      defined($res_show) ? $res_show : $res,
                      defined($res_show) ?
                          $opts->{max_log_output} : length($res))
                if $exit_code_is_success;
        }

    } elsif ($which eq 'run' || $which eq 'start') {

        if ($opts->{log} || $opts->{dry_run}) {
            if ($opts->{log}) {
                no strict 'refs';
                my $routine;
                my $label = "";
                if ($opts->{dry_run}) {
                    $label = "[DRY RUN] ";
                    $routine = "log_info";
                } else {
                    $routine = "log_trace";
                }
                $routine->("%srun(%s), env=%s", $label,
                           join(", ", @args), \%set_env);
            } else {
                warn "[DRY RUN] $which(".join(", ", @args).")\n";
            }
            if ($opts->{dry_run}) {
                $child_error = 0;
                $exit_code_is_success = 1;
                $res = "";
                goto CHECK_RESULT;
            }
        }

        require IPC::Run;
        my $func = $which eq 'run' ? "IPC::Run::run" : "IPC::Run::start";
        $res = &{$func}(
            \@args,
            defined($opts->{stdin}) ? \$opts->{stdin} : \*STDIN,
            sub {
                if ($opts->{capture_stdout}) {
                    if (ref $opts->{capture_stdout} eq 'CODE') {
                        $opts->{capture_stdout}->($_[0]);
                    } else {
                        ${$opts->{capture_stdout}} .= $_[0];
                    }
                } else {
                    print $_[0];
                }
            }, # out
            sub {
                if ($opts->{capture_stderr}) {
                    if (ref $opts->{capture_sderr} eq 'CODE') {
                        $opts->{capture_sderr}->($_[0]);
                    } else {
                        ${$opts->{capture_stderr}} .= $_[0];
                    }
                } else {
                    print STDERR $_[0];
                }
            }, # err
        );
        if ($which eq 'run') {
            $child_error = $?;
            $exit_code_is_success = $code_exit_code_is_success->($? < 0 ? $? : $? >> 8);
            $os_error = $!;
        } else {
            $child_error = 0;
            $exit_code_is_success = 1;
            $os_error = "";
        }

    } # which

    # restore ENV
    if (%save_env) {
        for (keys %save_env) {
            if (defined $save_env{$_}) {
                $ENV{$_} = $save_env{$_};
            } else {
                undef $ENV{$_};
            }
        }
    }

    # restore previous working directory
    if ($cwd) {
        unless (chdir $cwd) {
            $log->error("Can't chdir back to '$cwd': $!") if $log;
            $child_error ||= -1;
            $os_error = $!;
            $extra_error = "Can't chdir back";
            goto CHECK_RESULT;
        }
    }

  CHECK_RESULT:
    unless ($exit_code_is_success) {
        if ($opts->{log} || $opt_die) {
            my $msg = sprintf(
                "%s(%s) failed: %s (%s)%s%s%s",
                $which,
                join(" ", @args),
                defined $extra_error ? "" : $child_error,
                defined $extra_error ? "$extra_error: $os_error" : explain_child_error($child_error, $os_error),
                (ref($opts->{capture_stdout}) ?
                     ", captured stdout: <<" .
                     (defined ${$opts->{capture_stdout}} ? ${$opts->{capture_stdout}} : ''). ">>" : ""),
                (ref($opts->{capture_stderr}) ?
                     ", captured stderr: <<" .
                     (defined ${$opts->{capture_stderr}} ? ${$opts->{capture_stderr}} : ''). ">>" : ""),
                (ref($opts->{capture_merged}) ?
                     ", captured merged: <<" .
                     (defined ${$opts->{capture_merged}} ? ${$opts->{capture_merged}} : ''). ">>" : ""),
            );
            logger($opts->{fail_log_level}, $msg) if $opts->{log};
            die $msg if $opt_die;
        }
    }

    if ($which ne 'start') {
        $? = $child_error;
    }

    return $wa && $which ne 'run' && $which ne 'start' ? @$res : $res;
}

sub system {
    _system_or_readpipe_or_run_or_start('system', @_);
}

# backtick is the older, deprecated name for readpipe
sub backtick {
    _system_or_readpipe_or_run_or_start('readpipe', @_);
}

sub readpipe {
    _system_or_readpipe_or_run_or_start('readpipe', @_);
}

sub run {
    _system_or_readpipe_or_run_or_start('run', @_);
}

sub start {
    _system_or_readpipe_or_run_or_start('start', @_);
}

1;
# ABSTRACT: Perl's system(), readpipe()/qx, IPC::Run's run(), start() (with more options)

__END__