Batch-Interpreter
view release on metacpan or search on metacpan
lib/Batch/Interpreter.pm view on Meta::CPAN
package Batch::Interpreter;
use v5.10;
use warnings;
use strict;
=head1 NAME
Batch::Interpreter - interpreter for CMD.EXE batch files
=head1 VERSION
Version 0.01
=cut
our $VERSION = '0.01';
=head1 SYNOPSIS
use Batch::Interpreter;
open my $fh, '<:crlf', $ARGV[0]
or die "$ARGV[0]: $!";
my $rc = Batch::Interpreter->new(
locale => 'de_DE',
# more settings, see below
)->run({}, [ <$fh> ], @ARGV);
=head1 METHODS
=head2 ->new(%settings)
Create an instance of the class, which can be custimized with the following parameters (values for keys of C<%settings>):
=head3 Customization and Behavior
=over
=item filenames => $self->default_filenames
A Hash with the mapping of emulated filenames to host filenames, the default likely contains the entry NUL => '/dev/null'.
=item mountpoints => []
Mapping of emulated mount points (in most cases: drives) to host directories. The entries are scanned in order. Example: 'D:\' => '/mnt/data'.
=item remote_names => []
Mapping of emulated directories to remote names, for prompt $M.
=item extension_handlers => $self->builtin_extension_handlers
The list of handlers for file extensions. See chapter 'Extension Handlers' for the call interface.
=item internal_commands => $self->builtin_internal_commands
The list of handlers for internal commands, i.e. commands handled by CMD.EXE. See chapter 'Command Handlers' for the call interface.
=item external_commands => $self->builtin_external_commands
The list of handlers for external commands, i.e. command line tools. See chapter 'Command Handlers' for the call interface.
=item locale
The locale, see chapter LOCALES.
=back
=head3 Interpreter State
=over
=item echo => 1
State of the ECHO setting, 0 = OFF, 1 = ON.
=item exit_value => 0
%ERRORLEVEL%.
=item extensions => 1
State of SETLOCAL ENABLEEXTENSIONS / DISABLEEXTENSIONS, 0 = DISABLE, 1 = ENABLE.
.
Extensions are always enabled, but the state variable is maintained correctly.
=item delayedexpansion => 1
State of SETLOCAL ENABLEDELAYEDEXPANSION / DISABLEDELAYEDEXPANSION, 0 = DISABLE, 1 = ENABLE.
=item vars => {}
The values of the environment variables. Due to the case insensitivity all keys are in CAPS, while the real case of the variable names is stored in varcases under the same key.
=item varcases => { map((uc $_ => $_), keys %{$self->{vars}}), %{$self->default_variable_cases} }
See vars.
=back
=head3 Defaults and Constants
=over
=item version_string => __PACKAGE__." $VERSION"
The string for prompt $V and the ver command.
=item default_drive => 'C'
The default drive. Per default a mountpoint for this drive is generated.
=item default_pathext => '.COM;.EXE;.BAT'
The default, if %PATHEXT% is unset.
=back
=head3 User Interface
=over
=item terminal => undef
lib/Batch/Interpreter.pm view on Meta::CPAN
C<$attr> has the keys
=over
=item quoted_arguments => undef
Set to true, if C<@arg> contains quoted arguments. In this case the values in C<@arg> have to be quoted like under the emulated system. Specifically, they have to look like the return value of the internal function C<next_token()>, i.e. trailing blan...
=back
=head1 CUSTOMIZATION
=head2 Extension Handlers
Extension handlers are CodeRefs, that are called with the arguments:
my $ret = $handler->($self, $command, \@arg, $qcommand, \@qarg);
C<$self> is the interpreter instance, C<$command> is the name of the command (i.e. the key the handler was found under in the handler hash), C<@arg> is the array of unquoted command line arguments. $C<$qcommand> and C<@qarg> and C<$args> are the raw ...
The code has to return an empty list (to do nothing) or a list with the name of the interpreter and the arguments that lead to the interpretation of C<$command> (likely including C<$command> itself), which is prepended to C<@arg> and C<@qarg> in the ...
=head2 Command Handlers
Command handlers are CodeRefs, that are called with the arguments:
my $ret = $handler->($self, $command, \@arg, \@qarg, $args);
C<$self> is the interpreter instance, C<$command> is the name of the command (i.e. the key the handler was found under in the handler hash), C<@arg> is the array of unquoted command line arguments. C<@qarg> and C<$args> are the raw forms of C<@arg>, ...
The handler can:
=over
=item
Execute the command and return a numeric exit code or the value 'keep' to keep the %ERRORLEVEL% unchanged, or return a string beginning with the word 'error' to signal an error.
If the handler culminates in calling an external program, it will likely be based on the methods $self->unc2sys($path), $self->unc2sys_arg($path) and $self->run_external_command($attr, $exe, @arg), which are documented elsewhere in this document.
=item
Optionally change the contents of C<@arg> (and C<@qarg>, if finished is not set) and return a HashRef with the following keys:
=over
=item type
Must be 'rewrite'.
=item command
Return a new C<$command> to restart the handler search.
=back
=back
=head2 Locales
The locale class has to implement the following methods:
=head3 ->format_date($year, $month, $day)
Format a date for %DATE%, prompt $D, and the date command.
=head3 ->format_time_short($hour, $min)
Format a time for the time command.
=head3 ->format_time($hour, $min, $sec, $sec100)
Format a time for %TIME%, and prompt $T.
=head3 ->format_file_timedate($year, $month, $day, $hour, $min)
Format a file timestamp for the dir command.
=head3 ->format_file_timedate_for($year, $month, $day, $hour, $min)
Format a file timestamp for for %I in (...) do echo %~tI
=head3 ->get_string($category, $key)
Get a localized version of string C<$key> in category C<$category>. The only implemented category is 'message'.
=head1 METHODS TO BE CALLED FROM COMMAND HANDLERS
=cut
use Data::Dump qw(dump);
use Cwd;
use Time::HiRes qw(gettimeofday);
use List::MoreUtils qw(first_value);
use File::DosGlob qw(glob);
use File::Spec;
use File::Spec::Win32;
use File::Temp;
use File::Find;
use File::Copy;
use Clone qw(clone);
use POSIX ":sys_wait_h";
my $is_win_host = $^O =~ /Win32/;
# TODO: is there a need to port this to Moo??
sub new {
my ($class, @arg) = @_;
my $self = bless {
var_path_cache => {},
dump_parse_tree => undef,
verbose_system => undef,
echo => 1,
exit_value => 0,
extensions => 1, # always active :)
delayedexpansion => 1,
default_pathext => '.COM;.EXE;.BAT',
default_drive => 'C',
version_string => __PACKAGE__." $VERSION",
@arg
}, $class;
$self->{vars} //= {};
$self->{varcases} //= {
map((uc $_ => $_), keys %{$self->{vars}}),
%{$self->default_variable_cases},
};
$self->{filenames} //= $self->default_filenames;
$self->{extension_handlers} //= $self->builtin_extension_handlers;
$self->{internal_commands} //= $self->builtin_internal_commands;
$self->{external_commands} //= $self->builtin_external_commands;
# no commands are implemented by the windows shell, but not emulated
$self->{assume_is_executable} //= {};
# mapping back and forth (potentially)
$self->{filename_map} = { %{delete($self->{filenames}) // {}} };
$self->{filename_invmap} = { reverse %{$self->{filename_map}} };
$self->{remote_name_map} //= delete($self->{remote_names}) // [];
normalize_map($self->{remote_name_map}, sub {
my ($path) = @_;
$path =~ y|\\|/|;
return $path;
}, undef);
$self->{mountpoint_map} = [
map {
$_;
} @{delete($self->{mountpoints}) // [
$self->{default_drive}.':' => '/',
]}
];
# need to write system paths with unix slashes to be compatible with # for_first_match
normalize_map($self->{mountpoint_map}, sub {
my ($path) = @_;
$path =~ y|\\|/|;
return $path;
}, sub {
my ($path) = @_;
$path = File::Spec->rel2abs($path);
$path =~ y|\\|/|;
return $path;
});
defined $self->{locale}
or die "missing locale";
if ('' eq ref(my $locale = $self->{locale})) {
my $first_err;
my $locale_class = "Batch::Interpreter::Locale::$locale";
eval "require $locale_class";
if ($@) {
$first_err = $@;
$locale_class = $locale;
eval "require $locale_class";
}
$@ and die "couldn't load locale $locale:\n$first_err\n$@";
$self->{locale} = $locale_class;
}
if (my @missing = grep !$self->{locale}->can($_), qw(
format_date format_time_short format_time
format_file_timedate format_file_timedate_for
get_string
)) {
die "invalid locale, no handler for: ", join ', ', @missing;
}
return $self;
}
sub deep_clone {
my ($self, @modifier) = @_;
return bless clone({ %$self, @modifier }), ref $self;
}
sub get_message {
my ($self, $message) = @_;
return $self->{locale}->get_string('message', $message) // $message;
}
sub internal_error {
my ($self, $message, @arg) = @_;
return 'error: '.sprintf $message, @arg;
}
sub syn_error {
my ($self, $message, @arg) = @_;
return 'error: '.sprintf $self->get_message($message), @arg;
}
sub os_error {
my ($self, $name, $message, @arg) = @_;
return 'error: '.sprintf($self->get_message($message // ''), @arg).
" '$name': $!";
}
eval q{
use Win32::ShellQuote qw(quote_native);
};
$@ and eval {
sub quote_native {
my ($str) = @_;
$str =~ s/(\W)/\\$1/g;
return $str;
}
};
sub set_variable {
my ($self, $variable, $value) = @_;
$self->{verbose_set}
and say STDERR "SET($variable=$value)";
defined($value) && '' eq $value
and undef $value;
my $uc_var = uc $variable;
if (defined($value)
? defined $self->{vars}{$uc_var} &&
$self->{vars}{$uc_var} eq $value
: !exists $self->{vars}{$uc_var}
) {
# no value change
$self->{varcases}{$uc_var} = $variable;
return;
}
if (defined $value) {
$self->{vars}{$uc_var} = $value;
$self->{varcases}{$uc_var} = $variable;
} else {
delete $self->{vars}{$uc_var};
delete $self->{varcases}{$uc_var};
}
if ($uc_var eq 'PATHEXT') {
%{$self->{var_path_cache}} = ();
} else {
delete $self->{var_path_cache}{$uc_var};
}
}
sub get_date {
my ($self) = @_;
my @localtime = localtime;
return $self->{locale}->format_date(
$localtime[5]+1900, $localtime[4]+1, $localtime[3]
);
}
sub get_time {
my ($self, $short) = @_;
my @time = gettimeofday;
my @localtime = localtime $time[0];
if ($short) {
return $self->{locale}->format_time_short(
$localtime[2], $localtime[1]
);
} else {
return $self->{locale}->format_time(
$localtime[2], $localtime[1],
$localtime[0], $time[1]/10000
);
}
}
sub normalize_map {
my ($map, $callback_unc, $callback_sys) = @_;
for (0..$#$map) {
if (my $callback = ($_ & 1) ? $callback_sys : $callback_unc) {
my $path = $callback->($map->[$_]);
$path =~ s/(?<!\/)$/\//;
$map->[$_] = $path;
}
}
}
sub for_first_match {
my ($path, $map, $cmp, $callback) = @_;
(my $mpath = uc $path) =~ y|\\|/|;
$mpath =~ s/(?<!\/)$/\//;
for my $i (0..($#$map-1)/2) {
if (uc($map->[$i*2+$cmp]) eq
substr $mpath, 0, length $map->[$i*2+$cmp]
) {
$callback->(
length $map->[$i*2+$cmp], $map->[$i*2+1-$cmp]
);
last;
}
}
}
=head2 ->unc2sys($path)
Translates an emulated path into a host path.
Convert path separators from \ to / and apply the filename and mountpoint translation rules, return the result.
Bug: the path is not actually UNC, though that _may_ work through mountpoint translation.
=cut
my $switch_slashes = !$is_win_host;
sub unc2sys {
my ($self, $path) = @_;
$switch_slashes and $path =~ y|\\|/|;
if (exists $self->{filename_map}{uc $path}) {
defined($_ = $self->{filename_map}{uc $path})
and return $_;
}
if (File::Spec->file_name_is_absolute($path)) {
for_first_match $path, $self->{mountpoint_map}, 0, sub {
my ($offs, $val) = @_;
substr $path, 0, $offs, $val;
lib/Batch/Interpreter.pm view on Meta::CPAN
File::Spec::Win32->catdir($self->sys2unc(getcwd));
}
sub get_remote_name {
my ($self, $path) = @_;
my $result;
for_first_match $path, $self->{remote_name_map}, 0, sub {
my ($offs, $val) = @_;
$result = $val;
};
return $result // '';
}
sub get_drive {
my ($self, $path) = @_;
return (File::Spec::Win32->splitpath($path))[0]
// $self->{default_drive}.':';
}
sub get_path {
my ($self, $path) = @_;
return (File::Spec::Win32->splitpath($path))[1] // '\\';
}
sub get_filename {
my ($self, $path) = @_;
my $name = (File::Spec::Win32->splitpath($path))[2];
$name =~ s/\.[^\.]+$//;
return $name;
}
sub get_fileext {
my ($self, $path) = @_;
my $name = (File::Spec::Win32->splitpath($path))[2];
$name =~ /(\.[^\.]+)$/
and return $1;
return '';
}
sub get_short_path {
my ($self, $path) = @_;
# TODO: not implemented
return $path;
}
sub get_file_attr {
my ($self, $syspath) = @_;
# TODO: too simple
return '--a------';
}
sub get_file_timedate {
my ($self, $syspath, $mode) = @_;
my @localtime = localtime((stat $syspath)[9] // 0);
my @timedate = (
$localtime[5]+1900, $localtime[4]+1, $localtime[3],
$localtime[2], $localtime[1],
);
return ($mode//'') eq 'for'
? $self->{locale}->format_file_timedate_for(@timedate)
: $self->{locale}->format_file_timedate(@timedate)
;
}
sub format_size {
my ($self, $size) = @_;
1 while $size =~ s/(?<=\d)(\d\d\d)(?!\d)/.$1/;
return $size;
}
sub set_subprocess_env {
my ($self, $add_env) = @_;
my %old = %ENV;
my $case = $self->{varcases};
my @copy = grep exists($case->{$_}), keys %{$self->{vars}};
# select the variables that can be safely copied
if ($is_win_host) {
# setting a variable converts its case
#@copy = grep $_ eq ($case->{$_} // 'a'), @copy;
} else {
}
# TODO: convert the variables that have to be translated
@ENV{@$case{@copy}} = @{$self->{vars}}{@copy};
$add_env and
@ENV{keys %$add_env} = values %$add_env;
return %old;
}
sub extract_for_tokens {
my ($opts, $line) = @_;
if ($opts->{skip}) {
$opts->{skip}--;
return;
}
# skip empty lines
$line =~ /\S/ or return;
$opts->{eol_re} and $line =~ s/$opts->{eol_re}/$1/;
return map $_ // '', ($opts->{delim_re}
? split($opts->{delim_re}, $line, $opts->{numvals})
: ($line)
)[@{$opts->{tokens}}];
}
my $re_quoted = qr/ \" (?:\\.|\"\"|[^\\\"])*+ (?:\"|$) /x;
my $re_quotesc = qr/ \^. | $re_quoted /xo;
my $re_string =
qr/ (?: $re_quotesc | \d(?!\>) | [^\<\>\|\&\(\)\"\^\s] )++ /xo;
my $re_lhs =
qr/ (?: $re_quotesc | \d(?!\>) | [^\<\>\|\&\(\)\"\^\s\=] )++ /xo;
my $re_call_arg =
qr/ (?: $re_quotesc | \d(?!\>) | [^\<\>\|\&\(\)\"\^\s\=\,] )++ /xo;
my $re_call_arg_separator = qr/ [\=\,\s] /x;
my $re_redirect = qr/ \< | \d?\>\>?(?:\&\d?)? /x;
( run in 1.303 second using v1.01-cache-2.11-cpan-ceb78f64989 )