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

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
C<$a+=7>), but the usual function is called instead.  This additional
information can be used to generate some optimizations.  Compare
L<Calling Conventions for Mutators>.

=back

=head2 Calling Conventions for Unary Operations

Unary operation are considered binary operations with the second
argument being C<undef>.  Thus the functions that overloads C<{"++"}>
is called with arguments C<($a,undef,'')> when $a++ is executed.

=head2 Calling Conventions for Mutators

Two types of mutators have different calling conventions:

=over

=item C<++> and C<-->

The routines which implement these operators are expected to actually
I<mutate> their arguments.  So, assuming that $obj is a reference to a
number,

  sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n}

is an appropriate implementation of overloaded C<++>.  Note that

  sub incr { ++$ {$_[0]} ; shift }

is OK if used with preincrement and with postincrement. (In the case
of postincrement a copying will be performed, see L<Copy Constructor>.)

=item C<x=> and other assignment versions

There is nothing special about these methods.  They may change the
value of their arguments, and may leave it as is.  The result is going
to be assigned to the value in the left-hand-side if different from
this value.

This allows for the same method to be used as overloaded C<+=> and
C<+>.  Note that this is I<allowed>, but not recommended, since by the
semantic of L<"Fallback"> Perl will call the method for C<+> anyway,
if C<+=> is not overloaded.

=back

B<Warning.>  Due to the presence of assignment versions of operations,
routines which may be called in assignment context may create
self-referential structures.  Currently Perl will not free self-referential
structures until cycles are C<explicitly> broken.  You may get problems
when traversing your structures too.

Say,

  use overload '+' => sub { bless [ \$_[0], \$_[1] ] };

is asking for trouble, since for code C<$obj += $foo> the subroutine
is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj,