package overload;

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;
  bless $_[0], overload::Fake;	# Non-overloaded package
  my $str = "$_[0]";
  bless $_[0], $package;	# Back
  $package . substr $str, index $str, '=';
}

sub StrVal {
  (OverloadedStringify($_[0])) ?
    (AddrRef(shift)) :
    "$_[0]";
}

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, 
	      'float'	  =>  0x2000,
	      'binary'	  =>  0x4000,
	      'q'	  =>  0x8000,
	      'qr'	  => 0x10000,
	     );

%ops = ( with_assign	  => "+ - * / % ** << >> x .",
	 assign		  => "+= -= *= /= %= **= <<= >>= x= .=",
	 str_comparison	  => "< <= >  >= == !=",
	 '3way_comparison'=> "<=> cmp",
	 num_comparison	  => "lt le gt ge eq ne",
	 binary		  => "& | ^",
	 unary		  => "neg ! ~",
	 mutators	  => '++ --',
	 func		  => "atan2 cos sin exp abs log sqrt",
	 conversion	  => 'bool "" 0+',
	 special	  => 'nomethod fallback =');

sub constant {
  # Arguments: what, sub
  while (@_) {
    $^H{$_[0]} = $_[1];
    $^H |= $constants{$_[0]} | 0x20000;
    shift, shift;
  }
}

sub remove_constant {
  # Arguments: what, sub
  while (@_) {
    delete $^H{$_[0]};
    $^H &= ~ $constants{$_[0]};
    shift, shift;
  }
}

1;