view release on metacpan or  search on metacpan

lib/BATsh/SH.pm  view on Meta::CPAN

        pwd => 1, exit => 1, 'true' => 1, 'false' => 1, read => 1,
        test => 1, source => 1, 'return' => 1, 'break' => 1,
        'continue' => 1, shift => 1, local => 1, set => 1,
        let => 1, type => 1, command => 1,
        umask => 1, hash => 1, readonly => 1, mapfile => 1, readarray => 1,
    );
    return 1 if $builtin{$lc};

    # Control keywords (defensive; these are normally handled in _run_lines)
    my %kw = (
        'if' => 1, then => 1, 'else' => 1, elif => 1, fi => 1,
        'for' => 1, 'while' => 1, until => 1, 'do' => 1, done => 1,
        case => 1, esac => 1, function => 1, in => 1,
    );
    return 1 if $kw{$lc};

    # Defined SH function (case-sensitive, as in _exec_line dispatch)
    return 1 if exists $_SH_FUNCTIONS{$w};

    return 0;
}

# _bg_tempfile: create a unique, empty temp file (O_CREAT|O_EXCL to avoid
# symlink races) for capturing a background job's PID on Unix-like systems.
# Returns the path, or undef on failure.
sub _bg_tempfile {
    my $dir = $ENV{'TMPDIR'} || $ENV{'TEMP'} || $ENV{'TMP'} || '';
    $dir = '/tmp' if $dir eq '' && -d '/tmp';
    $dir = '.'    if $dir eq '';
    $dir =~ s{[\\/]+\z}{};
    $dir = '.' if !(-d $dir && -w $dir);

    my $attempt = 0;
    while ($attempt < 1000) {
        $_BG_SEQ++;
        $attempt++;
        my $path = $dir . '/' . 'batsh_bg_' . $$ . '_' . $_BG_SEQ;
        if (sysopen(_BG_TMP, $path, O_WRONLY | O_CREAT | O_EXCL, 0600)) {
            close(_BG_TMP);
            push @_BG_TMPFILES, $path;
            return $path;
        }
        # EEXIST or transient error: retry with next sequence number
    }
    warn "sh: cannot create background pidfile in $dir: $!\n";
    return undef;
}

# _bg_launch: start $cmdline asynchronously.
#   Win32      : system(1, STRING) spawns via the command shell (P_NOWAIT)
#                and returns the PID directly.
#   Unix-like  : delegate to /bin/sh so the job is backgrounded without a
#                Perl fork; the shell's $! (the job PID) is written to a
#                temp file and read back into BATsh's own $!.
# On a successful launch $? (LAST_STATUS) is 0; the exit code of the
# background job itself is not awaited (sh semantics).
# _bg_launch: un-guard the command line, then hand it to the platform-
# specific spawner below (system(1,...) on Win32, "&" on POSIX).
sub _bg_launch {
    my ($class, $cmdline) = @_;
    return _bg_launch_decoded($class, BATsh::MB::dec($cmdline));
}

sub _bg_launch_decoded {
    my ($class, $cmdline) = @_;
    $cmdline = '' unless defined $cmdline;
    return 0 if $cmdline =~ /\A\s*\z/;
    BATsh::Env->sync_to_env();

    if ($^O =~ /MSWin32/i) {
        my $pid = system(1, $cmdline);
        if (defined $pid && $pid > 0) {
            $_LAST_BG_PID = $pid;
            $LAST_STATUS  = 0;
        }
        else {
            warn "sh: failed to start background process\n";
            $LAST_STATUS = 1;
        }
        return $LAST_STATUS;
    }

    # Unix-like
    my $pidfile = _bg_tempfile();
    my $rc;
    if (defined $pidfile) {
        # Group the command so that the whole list (pipelines, &&, ...) is
        # backgrounded as a unit, then echo the job PID ($!) to the file.
        $rc = system("{ $cmdline ; } & echo \$! > '$pidfile'");
        if (open(_BG_PIDFH, "< $pidfile")) {
            local $/;
            my $buf = <_BG_PIDFH>;
            close(_BG_PIDFH);
            $buf = '' unless defined $buf;
            my $pid = '';
            ($pid) = ($buf =~ /(\d+)/);
            $_LAST_BG_PID = $pid if defined $pid && $pid ne '';
        }
        unlink $pidfile;
        @_BG_TMPFILES = grep { $_ ne $pidfile } @_BG_TMPFILES;
    }
    else {
        $rc = system("{ $cmdline ; } &");
    }
    $LAST_STATUS = (defined $rc && $rc != -1) ? 0 : 1;
    return $LAST_STATUS;
}


# ----------------------------------------------------------------
# Split "cmd rest" honouring quoted strings
# ----------------------------------------------------------------
sub _split_sh {
    my ($line) = @_;
    if ($line =~ /\A(\S+)\s*(.*)\z/s) {
        return ($1, $2);
    }
    return ($line, '');
}

# ----------------------------------------------------------------
# _sh_assign_prefix: detect POSIX assignment prefixes on a RAW (un-expanded)
# command line, e.g. `IFS= read -r LINE` or `LC_ALL=C sort file`.
#