Current File : /home/opti/optisoftcom/.cpanm/work/1544535406.20768/Class-XSAccessor-1.19/t/08hash_entersub.t
#!/usr/bin/env perl
use strict;
use warnings;
use constant {
EMPTY => [],
OPTIMIZING => [
'accessor: inside test',
'accessor: op_spare: 0',
'accessor: optimizing entersub',
],
OPTIMIZED => [
'entersub: inside optimized entersub',
'accessor: inside test',
'accessor: op_spare: 0',
'accessor: entersub has been optimized'
],
# XXX not used: not sure we want to trigger this internal error
DISABLING_NOT_DEFINED => [
'entersub: inside optimized entersub',
'entersub: disabling optimization: SV is null'
],
DISABLING_NOT_CV => [
'entersub: inside optimized entersub',
'entersub: disabling optimization: SV is not a CV'
],
DISABLING_NOT_SAME_ACCESSOR => [
'entersub: inside optimized entersub',
'entersub: disabling optimization: SV is not test'
],
DISABLED => [
'accessor: inside test',
'accessor: op_spare: 1',
'accessor: entersub optimization has been disabled'
],
};
use Class::XSAccessor {
__tests__ => [ qw(foo bar) ],
getters => [ 'quux' ],
};
BEGIN {
unless (Class::XSAccessor::__entersub_optimized__()) {
print "1..0 # Skip entersub optimization not enabled", $/;
exit;
}
}
use Data::Dumper;
use Test::More tests => 68;
our @MESSAGES = ();
sub is_debug ($) {
my $want = shift;
# report errors with the caller's line number
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $got = [ splice @MESSAGES ];
unless (is_deeply($got, $want)) {
local ($Data::Dumper::Terse, $Data::Dumper::Indent) = (1, 1);
print STDERR $/, 'unmatched messages: ', Dumper($got), $/;
}
}
local $SIG{__WARN__} = sub {
my $warning = join '', @_;
if ($warning =~ m{^cxah: (.+?) at \Q$0\E}) {
push @MESSAGES, $1;
} else {
warn @_; # from perldoc -f warn: "__WARN__ hooks are not called from inside one"
}
};
sub baz {
my $self = shift;
@_ ? $self->{baz} = shift : $self->{baz};
}
# XXX debugging note: change if/else branches to separate
# statements to debug/troubleshoot, otherwise the error will appear
# to come from the first line of the if/else statement i.e. change:
#
# 1: if ($_ == 1) {
# 2: is_debug ...
# 3: } else {
# 4: is_debug ... # error
# 5: }
#
# # error at line 1
#
# to:
#
# 1: if ($_ == 1) {
# 2: is_debug ...
# 3: }
# 4:
# 5: if ($_ == 2) {
# 6: is_debug ... # error
# 7: }
#
# # error at line 5
my $SELF = bless {
foo => 'Foo',
bar => 'Bar',
baz => 'Baz',
quux => 'Quux'
};
# standard: verify that the accessors work as expected
for (1 .. 3) {
is $SELF->foo, 'Foo';
is_debug ($_ == 1 ? OPTIMIZING : OPTIMIZED);
is $SELF->bar, 'Bar';
is_debug ($_ == 1 ? OPTIMIZING : OPTIMIZED);
is $SELF->baz, 'Baz';
is_debug EMPTY;
}
# changing the CV at a call site is OK (i.e. doesn't disable
# the entersub optimization) if both CVs are the same type of
# Class::XSAccessor accessor: foo (test) -> bar (test)
for (1 .. 4) {
my $name = [ qw(foo bar foo bar) ]->[$_ - 1];
is $SELF->$name, ucfirst($name);
if ($_ == 1) {
is_debug OPTIMIZING;
} else {
is_debug OPTIMIZED;
}
}
# disable the entersub optimization (method 1):
# change it to a different type of Class::XSAccessor accessor:
# foo (test) -> quux (getter)
for (1 .. 4) {
my $name = [ qw(foo quux foo quux) ]->[$_ - 1];
is $SELF->$name, ucfirst($name);
if ($_ == 1) {
is_debug OPTIMIZING;
} elsif ($_ == 2) {
is_debug DISABLING_NOT_SAME_ACCESSOR;
} elsif ($_ == 3) {
is_debug DISABLED;
} else {
is_debug EMPTY;
}
}
# disable the entersub optimization (method 2):
# change it to a non-Class::XSAccessor CV: foo (test) -> baz
for (1 .. 4) {
my $name = [ qw(foo baz foo baz) ]->[$_ - 1];
is $SELF->$name, ucfirst($name);
if ($_ == 1) {
is_debug OPTIMIZING;
} elsif ($_ == 2) {
is_debug DISABLING_NOT_SAME_ACCESSOR;
} elsif ($_ == 3) {
is_debug DISABLED;
} else {
is_debug EMPTY;
}
}
# if the SV passed to entersub is not a CV, disable the optimisation.
# note: the invalid type is detected in the optimised entersub,
# *not* in the accessor.
for (1 .. 4) {
# when entersub is called in this way, the SV is a GV
# rather than a CV
is foo($SELF), 'Foo';
if ($_ == 1) {
# in the accessor (test)
is_debug OPTIMIZING;
} elsif ($_ == 2) {
# the optimized entersub backs itself out
# because the SV is a GV rather than a CV
is_debug [ @{DISABLING_NOT_CV()}, @{DISABLED()} ];
} else {
# in the accessor (test)
is_debug DISABLED;
}
}
# confirm we haven't pessimized other call sites
for (1 .. 3) {
is $SELF->foo, 'Foo';
is_debug ($_ == 1 ? OPTIMIZING : OPTIMIZED);
is $SELF->bar, 'Bar';
is_debug ($_ == 1 ? OPTIMIZING : OPTIMIZED);
is $SELF->baz, 'Baz';
is_debug EMPTY;
}
Mini Shell