This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid an assertion failure when overloading readpipe.
[perl5.git] / t / op / gv.t
index e69c1f4..b5f63be 100755 (executable)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 use warnings;
 
 require './test.pl';
-plan( tests => 97 );
+plan( tests => 160 );
 
 # type coersion on assignment
 $foo = 'foo';
@@ -89,6 +89,34 @@ is (scalar %foo, 0);
     is($msg, '');
     *foo = undef;
     like($msg, qr/Undefined value assigned to typeglob/);
+
+    no warnings 'once';
+    # test warnings for converting globs to other forms
+    my $copy = *PWOMPF;
+    foreach ($copy, *SKREEE) {
+       $msg = '';
+       my $victim = sprintf "%d", $_;
+       like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
+            "Warning on conversion to IV");
+       is($victim, 0);
+
+       $msg = '';
+       $victim = sprintf "%u", $_;
+       like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
+            "Warning on conversion to UV");
+       is($victim, 0);
+
+       $msg = '';
+       $victim = sprintf "%e", $_;
+       like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
+            "Warning on conversion to NV");
+       like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero");
+
+       $msg = '';
+       $victim = sprintf "%s", $_;
+       is($msg, '', "No warning on stringification");
+       is($victim, '' . $_);
+    }
 }
 
 my $test = curr_test();
@@ -196,7 +224,7 @@ is($j[0], 1);
 
 {
     my $w = '';
-    $SIG{__WARN__} = sub { $w = $_[0] };
+    local $SIG{__WARN__} = sub { $w = $_[0] };
     sub abc1 ();
     local *abc1 = sub { };
     is ($w, '');
@@ -267,7 +295,9 @@ EOPROG
 # There are certain space optimisations implemented via promotion rules to
 # GVs
 
-ok(!exists $::{oonk}, "no symbols of any sort to start with");
+foreach (qw (oonk ga_shloip)) {
+    ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
+}
 
 # A string in place of the typeglob is promoted to the function prototype
 $::{oonk} = "pie";
@@ -278,7 +308,7 @@ is ($proto, "pie", "String is promoted to prototype");
 
 # A reference to a value is used to generate a constant subroutine
 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
-                  \*STDIN, \&ok, \undef) {
+                  \*STDIN, \&ok, \undef, *STDOUT) {
     delete $::{oonk};
     $::{oonk} = \$value;
     $proto = eval 'prototype \&oonk';
@@ -287,9 +317,174 @@ foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
 
     my $got = eval 'oonk';
     die if $@;
-    is (ref $got, ref $value, "Correct type of value");
+    is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
     is ($got, $value, "Value is correctly set");
 }
+
+delete $::{oonk};
+$::{oonk} = \"Value";
+
+*{"ga_shloip"} = \&{"oonk"};
+
+is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'ga_shloip', "Value", "Constant has correct value");
+is (ref $::{ga_shloip}, 'SCALAR',
+    "Inlining of constant doesn't change represenatation");
+
+delete $::{ga_shloip};
+
+eval 'sub ga_shloip (); 1' or die $@;
+is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
+
+# Check that a prototype expands.
+*{"ga_shloip"} = \&{"oonk"};
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'ga_shloip', "Value", "Constant has correct value");
+is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
+
+
+@::zwot = ('Zwot!');
+
+# Check that assignment to an existing typeglob works
+{
+  my $w = '';
+  local $SIG{__WARN__} = sub { $w = $_[0] };
+  *{"zwot"} = \&{"oonk"};
+  is($w, '', "Should be no warning");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'zwot', "Value", "Constant has correct value");
+is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
+is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
+
+sub spritsits () {
+    "Traditional";
+}
+
+# Check that assignment to an existing subroutine works
+{
+  my $w = '';
+  local $SIG{__WARN__} = sub { $w = $_[0] };
+  *{"spritsits"} = \&{"oonk"};
+  like($w, qr/^Constant subroutine main::spritsits redefined/,
+       "Redefining a constant sub should warn");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'spritsits', "Value", "Constant has correct value");
+is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
+
+my $result;
+# Check that assignment to an existing typeglob works
+{
+  my $w = '';
+  local $SIG{__WARN__} = sub { $w = $_[0] };
+  $result = *{"plunk"} = \&{"oonk"};
+  is($w, '', "Should be no warning");
+}
+
+is (ref \$result, 'GLOB',
+    "Non void assignment should still return a typeglob");
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'plunk', "Value", "Constant has correct value");
+is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
+
+my $gr = eval '\*plunk' or die;
+
+{
+  my $w = '';
+  local $SIG{__WARN__} = sub { $w = $_[0] };
+  $result = *{$gr} = \&{"oonk"};
+  is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'plunk', "Value", "Constant has correct value");
+is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
+
+{
+    use vars qw($glook $smek $foof);
+    # Check reference assignment isn't affected by the SV type (bug #38439)
+    $glook = 3;
+    $smek = 4;
+    $foof = "halt and cool down";
+
+    my $rv = \*smek;
+    is($glook, 3);
+    *glook = $rv;
+    is($glook, 4);
+
+    my $pv = "";
+    $pv = \*smek;
+    is($foof, "halt and cool down");
+    *foof = $pv;
+    is($foof, 4);
+}
+
+format =
+.
+
+foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+    # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
+    # IO::Handle, which isn't what we want.
+    my $type = $value;
+    $type =~ s/.*=//;
+    $type =~ s/\(.*//;
+    delete $::{oonk};
+    $::{oonk} = $value;
+    $proto = eval 'prototype \&oonk';
+    like ($@, qr/^Cannot convert a reference to $type to typeglob/,
+         "Cannot upgrade ref-to-$type to typeglob");
+}
+
+{
+    no warnings qw(once uninitialized);
+    my $g = \*clatter;
+    my $r = eval {no strict; ${*{$g}{SCALAR}}};
+    is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
+
+    $g = \*vowm;
+    $r = eval {use strict; ${*{$g}{SCALAR}}};
+    is ($@, '',
+       "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
+}
+
+{
+    # Bug reported by broquaint on IRC
+    *slosh::{HASH}->{ISA}=[];
+    slosh->import;
+    pass("gv_fetchmeth coped with the unexpected");
+
+    # An audit found these:
+    {
+       package slosh;
+       sub rip {
+           my $s = shift;
+           $s->SUPER::rip;
+       }
+    }
+    eval {slosh->rip;};
+    like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
+
+    is(slosh->isa('swoosh'), '');
+
+    $CORE::GLOBAL::{"lock"}=[];
+    eval "no warnings; lock";
+    like($@, qr/^Not enough arguments for lock/,
+       "Can't trip up general keyword overloading");
+
+    $CORE::GLOBAL::{"readline"}=[];
+    eval "no warnings; <STDOUT>";
+    is($@, '', "Can't trip up readline overloading");
+
+    $CORE::GLOBAL::{"readpipe"}=[];
+    eval "`` if 0";
+    is($@, '', "Can't trip up readpipe overloading");
+}
 __END__
 Perl
 Rules