view release on metacpan or  search on metacpan

lib/Command/Run.pm  view on Meta::CPAN

##
sub _restore_encoding {
    my($fh, $raw, $was_utf8) = @_;
    if ($raw) {
        binmode $fh, ':bytes' unless $was_utf8;
    } else {
        _pop_encoding($fh);
    }
}

sub _execute_in_place {
    my $obj = shift;
    my $command = shift;
    my %opt = @_;
    my @command = @$command;
    my $stderr_mode = $opt{stderr} // '';
    my $raw = $opt{raw};

    my $code = shift @command;

    my $tmp_stdout = $obj->_tmpfile('NOFORK_STDOUT', raw => $raw);

    # Save and redirect STDOUT (always needed)
    open my $save_stdout, '>&', \*STDOUT or die "dup STDOUT: $!\n";
    my $stdout_was_utf8 = _utf8_flagged(\*STDOUT);
    open STDOUT, '>&', $tmp_stdout or die "redirect STDOUT: $!\n";
    binmode STDOUT, $raw ? ':utf8' : ':encoding(utf8)';

    # Handle STDERR — only save/redirect when needed
    my ($save_stderr, $tmp_stderr);
    if ($stderr_mode eq 'redirect') {
        open $save_stderr, '>&', \*STDERR or die "dup STDERR: $!\n";
        open STDERR, '>&', \*STDOUT or die "redirect STDERR: $!\n";
    } elsif ($stderr_mode eq 'capture') {
        $tmp_stderr = $obj->_tmpfile('NOFORK_STDERR', raw => $raw);
        open $save_stderr, '>&', \*STDERR or die "dup STDERR: $!\n";
        open STDERR, '>&', $tmp_stderr or die "redirect STDERR: $!\n";
    }

    # Handle STDIN — only save/redirect when needed
    my $save_stdin;
    my $stdin_was_utf8;
    if (exists $opt{stdin}) {
        my $tmp_stdin = $obj->_tmpfile('NOFORK_STDIN', raw => $raw);
        $tmp_stdin->print($opt{stdin});
        $tmp_stdin->seek(0, 0) or die "seek: $!\n";
        open $save_stdin, '<&', \*STDIN or die "dup STDIN: $!\n";
        $stdin_was_utf8 = _utf8_flagged(\*STDIN);
        open STDIN, '<&', $tmp_stdin or die "redirect STDIN: $!\n";
        binmode STDIN, $raw ? ':utf8' : ':encoding(utf8)';
    } elsif (my $input = $obj->{INPUT}) {
        $input->seek(0, 0) or die "seek: $!\n";
        open $save_stdin, '<&', \*STDIN or die "dup STDIN: $!\n";
        $stdin_was_utf8 = _utf8_flagged(\*STDIN);
        open STDIN, '<&', $input->fileno or die "redirect STDIN: $!\n";
        binmode STDIN, $raw ? ':utf8' : ':encoding(utf8)';
    }

    # Set global state
    local $_;
    local @ARGV = @command;
    my $orig_0;
    if (my $name = code_name($code)) {
        $orig_0 = $0;
        $0 = $name;
    }

    # Execute
    my $result = 0;
    eval { $code->(@command) };
    if ($@) {
        $result = -1;
    }

    # Flush and restore — only what was redirected.  Undo the layer
    # change made above; restoring by re-open keeps the layer stack,
    # so it would persist (and :encoding would accumulate on every
    # execution) otherwise.
    STDOUT->flush;
    _restore_encoding(\*STDOUT, $raw, $stdout_was_utf8);
    open STDOUT, '>&', $save_stdout or die "restore STDOUT: $!\n";
    if ($save_stderr) {
        STDERR->flush;
        open STDERR, '>&', $save_stderr or die "restore STDERR: $!\n";
    }
    if ($save_stdin) {
        _restore_encoding(\*STDIN, $raw, $stdin_was_utf8);
        open STDIN, '<&', $save_stdin or die "restore STDIN: $!\n";
    }
    if (defined $orig_0) {
        $0 = $orig_0;
    }

    # Read captured output from tmpfiles
    $tmp_stdout->seek(0, 0) or die "seek: $!\n";
    my $stdout_data = do { local $/; <$tmp_stdout> };

    my $stderr_data = '';
    if ($tmp_stderr) {
        $tmp_stderr->seek(0, 0) or die "seek: $!\n";
        $stderr_data = do { local $/; <$tmp_stderr> };
    }

    return {
        result => $result,
        data   => $stdout_data,
        error  => $stderr_data,
    };
}

