BATsh
view release on metacpan or search on metacpan
lib/BATsh/CMD.pm view on Meta::CPAN
package BATsh::CMD;
# Copyright (c) 2026 INABA Hitoshi <ina@cpan.org>
######################################################################
#
# BATsh::CMD - Pure Perl cmd.exe interpreter
#
# v0.02 changes (cmd.exe compatibility fixes):
# 1. Environment variable case-insensitivity (via Env.pm)
# 2. ^ escape character: protects & | < > and line continuation
# 3. Redirect/pipe: > >> 2> 2>> < | parsed before dispatch
# 4. SETLOCAL ENABLEDELAYEDEXPANSION + !VAR! (via Env.pm)
# 5. IF block pre-expansion: entire IF block expanded at parse time
# (matching cmd.exe's "parse before execute" semantics)
# 6. FOR /F: tokens= delims= skip= eol= usebackq
# 7. IF /I must be parsed BEFORE plain == to avoid shadowing
# 8. ECHO no longer resets ERRORLEVEL
# 9. SETLOCAL passes option string to Env::setlocal()
# 10. IF EXIST handles quoted paths with spaces
# 11. Pipeline (|): _split_compound detects |, _exec_pipe chains via tmpfile
# 12. SET /P VAR=Prompt: reads one line from STDIN
# 13. SHIFT / SHIFT /N: shifts %1..%9 and %* positional parameters
# 14. Batch-parameter tilde modifiers via Env::expand_cmd():
# %~0 %~f1 %~d0 %~p0 %~n1 %~x1 %~dp0 %~nx1 (f d p n x combinable)
# 15. & && || compound commands (_exec_compound)
# 16. %0..%9 and %* positional parameter expansion in expand_cmd()
#
######################################################################
use strict;
BEGIN { if ($] < 5.006 && !defined(&warnings::import)) { $INC{'warnings.pm'} = 'stub'; eval 'package warnings; sub import {}' } }
use warnings; local $^W = 1;
BEGIN { pop @INC if $INC[-1] eq '.' }
use File::Spec ();
use File::Copy ();
use File::Path ();
use Carp qw(croak);
use vars qw($VERSION);
$VERSION = '0.02';
$VERSION = $VERSION;
require BATsh::Env;
# ----------------------------------------------------------------
# Module-level state
# ----------------------------------------------------------------
my $ECHO_ON = 1;
my $ERRORLEVEL = 0;
my $_GOTO_LABEL = '';
# ----------------------------------------------------------------
# Public: execute an array of CMD lines
# ----------------------------------------------------------------
sub exec_block {
my ($class, $lines_ref, %opts) = @_;
my @lines = @{$lines_ref};
# Preprocess: join ^ line-continuations
@lines = _join_continuations(@lines);
# Build label index
my %labels = ();
for my $i (0 .. $#lines) {
my $l = $lines[$i];
$l =~ s/\r?\n\z//;
$l =~ s/\A\s+//;
if ($l =~ /\A:([A-Za-z_][A-Za-z0-9_]*)\s*\z/) {
$labels{uc($1)} = $i;
}
}
my $i = 0;
while ($i <= $#lines) {
my $raw = $lines[$i];
lib/BATsh/CMD.pm view on Meta::CPAN
$probe =~ s/\x00FOR_[A-Za-z]\x00//g;
$probe =~ s/\x00PCT_[^\x00]+\x00//g;
$probe =~ s/%%[A-Za-z]//g;
if ($probe =~ /\A\s*\(\s*\z/) {
$paren_body_template = _read_paren_block('', $lines_ref, $i_ref);
}
}
# If we have a paren block, expand %VAR% ONCE at FOR-parse time
# (cmd.exe expands the whole block before any iteration runs).
# PCT placeholders (%%V protected vars) are restored to %VAR% first,
# then _block_expand runs the single-pass %VAR% substitution.
# The result is a template with loop-var placeholders still intact.
my $paren_expanded = undef;
if (defined $paren_body_template) {
my $tpl = $paren_body_template;
# Restore PCT placeholders -> %VAR% so _block_expand can see them
$tpl =~ s/\x00PCT_([^\x00]+)\x00/%$1%/g;
# But protect the loop variable itself from _block_expand
# (it will be substituted per-iteration below)
$tpl =~ s/%%$var/"\x00LOOPVAR\x00"/ge;
$tpl =~ s/\x00FOR_$var\x00/"\x00LOOPVAR\x00"/ge;
# Single-pass %VAR% expansion at FOR-line parse time
$paren_expanded = _block_expand($tpl);
# _block_expand already restored other %%X -> %%X, leave loop placeholder
}
my @values = $gen->();
for my $val (@values) {
BATsh::Env->set("%%$var", $val);
if (defined $paren_expanded) {
# Substitute loop variable placeholder with current value
my $body = $paren_expanded;
$body =~ s/\x00LOOPVAR\x00/$val/g;
# At runtime: if delayed expansion is on, expand !VAR!
# _exec_body with pre_expanded=1 handles this via _exec_line
_exec_body($class, $body, $lines_ref, $labels_ref, $i_ref, $opts_ref, 1);
}
else {
my $do_line = $do_part;
# Replace loop variable placeholder/shorthand with current value
$do_line =~ s/%%$var/$val/g;
$do_line =~ s/\x00FOR_$var\x00/$val/g;
# Restore other FOR-variable placeholders to %%X form
$do_line =~ s/\x00FOR_([A-Za-z])\x00/%%$1/g;
# Restore %VAR% placeholders so expand_cmd can expand them
$do_line =~ s/\x00PCT_([^\x00]+)\x00/%$1%/g;
$do_line = BATsh::Env->expand_cmd($do_line);
_exec_line($class, $do_line, $lines_ref, $labels_ref, $i_ref, $opts_ref, 1);
}
last if $_GOTO_LABEL ne '';
}
return 0;
}
# ----------------------------------------------------------------
# FOR /F
#
# Options string (inside quotes): tokens= delims= skip= eol= usebackq
# Source:
# "filename" -- iterate lines of file (or usebackq: command output)
# 'command' -- command output (or usebackq: literal filename)
# ("string") -- tokenize the string itself
# ----------------------------------------------------------------
sub _cmd_for_f {
my ($class, $opts_str, $var, $source_str, $do_part, $lines_ref, $labels_ref, $i_ref, $opts_ref) = @_;
# Strip outer quotes from opts_str
$opts_str =~ s/\A"//; $opts_str =~ s/"\z//;
# Parse options
my $tokens_spec = '1'; # default: first token only
my $delims = " \t"; # default delimiters
my $skip = 0;
my $eol = ';'; # default: skip lines starting with ;
my $usebackq = 0;
$usebackq = 1 if $opts_str =~ /usebackq/i;
if ($opts_str =~ /tokens=(\S+)/i) {
$tokens_spec = $1;
$tokens_spec =~ s/,\z//;
}
if ($opts_str =~ /delims=([^\s"]*)/i) {
$delims = $1;
$delims = ' ' if $delims eq ''; # delims= (empty) means no split? No: empty = space only
}
elsif ($opts_str =~ /delims=\s*\z/i) {
$delims = ''; # delims= with nothing = no delimiter (whole line = one token)
}
if ($opts_str =~ /skip=(\d+)/i) { $skip = int($1) }
if ($opts_str =~ /eol=(.)/i) { $eol = $1 }
# Parse tokens spec: e.g. "1,2,3" "1-3" "1,2*" "*"
my @token_indices = _parse_tokens_spec($tokens_spec);
my $want_star = ($tokens_spec =~ /\*/) ? 1 : 0;
# Determine source lines
my @lines_to_process;
$source_str =~ s/\A\s+//; $source_str =~ s/\s+\z//;
if ($source_str =~ /\A'([^']*)'\z/ || ($usebackq && $source_str =~ /\A`([^`]*)`\z/)) {
# Command output
my $cmd = $1;
BATsh::Env->sync_to_env();
local *CMDOUT;
open(CMDOUT, "$cmd |") or return 1;
@lines_to_process = <CMDOUT>;
close(CMDOUT);
}
elsif ($usebackq && $source_str =~ /\A"([^"]*)"\z/) {
# usebackq: "..." = filename
my $file = $1;
local *FFH;
open(FFH, $file) or do { _warn("FOR /F: cannot open $file"); return 1 };
@lines_to_process = <FFH>;
close(FFH);
}
elsif ($source_str =~ /\A"([^"]*)"\z/ && !$usebackq) {
# No usebackq: "string" = literal string to tokenize
@lines_to_process = ("$1\n");
}
elsif ($source_str =~ /\A(\S+)\z/) {
# Bare filename
my $file = $1;
local *FFH2;
open(FFH2, $file) or do { _warn("FOR /F: cannot open $file"); return 1 };
@lines_to_process = <FFH2>;
close(FFH2);
}
else {
_warn("FOR /F: cannot parse source: $source_str");
return 1;
}
# Skip leading lines
splice(@lines_to_process, 0, $skip) if $skip > 0;
# Pre-read paren body if needed
my $paren_body = undef;
{
my $probe = $do_part;
$probe =~ s/%%[A-Za-z]//g;
if ($probe =~ /\A\s*\(\s*\z/) {
$paren_body = _read_paren_block('', $lines_ref, $i_ref);
}
}
# Determine variable names: %%a and following letters for extra tokens
my @var_names;
for my $i (0 .. $#token_indices) {
push @var_names, chr(ord($var) + $i);
}
# Star token goes to the next letter after the listed ones
my $star_var = chr(ord($var) + scalar @token_indices);
for my $src_line (@lines_to_process) {
$src_line =~ s/\r?\n\z//;
# Skip eol lines
next if $eol ne '' && $src_line =~ /\A\Q$eol\E/;
next if $src_line =~ /\A\s*\z/;
# Tokenize
my @tokens;
if ($delims eq '') {
@tokens = ($src_line);
}
else {
my $escaped_delims = quotemeta($delims);
@tokens = split /[$escaped_delims]+/, $src_line;
# cmd.exe skips leading delimiters
if ($src_line =~ /\A[$escaped_delims]/) {
shift @tokens if @tokens && $tokens[0] eq '';
}
}
# Assign to variables
for my $i (0 .. $#token_indices) {
my $tidx = $token_indices[$i] - 1; # 0-based
BATsh::Env->set("%%$var_names[$i]", defined $tokens[$tidx] ? $tokens[$tidx] : '');
}
if ($want_star && @tokens > $token_indices[-1]) {
# Star: remainder from token N onwards joined by first delimiter
my $delim1 = length($delims) > 0 ? substr($delims, 0, 1) : ' ';
my $remainder = join($delim1, @tokens[$token_indices[-1] .. $#tokens]);
BATsh::Env->set("%%$star_var", $remainder);
}
# Execute body
if (defined $paren_body) {
my $body = $paren_body;
# Restore any \x00FOR_x\x00 placeholders before substituting values
$body =~ s/\x00FOR_([A-Za-z])\x00/%%$1/g;
for my $vn (@var_names, $want_star ? ($star_var) : ()) {
my $val = defined(BATsh::Env->get("%%$vn")) ? BATsh::Env->get("%%$vn") : '';
$body =~ s/%%$vn/$val/g;
}
$body = _block_expand($body);
_exec_body($class, $body, $lines_ref, $labels_ref, $i_ref, $opts_ref, 1);
}
else {
my $do_line = $do_part;
# Restore \x00FOR_x\x00 -> %%x, then substitute values
$do_line =~ s/\x00FOR_([A-Za-z])\x00/%%$1/g;
for my $vn (@var_names, $want_star ? ($star_var) : ()) {
my $val = defined(BATsh::Env->get("%%$vn")) ? BATsh::Env->get("%%$vn") : '';
$do_line =~ s/%%$vn/$val/g;
}
$do_line = BATsh::Env->expand_cmd($do_line);
_exec_line($class, $do_line, $lines_ref, $labels_ref, $i_ref, $opts_ref, 1);
}
last if $_GOTO_LABEL ne '';
}
return 0;
}
# ----------------------------------------------------------------
# _parse_tokens_spec: "1,2,3-5,*" -> (1,2,3,4,5)
# ----------------------------------------------------------------
sub _parse_tokens_spec {
lib/BATsh/CMD.pm view on Meta::CPAN
cmd1 && cmd2 (conditional-and)
cmd1 || cmd2 (conditional-or)
I/O redirection:
> file stdout overwrite
>> file stdout append
< file stdin
2> file stderr overwrite
2>> file stderr append
2>&1 stderr to stdout
=head2 Variable Expansion
C<%VAR%> references are expanded before each line executes.
Variable names are case-insensitive (stored in uppercase internally).
Inside parenthesised IF and FOR bodies, C<%VAR%> is expanded B<at parse
time> (before the block runs), matching cmd.exe's behaviour. To observe
a value updated inside the same block, enable delayed expansion:
SETLOCAL ENABLEDELAYEDEXPANSION
SET X=old
IF 1==1 (
SET X=new
ECHO !X! &:: new -- delayed, runtime
ECHO %X% &:: old -- immediate, parse-time
)
ENDLOCAL
=head2 Escape Character
The C<^> character escapes the following character:
ECHO a^&b -> a&b (& not a compound separator)
ECHO a^^b -> a^b (literal ^)
ECHO hello^ -> helloworld (^ at end-of-line joins next line)
world
=head2 I/O Redirection
CMD > file stdout overwrite
CMD >> file stdout append
CMD 2> file stderr overwrite
CMD 2>> file stderr append
CMD < file stdin from file
C<^E<gt>> is an escaped C<E<gt>> and is B<not> treated as a redirect.
=head2 Compound Commands
cmd1 & cmd2 run cmd2 unconditionally after cmd1
cmd1 && cmd2 run cmd2 only if cmd1 succeeded (ERRORLEVEL 0)
cmd1 || cmd2 run cmd2 only if cmd1 failed (ERRORLEVEL != 0)
=head2 FOR /F Options
tokens=1,2-4 which token columns to capture (1-based)
tokens=1* token 1 to %%a; remainder to %%b
delims=CHARS field separator characters (default: space and tab)
skip=N skip first N lines
eol=C skip lines beginning with C (default: ;)
usebackq "file" reads a file; 'cmd' runs a command
Sources: bare filename, C<"quoted filename">, C<'command'>,
or C<("literal string")>.
=head2 ERRORLEVEL
C<IF ERRORLEVEL n> is true when ERRORLEVEL E<gt>= n (not equality).
ECHO does B<not> reset ERRORLEVEL (unlike some broken implementations).
=head2 Accessors
BATsh::CMD::errorlevel('BATsh::CMD') -- current ERRORLEVEL
BATsh::CMD::set_errorlevel('BATsh::CMD', n) -- set ERRORLEVEL
BATsh::CMD::echo_on('BATsh::CMD') -- current ECHO state
=head1 AUTHOR
INABA Hitoshi E<lt>ina@cpan.orgE<gt>
=head1 LICENSE
Same as Perl itself.
=cut
( run in 0.574 second using v1.01-cache-2.11-cpan-98e64b0badf )