view release on metacpan or  search on metacpan

lib/Batch/Interpreter.pm  view on Meta::CPAN

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;
my $re_pipe = qr/ \|\|? | \&\&? /x;
my $re_grouping = qr/ [\(\)] /x;
my $any_token = qr/$re_redirect | $re_pipe | $re_grouping | $re_string/x;

sub next_token {
	# trailing separator is included to not have to store separators
	# separately. the separatator will be removed in unquote_token.
	$_[0] =~ /\G ( $any_token \s*+ ) /gcxo
		or return;
	return $1;
}

sub next_token_no_pipe {
	$_[0] =~ /\G ( (?:$re_redirect | $re_grouping | $re_string) \s*+ ) /gcxo
		or return;
	return $1;
}

sub next_token_string {
	$_[0] =~ /\G ( $re_string \s*+ ) /gcxo
		or return;
	return $1;
}

sub next_token_lhs {
	$_[0] =~ /\G ( $re_lhs \s*+ ) /gcxo
		or return;
	return $1;
}

sub next_token_call_arg {
	# semantics different from next_token, because no unquote_token is
	# following
	$_[0] =~ /\G ( $re_call_arg ) $re_call_arg_separator*+ /gcxo
		or return;
	return $1;
}

sub unquote_token {
	my ($token) = @_;
	defined $token or return;

	while ($token =~ /\G [^\"\^\s]* ( $re_quotesc | \s+ ) /gcxo) {
		my ($p, $q) = (pos($token) - length($1), $1);

lib/Batch/Interpreter.pm  view on Meta::CPAN

			while (my $token = next_token $list) {
				$handle_token->($token);
			}
		} elsif ($mode eq 'recursive') {
			my $scandir = unquote_token $cmd->{scandir};

			$cmd->{echo} and $self->print_prompt('for ',
				'/r ', $scandir, " %$var in (", $list, ')'
			);

			my @token;
			push @token, $_ while defined($_ = next_token $list);

			my $wanted = sub {
				-d or return;
				my $dir = $self->sys2unc($_);
				$handle_token->(File::Spec::Win32->catfile(
					$dir, $_
				)) for @token;
			};

			find {
				no_chdir => 1, wanted => $wanted,
				preprocess => sub {
					return sort @_;
				},
			}, $self->unc2sys($scandir);

		} elsif ($mode eq 'numbers') {
			my ($start, $step, $end) = split /,/, $list;
			s/^\s+//s for $start, $step, $end;
			s/\s+$//s for $start, $step, $end;
			/^-?\d+$/ or
				return $self->syn_error(
					"for: '%s' is not a number", $_
				)
					for $start, $step, $end;

			$cmd->{echo} and $self->print_prompt('for ',
				"/l %$var in ($start, $step, $end)"
			);

			for (my $i = $start;
				$step > 0 ? $i <= $end
					: $step < 0 ? $i >= $end : 0;
				$i += $step
			) {

				local $self->{for_vars}{$var} = $i;
				my $result = $self->run_cmd($command);
				$result eq 'next' or return $result;
			}
		} elsif ($mode eq 'lines') {
			my $opts = unquote_token $cmd->{line_options};

			$cmd->{echo} and $self->print_prompt('for ',
				"/f \"$opts\" %$var in (", $list, ')'
			);

			my %opt;
			(@opt{qw(eol skip delims tokens)}, my $usebackq) = (
				undef, 0, "\t ", '1', 0
			);
			$opts =~ /\beol=(.)/i and $opt{eol} = $1;
			$opts =~ /\bskip=(\d+)/i and $opt{skip} = $1;
			$opts =~ /\bdelims=(.?[^\s]*)/i and $opt{delims} = $1;
			$opts =~ /\btokens=(\d[\d,-]*+\*?)/i
				and $opt{tokens} = $1;
			$opts =~ /\busebackq\b/i and $usebackq = 1;

			$opt{eol} and $opt{eol_re} =
				qr/^([\Q$opt{eol}\E]+)\Q$opt{eol}\E.*+$/;
			$opt{delims} ne ''
				and $opt{delim_re} = qr/[\Q$opt{delims}\E]/;

			my @token = map {
				/^(\d+)\-(\d+)$/ ? ($1 .. $2) : ($_);
			} split /,/, $opt{tokens};

			if ($token[-1] =~ s/\*$//) {
				# 1,* or 1*
				$token[-1] eq '' and pop @token;
				push @token, $token[-1]+1;
				$opt{numvals} = @token;
			} else {
				$opt{numvals} = @token+1;
			}

			/^\d++$/ or
				return $self->syn_error(
					"invalid token '%s'", $_
				)
					for @token;
			$opt{tokens} = [ map $_-1, @token ];

			my @var;
			my $varcount = "$var";
			push @var, $varcount++ for 1..$opt{numvals};

			my $type = 'files';
			if ( # $usebackq &&
				$list =~ /^\s*\"/s && $list =~ /\"\s*+$/s
			) {
				$type = 'explicit';
				$list =~ s/^\s*+\"//s;
				$list =~ s/\"\s*+$//s;
			} elsif ($usebackq &&
				$list =~ /^\s*\`/s && $list =~ /\`\s*+$/s
			) {
				$type = 'output';
				$list =~ s/^\s*+\`//s;
				$list =~ s/\`\s*+$//s;
			}

			local $self->{for_vars} = my $for_vars = {
				%{$self->{for_vars}}
			};
			if ($type eq 'explicit') {
				if (my @val = extract_for_tokens \%opt, $list) {
					@$for_vars{@var} = @val;
					my $result = $self->run_cmd($command);
					$result eq 'next' or return $result;
				}
			} elsif ($type eq 'files') {
				$list =~ /^\s+/gc;
				while (my $token =
					unquote_token next_token $list
				) {
					open my $fh, '<:crlf',
							$self->unc2sys($token)
						or return $self->os_error(
							$token, 'for'