Edit: /usr/share/perl5/overload.pm (48050B)
package overload;
our $VERSION = '1.07';
sub nil {}
sub OVERLOAD {
$package = shift;
my %arg = @_;
my ($sub, $fb);
$ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
*{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
for (keys %arg) {
if ($_ eq 'fallback') {
$fb = $arg{$_};
} else {
$sub = $arg{$_};
if (not ref $sub and $sub !~ /::/) {
$ {$package . "::(" . $_} = $sub;
$sub = \&nil;
}
#print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
*{$package . "::(" . $_} = \&{ $sub };
}
}
${$package . "::()"} = $fb; # Make it findable too (fallback only).
}
sub import {
$package = (caller())[0];
# *{$package . "::OVERLOAD"} = \&OVERLOAD;
shift;
$package->overload::OVERLOAD(@_);
}
sub unimport {
$package = (caller())[0];
${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
shift;
for (@_) {
if ($_ eq 'fallback') {
undef $ {$package . "::()"};
} else {
delete $ {$package . "::"}{"(" . $_};
}
}
}
sub Overloaded {
my $package = shift;
$package = ref $package if ref $package;
$package->can('()');
}
sub ov_method {
my $globref = shift;
return undef unless $globref;
my $sub = \&{*$globref};
return $sub if $sub ne \&nil;
return shift->can($ {*$globref});
}
sub OverloadedStringify {
my $package = shift;
$package = ref $package if ref $package;
#$package->can('(""')
ov_method mycan($package, '(""'), $package
or ov_method mycan($package, '(0+'), $package
or ov_method mycan($package, '(bool'), $package
or ov_method mycan($package, '(nomethod'), $package;
}
sub Method {
my $package = shift;
if(ref $package) {
local $@;
local $!;
require Scalar::Util;
$package = Scalar::Util::blessed($package);
return undef if !defined $package;
}
#my $meth = $package->can('(' . shift);
ov_method mycan($package, '(' . shift), $package;
#return $meth if $meth ne \&nil;
#return $ {*{$meth}};
}
sub AddrRef {
my $package = ref $_[0];
return "$_[0]" unless $package;
local $@;
local $!;
require Scalar::Util;
my $class = Scalar::Util::blessed($_[0]);
my $class_prefix = defined($class) ? "$class=" : "";
my $type = Scalar::Util::reftype($_[0]);
my $addr = Scalar::Util::refaddr($_[0]);
return sprintf("$class_prefix$type(0x%x)", $addr);
}
*StrVal = *AddrRef;
sub mycan { # Real can would leave stubs.
my ($package, $meth) = @_;
my $mro = mro::get_linear_isa($package);
foreach my $p (@$mro) {
my $fqmeth = $p . q{::} . $meth;
return \*{$fqmeth} if defined &{$fqmeth};
}
return undef;
}
%constants = (
'integer' => 0x1000, # HINT_NEW_INTEGER
'float' => 0x2000, # HINT_NEW_FLOAT
'binary' => 0x4000, # HINT_NEW_BINARY
'q' => 0x8000, # HINT_NEW_STRING
'qr' => 0x10000, # HINT_NEW_RE
);
%ops = ( with_assign => "+ - * / % ** << >> x .",
assign => "+= -= *= /= %= **= <<= >>= x= .=",
num_comparison => "< <= > >= == !=",
'3way_comparison'=> "<=> cmp",
str_comparison => "lt le gt ge eq ne",
binary => '& &= | |= ^ ^=',
unary => "neg ! ~",
mutators => '++ --',
func => "atan2 cos sin exp abs log sqrt int",
conversion => 'bool "" 0+',
iterators => '<>',
dereferencing => '${} @{} %{} &{} *{}',
matching => '~~',
special => 'nomethod fallback =');
use warnings::register;
sub constant {
# Arguments: what, sub
while (@_) {
if (@_ == 1) {
warnings::warnif ("Odd number of arguments for overload::constant");
last;
}
elsif (!exists $constants {$_ [0]}) {
warnings::warnif ("`$_[0]' is not an overloadable type");
}
elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) {
# Can't use C
[ above as code references can be
# blessed, and C][ would return the package the ref is blessed into.
if (warnings::enabled) {
$_ [1] = "undef" unless defined $_ [1];
warnings::warn ("`$_[1]' is not a code reference");
}
}
else {
$^H{$_[0]} = $_[1];
$^H |= $constants{$_[0]};
}
shift, shift;
}
}
sub remove_constant {
# Arguments: what, sub
while (@_) {
delete $^H{$_[0]};
$^H &= ~ $constants{$_[0]};
shift, shift;
}
}
1;
__END__
=head1 NAME
overload - Package for overloading Perl operations
=head1 SYNOPSIS
package SomeThing;
use overload
'+' => \&myadd,
'-' => \&mysub;
# etc
...
package main;
$a = SomeThing->new( 57 );
$b=5+$a;
...
if (overload::Overloaded $b) {...}
...
$strval = overload::StrVal $b;
=head1 DESCRIPTION
This pragma allows overloading of Perl's operators for a class.
To overload built-in functions, see L instead.
=head2 Declaration of overloaded functions
The compilation directive
package Number;
use overload
"+" => \&add,
"*=" => "muas";
declares function Number::add() for addition, and method muas() in
the "class" C (or one of its base classes)
for the assignment form C<*=> of multiplication.
Arguments of this directive come in (key, value) pairs. Legal values
are values legal inside a C<&{ ... }> call, so the name of a
subroutine, a reference to a subroutine, or an anonymous subroutine
will all work. Note that values specified as strings are
interpreted as methods, not subroutines. Legal keys are listed below.
The subroutine C will be called to execute C<$a+$b> if $a
is a reference to an object blessed into the package C, or if $a is
not an object from a package with defined mathemagic addition, but $b is a
reference to a C. It can also be called in other situations, like
C<$a+=7>, or C<$a++>. See L. (Mathemagical
methods refer to methods triggered by an overloaded mathematical
operator.)
Since overloading respects inheritance via the @ISA hierarchy, the
above declaration would also trigger overloading of C<+> and C<*=> in
all the packages which inherit from C.
=head2 Calling Conventions for Binary Operations
The functions specified in the C]