BEGIN {
$| = 1;
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
- plan (tests => 179);
+ set_up_inc( '../lib' );
+ plan (tests => 192); # some tests are run in BEGIN block
}
# Test that defined() returns true for magic variables created on the fly,
# avoid using any global vars here:
if ($v =~ s/^\^(?=.)//) {
for(substr $v, 0, 1) {
- $_ = chr ord() - 64;
+ $_ = chr(utf8::native_to_unicode(ord($_)) - 64);
}
}
SKIP:
$Is_os2 = $^O eq 'os2';
$Is_Cygwin = $^O eq 'cygwin';
-$PERL = $ENV{PERL} ||
+$PERL =
($Is_NetWare ? 'perl' :
$Is_VMS ? $^X :
$Is_MSWin32 ? '.\perl' :
'./perl');
+
sub env_is {
my ($key, $val, $desc) = @_;
$eqv = "\n" if length($eqv) == 2 and $eqv eq "\000\n";
is $eqv, "$val\n", $desc;
} else {
- chomp (my @env = grep { s/^$key=// } `env`);
- is "@env", $val, $desc;
+ my @env = `env`;
+ SKIP: {
+ skip("env doesn't work on this android", 1) if !@env && $^O =~ /android/;
+ chomp (my @env = grep { s/^$key=// } @env);
+ is "@env", $val, $desc;
+ }
}
}
eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval
# cmd.exe will echo 'variable=value' but 4nt will echo just the value
# -- Nikola Knezevic
-if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/; }
+if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/m; }
elsif ($Is_VMS) { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; }
else { is `echo \$FOO`, "hi there\n"; }
unlink_all 'ajslkdfpqjsjfk';
$! = 0;
open(FOO,'ajslkdfpqjsjfk');
-isnt($!, 0);
+isnt($!, 0, "Unlinked file can't be opened");
close FOO; # just mention it, squelch used-only-once
SKIP: {
sub FETCH { $next_test + pop }
tie my @tn, __PACKAGE__;
- open( CMDPIPE, "| $PERL");
+ open( CMDPIPE, "|-", $PERL);
print CMDPIPE "\$t1 = $tn[1]; \$t2 = $tn[2];\n", <<'END';
close CMDPIPE;
- open( CMDPIPE, "| $PERL");
+ open( CMDPIPE, "|-", $PERL);
print CMDPIPE "\$t3 = $tn[3];\n", <<'END';
{ package X;
close CMDPIPE;
$? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte
my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : '');
+ $todo = ($Config{usecrosscompile} ? '# TODO: Not sure whats going on here when cross-compiling' : '');
print $? & 0xFF ? "ok $tn[4]$todo\n" : "not ok $tn[4]$todo\n";
- open(CMDPIPE, "| $PERL");
+ open(CMDPIPE, "|-", $PERL);
print CMDPIPE <<'END';
sub PVBM () { 'foo' }
is join(':',@val1), join(':',@val2);
cmp_ok @val1, '>', 1;
+# deleting $::{ENV}
+is runperl(prog => 'delete $::{ENV}; chdir; print qq-ok\n-'), "ok\n",
+ 'deleting $::{ENV}';
+
# regex vars
'foobarbaz' =~ /b(a)r/;
is $`, 'foo';
eval { die "foo\n" };
is $@, "foo\n";
+ok !*@{HASH}, 'no %@';
+
cmp_ok($$, '>', 0);
my $pid = $$;
eval { $$ = 42 };
if ($^O eq 'qnx') {
chomp($wd = `/usr/bin/fullpath -t`);
}
+ elsif($^O =~ /android/) {
+ chomp($wd = `sh -c 'pwd'`);
+ }
elsif($Is_Cygwin || $is_abs) {
# Cygwin turns the symlink into the real file
chomp($wd = `pwd`);
# argv[0] assignment and by calling prctl()
{
SKIP: {
- skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name};
+ skip "We don't have prctl() here, or we're on Android", 2 unless $Config{d_prctl_set_name} && $^O ne 'android';
# We don't really need these tests. prctl() is tested in the
# Kernel, but test it anyway for our sanity. If something doesn't
chomp(my $argv0 = $maybe_ps->("ps h $$"));
chomp(my $prctl = $maybe_ps->("ps hc $$"));
- like($argv0, $name, "Set process name through argv[0] ($argv0)");
- like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)");
+ like($argv0, qr/$name/, "Set process name through argv[0] ($argv0)");
+ my $name_substr = substr($name, 0, 15);
+ like($prctl, qr/$name_substr/, "Set process name through prctl() ($prctl)");
}
}
undef %Errno::;
delete $INC{"Errno.pm"};
+ delete $::{"!"};
open(FOO, "nonesuch"); # Generate ENOENT
my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
}
# Check that we don't auto-load packages
-SKIP: {
- skip "staticly linked; may be preloaded", 4 unless $Config{usedl};
- foreach (['powie::!', 'Errno'],
- ['powie::+', 'Tie::Hash::NamedCapture']) {
- my ($symbol, $package) = @$_;
+foreach (['powie::!', 'Errno']) {
+ my ($symbol, $package) = @$_;
+ SKIP: {
+ (my $extension = $package) =~ s|::|/|g;
+ skip "$package is statically linked", 2
+ if $Config{static_ext} =~ m|\b\Q$extension\E\b|;
foreach my $scalar_first ('', '$$symbol;') {
my $desc = qq{Referencing %{"$symbol"}};
$desc .= qq{ after mentioning \${"$symbol"}} if $scalar_first;
}
SKIP: {
- skip_if_miniperl("No XS in miniperl", 3);
+ skip_if_miniperl("No XS in miniperl", 1);
- for ( [qw( %- Tie::Hash::NamedCapture )], [qw( $[ arybase )],
- [qw( %! Errno )] ) {
+ for ( [qw( %! Errno )] ) {
my ($var, $mod) = @$_;
my $modfile = $mod =~ s|::|/|gr . ".pm";
fresh_perl_is
# This also tests that ${^LAST_FH} is a weak reference:
is ${^LAST_FH}, undef, '${^LAST_FH} is undef when PL_last_in_gv is NULL';
+# all of these would set PL_last_in_gv to a non-GV which would
+# assert when referenced by the magic for ${^LAST_FH}.
+# The approach to fixing this has changed (#128263), but it's still useful
+# to check each op.
+for my $code ('tell $0', 'sysseek $0, 0, 0', 'seek $0, 0, 0', 'eof $0') {
+ fresh_perl_is("$code; print defined \${^LAST_FH} ? qq(not ok\n) : qq(ok\n)", "ok\n",
+ undef, "check $code doesn't define \${^LAST_FH}");
+}
# $|
fresh_perl_is 'print $| = ~$|', "1\n", {switches => ['-l']},
'select f; undef *f; ${q/|/}; print STDOUT qq|ok\n|', "ok\n", {},
'[perl #115206] no crash when vivifying $| while *{+select}{IO} is undef';
+# ${^OPEN} and $^H interaction
+# Setting ${^OPEN} causes $^H to change, but setting $^H would only some-
+# times make ${^OPEN} change, depending on whether it was in the same BEGIN
+# block. Don’t test actual values (subject to change); just test for
+# consistency.
+my @stuff;
+eval '
+ BEGIN { ${^OPEN} = "a\0b"; $^H = 0; push @stuff, ${^OPEN} }
+ BEGIN { ${^OPEN} = "a\0b"; $^H = 0 } BEGIN { push @stuff, ${^OPEN} }
+1' or die $@;
+is $stuff[0], $stuff[1], '$^H modifies ${^OPEN} consistently';
+
+# deleting $::{"\cH"}
+is runperl(prog => 'delete $::{qq-\cH-}; ${^OPEN}=foo; print qq-ok\n-'),
+ "ok\n",
+ 'deleting $::{"\cH"}';
+
+# Tests for some non-magic names:
+is ${^MPE}, undef, '${^MPE} starts undefined';
+is ++${^MPE}, 1, '${^MPE} can be incremented';
+
+# This one used to behave as ${^MATCH} due to a missing break:
+is ${^MPEN}, undef, '${^MPEN} starts undefined';
+# This one used to croak due to that missing break:
+is ++${^MPEN}, 1, '${^MPEN} can be incremented';
+
+{
+ no warnings 'deprecated';
+ eval { ${^E_NCODING} = 1 };
+ is $@, "", 'Setting ${^E_NCODING} does nothing';
+ $_ = ${^E_NCODING};
+ pass('can read ${^E_NCODING} without blowing up');
+ is $_, 1, '${^E_NCODING} is whatever it was set to';
+}
+
+{
+ my $warned = 0;
+ local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; };
+ unshift @RT12608::A::ISA, qw(RT12608::B RT12608::C);
+ is $warned, 0, '[perl #126082] unshifting onto @ISA doesn\'t trigger set magic for each item';
+}
+
+{
+ my $warned = 0;
+ local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; };
+
+ my $x; tie $x, 'RT12608::F';
+ unshift @RT12608::X::ISA, $x, "RT12608::Z";
+ is $warned, 0, '[perl #126082] PL_delaymagic correctly/saved restored when pushing/unshifting onto @ISA';
+
+ package RT12608::F;
+ use parent 'Tie::Scalar';
+ sub TIESCALAR { bless {}; }
+ sub FETCH { push @RT12608::G::ISA, "RT12608::H"; "RT12608::Y"; }
+}
+
# ^^^^^^^^^ New tests go here ^^^^^^^^^
SKIP: {
- skip("%ENV manipulations fail or aren't safe on $^O", 19)
+ skip("%ENV manipulations fail or aren't safe on $^O", 20)
if $Is_Dos;
+ skip "Win32 needs XS for env/shell tests", 20
+ if $Is_MSWin32 && is_miniperl;
SKIP: {
skip("clearing \%ENV is not safe when running under valgrind or on VMS")
if $ENV{PERL_VALGRIND} || $Is_VMS;
$PATH = $ENV{PATH};
+ $SYSTEMROOT = $ENV{SYSTEMROOT} if exists $ENV{SYSTEMROOT}; # win32
$PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
$ENV{foo} = "bar";
%ENV = ();
$ENV{PATH} = $PATH;
+ $ENV{SYSTEMROOT} = $SYSTEMROOT if defined $SYSTEMROOT;
$ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0;
if ($Is_MSWin32) {
is `set foo 2>NUL`, "";
SKIP: {
skip("\$0 check only on Linux and FreeBSD", 2)
- unless $^O =~ /^(linux|freebsd)$/
+ unless $^O =~ /^(linux|android|freebsd)$/
&& open CMDLINE, "/proc/$$/cmdline";
chomp(my $line = scalar <CMDLINE>);
my $me = (split /\0/, $line)[0];
is $me, $0, 'altering $0 is effective (testing with /proc/)';
close CMDLINE;
+ skip("\$0 check with 'ps' only on Linux (but not Android) and FreeBSD", 1) if $^O eq 'android';
# perlbug #22811
my $mydollarzero = sub {
my($arg) = shift;