source: trunk/essentials/dev-lang/perl/lib/overload.pm

package overload;

our $VERSION = '1.04';

$overload::hint_bits = 0x20000; # HINT_LOCALIZE_HH

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;
  $package = ref $package if ref $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;

        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) = @_;
  return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
  my $p;
  foreach $p (@{$package . "::ISA"}) {
    my $out = mycan($p, $meth);
    return $out if $out;
  }
  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    => '${} @{} %{} &{} *{}',
         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[\da-f]+\)$/) {
        # Can't use C<ref $_[1] eq "CODE"> above as code references can be
        # blessed, and C<ref> 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]} | $overload::hint_bits;
    }
    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 = new SomeThing 57;
    $b=5+$a;
    ...
    if (overload::Overloaded $b) {...}
    ...
    $strval = overload::StrVal $b;

=head1 DESCRIPTION

=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<Number> (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<add> will be called to execute C<$a+$b> if $a
is a reference to an object blessed into the package C<Number>, or if $a is
not an object from a package with defined mathemagic addition, but $b is a
reference to a C<Number>.  It can also be called in other situations, like
C<$a+=7>, or C<$a++>.  See L<MAGIC AUTOGENERATION>.  (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<Number>.

=head2 Calling Conventions for Binary Operations

The functions specified in the C<use overload ...> directive are called
with three (in one particular case with four, see L<Last Resort>)
arguments.  If the corresponding operation is binary, then the first
two arguments are the two arguments of the operation.  However, due to
general object calling conventions, the first argument should always be
an object in the package, so in the situation of C<7+$a>, the
order of the arguments is interchanged.  It probably does not matter
when implementing the addition method, but whether the arguments
are reversed is vital to the subtraction method.  The method can
query this information by examining the third argument, which can take
three different values:

=over 7

=item FALSE

the order of arguments is as in the current operation.

=item TRUE

the arguments are reversed.

=item C<undef>

the current operation is an assignment variant (as in