This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Rework mod loading for %- and %!; fix mem leak
[perl5.git] / t / op / magic.t
diff --git a/t/op/magic.t b/t/op/magic.t
index 75d4ed0..536b225 100644 (file)
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 187);
+    plan (tests => 192);
 }
 
 # Test that defined() returns true for magic variables created on the fly,
 }
 
 # Test that defined() returns true for magic variables created on the fly,
@@ -26,7 +26,7 @@ BEGIN {
        # avoid using any global vars here:
        if ($v =~ s/^\^(?=.)//) {
            for(substr $v, 0, 1) {
        # 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:
            }
        }
        SKIP:
@@ -82,8 +82,12 @@ sub env_is {
         $eqv = "\n" if length($eqv) == 2 and $eqv eq "\000\n";
         is $eqv, "$val\n", $desc;
     } else {
         $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;
+        }
     }
 }
 
     }
 }
 
@@ -123,7 +127,7 @@ SKIP: {
     sub FETCH { $next_test + pop }
     tie my @tn, __PACKAGE__;
 
     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';
 
 
     print CMDPIPE "\$t1 = $tn[1]; \$t2 = $tn[2];\n", <<'END';
 
@@ -146,7 +150,7 @@ END
 
     close CMDPIPE;
 
 
     close CMDPIPE;
 
-    open( CMDPIPE, "| $PERL");
+    open( CMDPIPE, "|-", $PERL);
     print CMDPIPE "\$t3 = $tn[3];\n", <<'END';
 
     { package X;
     print CMDPIPE "\$t3 = $tn[3];\n", <<'END';
 
     { package X;
@@ -174,9 +178,10 @@ END
     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? ' : '');
     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";
 
     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' }
     print CMDPIPE <<'END';
 
     sub PVBM () { 'foo' }
@@ -277,6 +282,9 @@ $$ = $pid; # Tests below use $$
     if ($^O eq 'qnx') {
        chomp($wd = `/usr/bin/fullpath -t`);
     }
     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`);
     elsif($Is_Cygwin || $is_abs) {
        # Cygwin turns the symlink into the real file
        chomp($wd = `pwd`);
@@ -399,7 +407,7 @@ EOP
 # argv[0] assignment and by calling prctl()
 {
   SKIP: {
 # 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
 
     # We don't really need these tests. prctl() is tested in the
     # Kernel, but test it anyway for our sanity. If something doesn't
@@ -421,8 +429,9 @@ EOP
     chomp(my $argv0 = $maybe_ps->("ps h $$"));
     chomp(my $prctl = $maybe_ps->("ps hc $$"));
 
     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)");
   }
 }
 
   }
 }
 
@@ -457,6 +466,7 @@ SKIP:  {
 
     undef %Errno::;
     delete $INC{"Errno.pm"};
 
     undef %Errno::;
     delete $INC{"Errno.pm"};
+    delete $::{"!"};
 
     open(FOO, "nonesuch"); # Generate ENOENT
     my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
 
     open(FOO, "nonesuch"); # Generate ENOENT
     my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
@@ -666,11 +676,43 @@ is ${^MPEN}, undef, '${^MPEN} starts undefined';
 # This one used to croak due to that missing break:
 is ++${^MPEN}, 1, '${^MPEN} can be incremented';
 
 # 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: {
 # ^^^^^^^^^ 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;
        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")
 
  SKIP: {
        skip("clearing \%ENV is not safe when running under valgrind or on VMS")
@@ -746,13 +788,14 @@ SKIP: {
 
     SKIP: {
            skip("\$0 check only on Linux and FreeBSD", 2)
 
     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;
                    && 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;
             # perlbug #22811
             my $mydollarzero = sub {
               my($arg) = shift;
Unnamed repository; edit this file 'description' to name the repository.