view release on metacpan or  search on metacpan

t/0031-set-positional.t  view on Meta::CPAN

######################################################################
#
# 0031-set-positional.t  set [--] ARG ... sets $1..$9 / $@ / $# (v0.09)
#
# BACKGROUND
#   Until v0.09 the "set" builtin understood only its option letters
#   (-e -u -x, -o NAME) and silently ignored every operand, so the
#   standard way of feeding an argument list to a script fragment
#
#       set -- -f value
#       while getopts f: opt ; do ... done
#
#   saw an empty argument list: getopts falls back to the positional
#   parameters, and those were never set.  "set" now implements the POSIX
#   operand rules -- "set -- [ARG ...]" replaces the positional
#   parameters (clearing them when no ARG follows), and so does a first
#   operand that is not an option, as in "set a b c".  The parameters are
#   kept in the interpreter's existing %1..%9 / %* representation, the
#   one a function call and "shift" already use, so $1..$9, $@, $*, $#,
#   shift and getopts all see them.
#
# THIS TEST
#   SP01-SP02  set -- ARG ... sets $1..$3, $# and $@.
#   SP03       Quoting is respected: set -- "a b" c sets two parameters.
#   SP04       set -- with no operand clears the parameters.
#   SP05       set a b (no --) sets them too (POSIX operand rule).
#   SP06       Options and operands combine: set -e -- p q.
#   SP07       An option-only "set" leaves existing parameters alone.
#   SP08       shift works on parameters set this way.
#   SP09       getopts parses them (the case from the BACKGROUND note).
#   SP10       A full getopts loop plus shift $((OPTIND - 1)).
#   SP11       A value containing a backslash survives (v0.09 literals).
#
# COMPATIBILITY: Perl 5.005_03 and later
#
######################################################################
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 FindBin ();
use lib "$FindBin::Bin/../lib";

eval { require BATsh } or die "Cannot load BATsh: $@";

sub _capture {
    my ($code) = @_;
    my $out = '';
    local *OLDOUT;
    open(OLDOUT, ">&STDOUT") or die "cannot dup STDOUT: $!";
    my $tmp = "$FindBin::Bin/_sp_cap_$$.tmp";
    close(STDOUT);
    open(STDOUT, "> $tmp")
        or do { open(STDOUT, ">&OLDOUT"); die "cannot redirect STDOUT: $!" };
    eval { $code->() };
    my $err = $@;
    close(STDOUT);
    open(STDOUT, ">&OLDOUT") or die "cannot restore STDOUT: $!";
    close(OLDOUT);
    local *RF;
    if (open(RF, $tmp)) { local $/; $out = <RF>; close(RF) }
    unlink($tmp);
    $out = '' unless defined $out;
    warn $err if $err;
    $out =~ s/\r//g;
    $out =~ s/\s+\z//;
    return $out;