sub data {
    my $obj = shift;
    if (@_) {
        my $data = shift;
        $obj->{RESULT}->{data} = $data;
        my $fh = $obj->fh;
        $fh->seek(0, 0)  or die "seek: $!\n";
        $fh->truncate(0) or die "truncate: $!\n";
        $fh->print($data);
        $fh->flush;
        $fh->seek(0, 0)  or die "seek: $!\n";

lib/Command/Run.pm  view on Meta::CPAN

This is fixed: the layer change is now undone before the handles are
restored, so the layer stack of the standard filehandles stays
exactly as the caller left it.  With the fix, nofork is much faster
than fork in either mode, and most of the historical gap between
C<:encoding> and raw mode (which was caused by the accumulation) is
gone:

    # Benchmark: code ref with stdin (100-byte input,
    # 1000 iterations, object reused)
    fork:                    495/s (baseline)
    nofork + :encoding:   15,997/s (32x)
    nofork + :utf8 (raw): 20,038/s (40x)

=head2 Zero-Modification Callee Integration

A key advantage of this mechanism is that B<callee modules typically
require no modification> to work with nofork+raw mode.

Many Perl modules use C<use open> pragma or equivalent to set up
encoding layers on standard I/O:

    package App::ansicolumn;
    use open IO => ':utf8', ':std';    # sets :encoding(utf8) on STDIO

This works transparently because of execution order.  When using
nofork mode with method chaining:

    require App::ansicolumn;           # (1) module loaded here
    Command::Run->new
        ->command(\&ansicolumn, @args)
        ->with(stdin => $text, nofork => 1, raw => 1)
        ->update                       # (2) STDOUT redirected here
        ->data;

At step (1), C<require> loads the module and C<use open ':std'>
applies C<:encoding(utf8)> to the B<original> STDOUT.  At step (2),
nofork mode redirects STDOUT to a fresh temporary file with
C<:utf8> layer.  The callee's encoding setup has already fired on the
original STDOUT and does not affect the redirected one.

This means existing modules like L<App::ansicolumn> and
L<App::ansifold> work unchanged with nofork+raw mode, achieving
significant speedups with zero code changes on the callee side.

=head2 Caller Protection

Nofork mode executes the code reference in the same process, so care
is needed to prevent the callee from corrupting the caller's state.
The following protections are applied:

=over 4

=item C<local $_;>

Prevents the callee from modifying the caller's C<$_>.  This is
critical when the caller aliases C<$_> to important data (e.g.,
greple's C<local *_ = shift> to alias C<$_> to the content buffer).
Without this protection, a callee's C<< while (E<lt>E<gt>) >> loop
would set C<$_> to C<undef> at EOF, destroying the caller's data.

=item C<local @ARGV>

Prevents the callee from modifying the caller's C<@ARGV>.

=item C<$0> save/restore

Prevents the callee from permanently changing the program name.

=back

=head1 COMPARISON WITH SIMILAR MODULES

There are many modules on CPAN for executing external commands.
This module is designed to be simple and lightweight, with minimal
dependencies.

This module was originally developed as L<App::cdif::Command> and
has been used in production as part of the L<App::cdif> distribution
since 2014.  It has also been adopted by several unrelated modules,
which motivated its release as an independent distribution.

=over 4

=item L<IPC::Run>

Full-featured module for running processes with support for
pipelines, pseudo-ttys, and timeouts.  Very powerful but large
(135KB+) with non-core dependencies (L<IO::Pty>).  Overkill for
simple command execution.

=item L<Capture::Tiny>

Excellent for capturing STDOUT/STDERR from Perl code or external
commands.  Does not provide stdin input functionality.

=item L<IPC::Run3>

Simpler than L<IPC::Run>, handles stdin/stdout/stderr.  Good
alternative but does not support code reference execution.

=item L<Command::Runner>

Modern interface with timeout support and code reference execution.
Has non-core dependencies.

=item L<Proc::Simple>

Simple process management with background execution support.
Focused on process control rather than I/O capture.

=back

B<Command::Run> differs from these modules in several ways:

=over 4

=item * B<Core modules only> - No non-core dependencies

=item * B<Code reference support> - Execute Perl code with $0 and @ARGV setup

=item * B<File descriptor path> - Output accessible via C</dev/fd/N>