#!./perl
BEGIN {
- chdir 't';
- @INC = '../lib';
+ chdir 't' if -d 't';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
use warnings;
no warnings 'uninitialized';
+no warnings 'experimental::smartmatch';
+
+++$|;
use Tie::Array;
use Tie::Hash;
my %empty;
my @sparse; $sparse[2] = 2;
-my $deep1 = []; push @$deep1, \$deep1;
-my $deep2 = []; push @$deep2, \$deep2;
+my $deep1 = []; push @$deep1, $deep1;
+my $deep2 = []; push @$deep2, $deep2;
my @nums = (1..10);
tie my @tied_nums, 'Tie::StdArray';
}
{
+ package Test::Object::StringOverload;
+ use overload '""' => sub { "object" }, fallback => 1;
+ sub new { bless { key => 1 } }
+}
+
+{
package Test::Object::WithOverload;
- sub new { bless { key => 'magic' } }
- use overload '~~' => sub { my %hash = %{ $_[0] }; $_[1] eq $hash{key} };
+ sub new { bless { key => ($_[1] // 'magic') } }
+ use overload '~~' => sub {
+ my %hash = %{ $_[0] };
+ if ($_[2]) { # arguments reversed ?
+ return $_[1] eq reverse $hash{key};
+ }
+ else {
+ return $_[1] eq $hash{key};
+ }
+ };
use overload '""' => sub { "stringified" };
use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
}
our $ov_obj = Test::Object::WithOverload->new;
+our $ov_obj_2 = Test::Object::WithOverload->new("object");
our $obj = Test::Object::NoOverload->new;
+our $str_obj = Test::Object::StringOverload->new;
+
+my %refh;
+unless (is_miniperl()) {
+ require Tie::RefHash;
+ tie %refh, 'Tie::RefHash';
+ $refh{$ov_obj} = 1;
+}
my @keyandmore = qw(key and more);
my @fooormore = qw(foo or more);
my %fooormore = map { $_ => 0 } @fooormore;
# Load and run the tests
-plan "no_plan";
+plan tests => 349+2;
while (<DATA>) {
+ SKIP: {
next if /^#/ || !/\S/;
chomp;
my ($yn, $left, $right, $note) = split /\t+/;
$res = eval "no warnings; $tstr";
}
else {
+ skip_if_miniperl("Doesn't work with miniperl", $yn =~ /=/ ? 2 : 1)
+ if $note =~ /MINISKIP/;
$res = eval $tstr;
}
$tstr = "$right ~~ $left";
goto test_again;
}
+ }
}
sub foo {}
sub TRUE() { 1 }
sub NOT_DEF() { undef }
+{
+ # [perl #123860]
+ # this can but might not crash
+ # This can but might not crash
+ #
+ # The second smartmatch would leave a &PL_sv_no on the stack for
+ # each key it checked in %!, this could then cause various types of
+ # crash or assertion failure.
+ #
+ # This isn't guaranteed to crash, but if the stack issue is
+ # re-introduced it will probably crash in one of the many smoke
+ # builds.
+ fresh_perl_is('print (q(x) ~~ q(x)) | (/x/ ~~ %!)', "1",
+ { switches => [ "-MErrno", "-M-warnings=experimental::smartmatch" ] },
+ "don't fill the stack with rubbish");
+}
+
+{
+ # [perl #123860] continued;
+ # smartmatch was failing to SPAGAIN after pushing an SV and calling
+ # pp_match, which may have resulted in the stack being realloced
+ # in the meantime. Test this by filling the stack with pregressively
+ # larger amounts of data. At some point the stack will get realloced.
+ my @a = qw(x);
+ my %h = qw(x 1);
+ my @args;
+ my $x = 1;
+ my $bad = -1;
+ for (1..1000) {
+ push @args, $_;
+ my $exp_n = join '-', (@args, $x == 0);
+ my $exp_y = join '-', (@args, $x == 1);
+
+ my $got_an = join '-', (@args, (/X/ ~~ @a));
+ my $got_ay = join '-', (@args, (/x/ ~~ @a));
+ my $got_hn = join '-', (@args, (/X/ ~~ %h));
+ my $got_hy = join '-', (@args, (/x/ ~~ %h));
+
+ if ( $exp_n ne $got_an || $exp_n ne $got_hn
+ || $exp_y ne $got_ay || $exp_y ne $got_hy
+ ) {
+ $bad = $_;
+ last;
+ }
+ }
+ is($bad, -1, "RT 123860: stack realloc");
+}
+
+
# Prefix character :
# - expected to match
# ! - expected to not match
# Any ~~ object overloaded
! \&fatal $ov_obj
- 'magic' $ov_obj
-! 'not magic' $ov_obj
+ 'cigam' $ov_obj
+! 'cigam on' $ov_obj
+! ['cigam'] $ov_obj
+! ['stringified'] $ov_obj
+! { cigam => 1 } $ov_obj
+! { stringified => 1 } $ov_obj
! $obj $ov_obj
! undef $ov_obj
# regular object
@ $obj $obj
@ $ov_obj $obj
-@ \&fatal $obj
+=@ \&fatal $obj
@ \&FALSE $obj
@ \&foo $obj
@ sub { 1 } $obj
@ "key" $obj
@ FALSE $obj
+# regular object with "" overload
+@ $obj $str_obj
+=@ \&fatal $str_obj
+@ \&FALSE $str_obj
+@ \&foo $str_obj
+@ sub { 1 } $str_obj
+@ sub { 0 } $str_obj
+@ %keyandmore $str_obj
+@ {"object" => 1} $str_obj
+@ @fooormore $str_obj
+@ ["object" => 1] $str_obj
+@ /object/ $str_obj
+@ qr/object/ $str_obj
+@ "object" $str_obj
+@ FALSE $str_obj
+# Those will treat the $str_obj as a string because of fallback:
+
# object (overloaded or not) ~~ Any
$obj qr/NoOverload/
$ov_obj qr/^stringified$/
- $ov_obj "stringified"
+= "$ov_obj" "stringified"
+= "$str_obj" "object"
+!= $ov_obj "stringified"
+ $str_obj "object"
+ $ov_obj 'magic'
+! $ov_obj 'not magic'
# ~~ Coderef
sub{0} sub { ref $_[0] eq "CODE" }
+{} \&fatal
@empty \&fatal
%empty \&fatal
+# sub is not special on the left
+ sub {0} qr/^CODE/
+ sub {0} sub { ref shift eq "CODE" }
# HASH ref against:
# - another hash ref
= %hash %tied_hash
%tied_hash %tied_hash
!= {"a"=>"b"} %tied_hash
+ $ov_obj %refh MINISKIP
+! "$ov_obj" %refh MINISKIP
+ [$ov_obj] %refh MINISKIP
+! ["$ov_obj"] %refh MINISKIP
+ %refh %refh MINISKIP
# - an array ref
# (since this is symmetrical, tests as well hash~~array)
["foo", "bar"] [["foo"], ["bar"]]
! ["foo", "bar"] [qr/o/, "foo"]
["foo", undef, "bar"] [qr/o/, undef, "bar"]
- ["foo", undef, "bar"] [qr/o/, "", "bar"]
+! ["foo", undef, "bar"] [qr/o/, "", "bar"]
! ["foo", "", "bar"] [qr/o/, undef, "bar"]
$deep1 $deep1
@$deep1 @$deep1
! undef [1, 2, [undef], 4]
! undef @fooormore
undef @sparse
+ undef [undef]
+! 0 [undef]
+! "" [undef]
+! undef [0]
+! undef [""]
# - nested arrays and ~~ distributivity
11 [[11]]
! 2 3
0 FALSE
3-2 TRUE
- undef 0
+! undef 0
+! (my $u) 0
# Number against string
= 2 "2"
! 2 "2bananas"
!= 2_3 "2_3" NOWARNINGS
FALSE "0"
+! undef "0"
+! undef ""
# Regex against string
"x" qr/x/
@nums { 1, '', 2, '' }
@nums { 1, '', 12, '' }
! @nums { 11, '', 12, '' }
+
+# array slices
+ @nums[0..-1] []
+ @nums[0..0] [1]
+! @nums[0..1] [0..2]
+ @nums[0..4] [1..5]
+
+! undef @nums[0..-1]
+ 1 @nums[0..0]
+ 2 @nums[0..1]
+! @nums[0..1] 2
+
+ @nums[0..1] @nums[0..1]
+
+# hash slices
+ @keyandmore{qw(not)} [undef]
+ @keyandmore{qw(key)} [0]
+
+ undef @keyandmore{qw(not)}
+ 0 @keyandmore{qw(key and more)}
+! 2 @keyandmore{qw(key and)}
+
+ @fooormore{qw(foo)} @keyandmore{qw(key)}
+ @fooormore{qw(foo or more)} @keyandmore{qw(key and more)}
+
+# UNDEF
+! 3 undef
+! 1 undef
+! [] undef
+! {} undef
+! \%::main undef
+! [1,2] undef
+! %hash undef
+! @nums undef
+! "foo" undef
+! "" undef
+! !1 undef
+! \&foo undef
+! sub { } undef
https://perl5.git.perl.org / perl5.git / blobdiff