Sponsoring The Perl Toolchain Summit 2025: Help make this important event another success Learn more

use strict;
no warnings 'redefine';
# Handles :Automethods and foreign inheritance
sub AUTOLOAD
{
my ($GBL, @args) = @_;
push(@{$$GBL{'export'}}, 'AUTOLOAD');
$$GBL{'init'} = 1;
*Object::InsideOut::AUTOLOAD = sub
{
my $thing = $_[0];
# Extract the class and method names from the fully-qualified name
my ($class, $method) = our $AUTOLOAD =~ /(.*)::(.*)/;
# Handle superclass calls
my $super;
if ($class =~ /::SUPER$/) {
$class =~ s/::SUPER//;
$super = 1;
}
my $heritage = $$GBL{'heritage'};
my $automethods = $$GBL{'sub'}{'auto'};
# Find a something to handle the method call
my ($code_type, $code_dir, %code_refs);
foreach my $pkg (@{$$GBL{'tree'}{'bu'}{$class}}) {
# Skip self's class if SUPER
if ($super && $class eq $pkg) {
next;
}
# Check with heritage objects/classes
if (exists($$heritage{$pkg})) {
my $objects = $$heritage{$pkg}{'obj'};
my $classes = $$heritage{$pkg}{'cl'};
if (Scalar::Util::blessed($thing)) {
if (exists($$objects{$$thing})) {
# Check objects
foreach my $obj (@{$$objects{$$thing}}) {
if (my $code = $obj->can($method)) {
shift;
unshift(@_, $obj);
goto $code;
}
}
} else {
# Check classes
foreach my $pkg (keys(%{$classes})) {
if (my $code = $pkg->can($method)) {
@_ = @_; # Perl 5.8.5 bug workaround
goto $code;
}
}
}
} else {
# Check classes
foreach my $pkg (keys(%{$classes})) {
if (my $code = $pkg->can($method)) {
shift;
unshift(@_, $pkg);
goto $code;
}
}
}
}
# Check with Automethod
if (my $automethod = $$automethods{$pkg}) {
# Call the Automethod to get a code ref
local $CALLER::_ = $_;
local $_ = $method;
local $SIG{'__DIE__'} = 'OIO::trap';
if (my ($code, $ctype) = $automethod->(@_)) {
if (ref($code) ne 'CODE') {
# Delete defective automethod
delete($$automethods{$pkg});
# Not a code ref
OIO::Code->die(
'message' => ':Automethod did not return a code ref',
'Info' => "NOTICE: The defective :Automethod in package '$pkg' has been DELETED!",
'Code' => ":Automethod in package '$pkg' invoked for method '$method'");
}
if (defined($ctype)) {
my ($type, $dir) = $ctype =~ /(\w+)(?:[(]\s*(.*)\s*[)])?/;
if ($type && $type =~ /CUM/i) {
if ($code_type) {
$type = ':Cumulative';
$dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
if ($code_type ne $type || $code_dir ne $dir) {
# Mixed types
my ($pkg2) = keys(%code_refs);
OIO::Code->die(
'message' => 'Inconsistent code types returned by :Automethods',
'Info' => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)");
}
} else {
$code_type = ':Cumulative';
$code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
}
$code_refs{$pkg} = $code;
next;
}
if ($type && $type =~ /CHA/i) {
if ($code_type) {
$type = ':Chained';
$dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
if ($code_type ne $type || $code_dir ne $dir) {
# Mixed types
my ($pkg2) = keys(%code_refs);
OIO::Code->die(
'message' => 'Inconsistent code types returned by :Automethods',
'Info' => "Class '$pkg' returned type $type($dir), and class '$pkg2' returned type $code_type($code_dir)");
}
} else {
$code_type = ':Chained';
$code_dir = ($dir && $dir =~ /BOT/i) ? 'bottom up' : 'top down';
}
$code_refs{$pkg} = $code;
next;
}
# Unknown automethod code type
OIO::Code->die(
'message' => "Unknown :Automethod code type: $ctype",
'Info' => ":Automethod in package '$pkg' invoked for method '$method'");
}
if ($code_type) {
# Mixed types
my ($pkg2) = keys(%code_refs);
OIO::Code->die(
'message' => 'Inconsistent code types returned by :Automethods',
'Info' => "Class '$pkg' returned an 'execute immediately' type, and class '$pkg2' returned type $code_type($code_dir)");
}
# Just a one-shot - execute it
@_ = @_; # Perl 5.8.5 bug workaround
goto $code;
}
}
}
if ($code_type) {
my $tree = ($code_dir eq 'bottom up') ? $$GBL{'tree'}{'bu'} : $$GBL{'tree'}{'td'};
my $code = ($code_type eq ':Cumulative')
? create_CUMULATIVE($method, $tree, \%code_refs)
: create_CHAINED($method, $tree, \%code_refs);
@_ = @_; # Perl 5.8.5 bug workaround
goto $code;
}
# Failed to AUTOLOAD
my $type = ref($thing) ? 'object' : 'class';
OIO::Method->die('message' => qq/Can't locate $type method "$method" via package "$class"/);
};
# Do the original call
@_ = @args;
goto &Object::InsideOut::AUTOLOAD;
}
} # End of package's lexical scope
# Ensure correct versioning
($Object::InsideOut::VERSION == 3.34)
or die("Version mismatch\n");
# EOF