<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package overload;

use strict;
no strict 'refs';

our $VERSION = '1.33';

our %ops = (
    with_assign         =&gt; "+ - * / % ** &lt;&lt; &gt;&gt; x .",
    assign              =&gt; "+= -= *= /= %= **= &lt;&lt;= &gt;&gt;= x= .=",
    num_comparison      =&gt; "&lt; &lt;= &gt;  &gt;= == !=",
    '3way_comparison'   =&gt; "&lt;=&gt; cmp",
    str_comparison      =&gt; "lt le gt ge eq ne",
    binary              =&gt; '&amp; &amp;= | |= ^ ^= &amp;. &amp;.= |. |.= ^. ^.=',
    unary               =&gt; "neg ! ~ ~.",
    mutators            =&gt; '++ --',
    func                =&gt; "atan2 cos sin exp abs log sqrt int",
    conversion          =&gt; 'bool "" 0+ qr',
    iterators           =&gt; '&lt;&gt;',
    filetest            =&gt; "-X",
    dereferencing       =&gt; '${} @{} %{} &amp;{} *{}',
    matching            =&gt; '~~',
    special             =&gt; 'nomethod fallback =',
);

my %ops_seen;
@ops_seen{ map split(/ /), values %ops } = ();

sub nil {}

sub OVERLOAD {
  my $package = shift;
  my %arg = @_;
  my $sub;
  *{$package . "::(("} = \&amp;nil; # Make it findable via fetchmethod.
  for (keys %arg) {
    if ($_ eq 'fallback') {
      for my $sym (*{$package . "::()"}) {
	*$sym = \&amp;nil; # Make it findable via fetchmethod.
	$$sym = $arg{$_};
      }
    } else {
      warnings::warnif("overload arg '$_' is invalid")
        unless exists $ops_seen{$_};
      $sub = $arg{$_};
      if (not ref $sub) {
	$ {$package . "::(" . $_} = $sub;
	$sub = \&amp;nil;
      }
      #print STDERR "Setting '$ {'package'}::\cO$_' to \\&amp;'$sub'.\n";
      *{$package . "::(" . $_} = \&amp;{ $sub };
    }
  }
}

sub import {
  my $package = (caller())[0];
  # *{$package . "::OVERLOAD"} = \&amp;OVERLOAD;
  shift;
  $package-&gt;overload::OVERLOAD(@_);
}

sub unimport {
  my $package = (caller())[0];
  shift;
  *{$package . "::(("} = \&amp;nil;
  for (@_) {
      warnings::warnif("overload arg '$_' is invalid")
        unless exists $ops_seen{$_};
      delete $ {$package . "::"}{$_ eq 'fallback' ? '()' : "(" .$_};
  }
}

sub Overloaded {
  my $package = shift;
  $package = ref $package if ref $package;
  mycan ($package, '()') || mycan ($package, '((');
}

sub ov_method {
  my $globref = shift;
  return undef unless $globref;
  my $sub = \&amp;{*$globref};
  no overloading;
  return $sub if $sub != \&amp;nil;
  return shift-&gt;can($ {*$globref});
}

sub OverloadedStringify {
  my $package = shift;
  $package = ref $package if ref $package;
  #$package-&gt;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-&gt;can('(' . shift);
  ov_method mycan($package, '(' . shift), $package;
  #return $meth if $meth ne \&amp;nil;
  #return $ {*{$meth}};
}

sub AddrRef {
  no overloading;
  "$_[0]";
}

*StrVal = *AddrRef;

sub mycan {				# Real can would leave stubs.
  my ($package, $meth) = @_;

  local $@;
  local $!;
  require mro;

  my $mro = mro::get_linear_isa($package);
  foreach my $p (@$mro) {
    my $fqmeth = $p . q{::} . $meth;
    return \*{$fqmeth} if defined &amp;{$fqmeth};
  }

  return undef;
}

my %constants = (
	      'integer'	  =&gt;  0x1000, # HINT_NEW_INTEGER
	      'float'	  =&gt;  0x2000, # HINT_NEW_FLOAT
	      'binary'	  =&gt;  0x4000, # HINT_NEW_BINARY
	      'q'	  =&gt;  0x8000, # HINT_NEW_STRING
	      'qr'	  =&gt; 0x10000, # HINT_NEW_RE
	     );

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&lt;ref $_[1] eq "CODE"&gt; above as code references can be
        # blessed, and C&lt;ref&gt; 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 &amp;= ~ $constants{$_[0]};
    shift, shift;
  }
}

1;

__END__

</pre></body></html>