#  Copyright (c) 1997-2006
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de
#
#  This program is free software; you can redistribute it and/or modify it
#  under the terms of the GNU General Public License as published by the
#  Free Software Foundation; either version 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#----------------------------------------------------------------------------
#  $Project: polymake $$Id: Overload.pm 7279 2006-03-21 14:46:19Z gawrilow $

use strict;
use namespaces;
require 'Poly/regex.pl';

package Poly::Overload::Node;

use Struct (
   [ new => '$$$' ],
   [ '$min_arg' => '#1' ],	# min and max possible number of arguments.
   [ '$max_arg' => '#2' ],	# undef => unlimited ( signature with trailing @ or keywords)
   [ '$backtrack' => '#3' ],	# another Node
   [ '$next_arg' => 'undef' ],	# skip untyped scalars which don't need checking;  undef => stop checking
   '$signature',
   '@code',			# \&sub or (label controlled) list
   '$ellipsis_code',		# \&sub with unlimited arglist
   [ '$default_args' => 'undef' ],	# to push into @_
   [ '$keywords' => 'undef' ],		# [ \%keyword_table, ... ] when signature with keywords
);

####################################################################################
sub clone {
   my ($src)=@_;
   bless [ $src->min_arg, $src->max_arg, 0, $src->next_arg, $src->signature,
	   [ @{$src->code} ],
	   $src->ellipsis_code,
	   $src->default_args,
	   $src->keywords,
	 ];
}
####################################################################################
sub demangle {
   my ($self, $n_args)=@_;
   my $sig=$self->signature;
   $sig =~ s/\@/::/g;
   if (@_==1) {
      $sig =~ s/^\.([^,]+)(?:,(.*))?$/$1($2)/;
   } elsif ($n_args > $sig =~ tr/,/,/) {
      $sig =~ s/^\.([^,]+)(?:,(.*))?$/$1($2,...)/;
   } else {
      $sig =~ s/^\.([^,]+)(?:,((?:[^,]+.*?){$n_args}).*)?$/$1($2)/;
   }
   $sig;
}
####################################################################################
sub _expand {
   my ($self, $new_min, $new_max, $new_proto_length)=@_;
   if ($new_min < $self->min_arg) {
      if (@{$self->code}) {
	 unshift @{$self->code}, (undef) x ($self->min_arg - $new_min);
      }
      $self->min_arg=$new_min;
   }

   my $limit=defined($new_proto_length) ? $new_proto_length : $self->next_arg;

   if (defined $self->max_arg) {
      if (defined $new_max) {
	 assign_min($limit, $new_max);
	 assign_max($self->max_arg, $new_max);
      } else {
	 undef $self->max_arg;
      }
   }
   return $limit;
}
####################################################################################
sub expand {
   my ($self, $new_min, $new_max, $new_proto_length, $new_code)=@_;
   my $limit=&_expand;

   if ($self->ellipsis_code  &&  $#{$self->code} < $limit-$self->min_arg) {
      croak( "ambiguous overloading for ", demangle($self) );
   }

   for (my $i=$new_min; $i<=$limit; ++$i) {
      ( $self->code->[$i-$self->min_arg] &&= croak( "ambiguous overloading for ", demangle($self, $i) )
      ) ||= $new_code;
   }

   if (defined($new_proto_length) && !defined($new_max)) {
      if ($self->ellipsis_code  ||  $#{$self->code} > $new_proto_length-$self->min_arg) {
	 croak( "ambiguous overloading for ", demangle($self) );
      }
      $self->ellipsis_code=$new_code;
   }
}
####################################################################################
sub push_code {
   my ($self, $new_code, $n)=@_;
   push @{$self->code}, ($new_code) x $n;
}
####################################################################################
sub push_ellipsis_code {
   my ($self, $new_code)=@_;
   $self->ellipsis_code=$new_code;
}
####################################################################################
sub find_backtrack {
   my ($nodesub)=@_;
   my $node_of_interest=&$nodesub;

   my $node=$node_of_interest;
   for (;;) {
      my $obj=method_owner($nodesub);
      if (my $nextnodesub=$obj->can("SUPER::" . method_name($nodesub))) {
	 my $nextnode=&$nextnodesub;
	 $node->backtrack=$nextnode;
	 last if ref($nextnode->backtrack) or !$nextnode->backtrack;
	 $node=$nextnode;
	 $nodesub=$nextnodesub;
      } else {
	 $node->backtrack=0;
	 last;
      }
   }

   $node_of_interest->backtrack;
}
####################################################################################
# Node, \(original @_) => \&target_sub | control list | undef
sub resolve {
   my ($node, $args)=@_;
   my @backtrack;
   my $n_repeated=0;
   my $n_args=@$args;

   for (;;) {
      if ($n_args-$n_repeated >= $node->min_arg) {
	 if (!defined($node->max_arg) || $n_args <= $node->max_arg) {
	    if (!defined($node->next_arg) || $node->next_arg+$n_repeated >= $n_args) {
	       if ($node->keywords) {
		  my $first_kw=$args->[$node->min_arg+$n_repeated];
		  if (ref($first_kw) && ref($first_kw) ne "HASH") {
		     goto BACKTRACK;
		  }
		  push @$args, $node->default_args ? @{$node->default_args}[ $node->min_arg .. $#{$node->default_args} ] : (),
			       process_keywords($node->keywords, splice @$args, $node->min_arg+$n_repeated);
		  return $node->ellipsis_code;
	       } elsif ($node->default_args) {
		  push @$args, @{$node->default_args}[ $n_args-$n_repeated .. $#{$node->default_args} ];
	       }
	       return $node->code->[ $n_args-$n_repeated-$node->min_arg ] || $node->ellipsis_code;
	    }

	    if (defined (my $nodesub=can_signature($args->[$node->next_arg+$n_repeated], $node->signature, $node->keywords))) {
	       $node=$nodesub->($n_repeated);
	       if (my $bt_node=$node->backtrack) {
		  push @backtrack, ref($bt_node) ? $bt_node : $nodesub;
	       }
	       next;
	    }
	 }
      }

      BACKTRACK: {
	 $node=pop @backtrack or return undef;
	 if (is_code($node)) {
	    $node=find_backtrack($node) or redo BACKTRACK;
	 }
	 if (my $bt_node=$node->backtrack) {
	    push @backtrack, $bt_node;
	 }
      }
   }
}
####################################################################################
sub complain_mismatch {
   "already defined without labels"
}
####################################################################################

package Poly::Overload::LabeledNode;

use Struct (
   [ '@ISA' => 'Poly::Overload::Node' ],
);

####################################################################################
sub dup_or_new_code {
   $_[0] ? &Poly::Preference::Label::dup_control : [ ];
}
####################################################################################
sub dup_code {
   $_[0] && &Poly::Preference::Label::dup_control;
}
####################################################################################
sub clone {
   my ($src)=@_;
   my $self=bless [ $src->min_arg, $src->max_arg, 0, $src->next_arg, $src->signature,
		    [ map { dup_code($_) } @{$src->code} ],
		    dup_code($src->ellipsis_code),
		    $src->default_args,
		    $src->keywords,
		  ];
   $self;
}
####################################################################################
sub create_controls {
   my ($list, $c, $labels)=@_;
   foreach my $label (@$labels) {
      $label->add_control($list, $c);
   }
   $list;
}
####################################################################################
sub expand {
   my ($self, $new_min, $new_max, $new_proto_length, $new_code, $labels)=@_;
   my $limit=&Poly::Overload::Node::_expand;

   if (defined($new_proto_length) && !defined($new_max)) {
      create_controls(( $self->ellipsis_code ||= [ ] ), $new_code, $labels);
      assign_max($limit, $#{$self->code}+$self->min_arg);
   }
   for (my $i=$new_min; $i<=$limit; ++$i) {
      create_controls(( $self->code->[$i-$self->min_arg] ||= dup_or_new_code($self->ellipsis_code) ),
		      $new_code, $labels);
   }
}
####################################################################################
sub push_code {
   my ($self, $new_code, $n, $labels)=@_;
   while (--$n >= 0) {
      push @{$self->code}, create_controls([ ], $new_code, $labels);
   }
}
####################################################################################
sub push_ellipsis_code {
   my ($self, $new_code, $labels)=@_;
   $self->ellipsis_code=create_controls([ ], $new_code, $labels);
}
####################################################################################
sub resolve {
   my $l=&Poly::Overload::Node::resolve;
   $l && $l->[0];
}
####################################################################################
sub complain_mismatch {
   "already defined with labels and signature"
}
####################################################################################

package Poly::Overload::Labeled;

sub new {
   bless [ ], shift;
}

sub resolve {
   $_[0]->[0];
}

sub complain_mismatch {
   "already defined without signature"
}
####################################################################################

package Poly::Overload;
use Poly::Ext;

sub parse_signature {
   (local $_, my ($pkg, $kw))=@_;
   my (@proto, $min, @defaults, @repeated);
   my $fixed=1;
   s/\s+$//;
   while (pos($_) < length($_)) {
      if (/\G\s* ; \s*/gxc) {
	 if (defined $min) {
	    croak( "invalid signature: multiple ';'" );
	 }
	 $min=@proto;
	 next;
      }
      if (/\G\s* ($type_re | \$)
	         (?: (?<!\$) \s* (\+)
		   | \s*=\s* ( $quoted_re | (?= [\(\[\{]) $balanced_re | [^\s,]+ ) )? (?:\s*,)?/gxco) {
	 my ($type, $repeated, $default_value)=($1, $2, $3);
	 if (defined $default_value) {
	    unless (defined $min) {
	       croak( "only optional arguments may have default values" );
	    }
	    $#defaults=$#proto;		# fill in 'undef's for the omitted default values
	    push @defaults, eval "package $pkg; $default_value";
	    if ($@) {
	       $@ =~ s/ at \(eval \d+.*$//;
	       croak( "invalid default value for argument ", @proto+1, ": $@" );
	    }
	 }
	 push @proto, $type;
	 push @repeated, $repeated;
	 undef $fixed if defined($repeated);
	 next;
      }
      if (/\G\s* % \s*$/gxc) {
	 if (!@$kw) {
	    croak( "missing keyword argument descriptions" );
	 }
	 foreach my $table (@$kw) {
	    if (!is_hash($table)) {
	       croak( "expected a hash with keyword descriptions, got ", ref($table) || $table );
	    }
	 }
	 $min=@proto unless defined $min;
	 if (@defaults) {
	    $#defaults=$#proto;		# fill in 'undef's for the omitted default values
	 }
	 return ($min, undef, @defaults ? \@defaults : undef, \@repeated, @proto);
      }
      if (/\G\s* \@ \s*$/gxc) {
	 $min=@proto unless defined $min;
	 return ($min, undef, @defaults ? \@defaults : undef, \@repeated, @proto);
      }
      croak( "invalid signature '$_'" );
   }
   if (@$kw) {
      croak( "missing '%' in signature" );
   }
   $min=@proto unless defined $min;
   return ($min, $fixed && scalar(@proto), @defaults ? \@defaults : undef, \@repeated, @proto);
}
####################################################################################
my %dictionary;
declare $override;

sub dict_node {
   my ($pkg, $name, $is_method, $node_type)=@_;
   my $node=$dictionary{$pkg}->{$name};
   if (defined($node)) {
      if (ref($node) ne $node_type) {
	 croak( $is_method ? "method" : "function", " $pkg\::$name ", $node->complain_mismatch );
      }
   } elsif (my ($sub, $own)=namespaces::lookup_sub($pkg,$name)) {
      if ($own) {
	 if (!$override) {
	    croak( "non-overloaded ", $is_method ? "method" : "function", " $pkg\::$name already ",
		   $own==1 ? ("imported from package ", method_owner($sub)) : ("defined") );
	 }
      } else {
	 $node=$dictionary{method_owner($sub)}
	    and
	 $node=$node->{$name}
	    and
	 $dictionary{$pkg}->{$name}=$node;
      }
   }
   return $node;
}
####################################################################################
sub _add {
   my ($caller, $labels, $name, $proto, @kw)=@_;
   my $pkg= $name =~ s/^(.*)::([^:]+)$/$2/ ? $1 : $caller;
   my $code=pop(@kw);
   my $is_method=is_method($code);
   my ($min, $max, $default_args, $repeated, @proto)=parse_signature($proto,$caller,\@kw);
   if ($is_method) {
      ++$min;
      ++$max if defined($max);
      unshift @proto, $pkg;
      unshift @$default_args, undef if $default_args;
   }
   my $node_type= $labels ? "Poly::Overload::LabeledNode" : "Poly::Overload::Node";
   my ($signature, @last_glob, $last_repeated);
   my $arg= $is_method ? 0 : -1;

   if (defined (my $node=dict_node($pkg, $name, $is_method, $node_type))) {
      ($signature)= $node->signature =~ /^([^,]+)/;
   DESCEND: {
	 while (++$arg <= $#proto  &&  $proto[$arg] eq "\$") { $signature.=",\$" }

	 if ($arg <= $#proto) {
	  EXISTING: {
	       if (defined (my $next_arg=$node->next_arg)) {
		  if ($next_arg == $arg) {
		     $node->expand($min,$max,undef,$code,$labels);
		     $min=$arg+1 if $min<=$arg;
		     my $next_node_sub=$proto[$arg]->can($signature);
		     if (defined($next_node_sub)  &&  $proto[$arg] eq method_owner($next_node_sub)) {
			# exact match - more than one function have the $arg-prefix, must descend deeper
			$signature .= ",$proto[$arg]";
			$signature =~ s/::/\@/g;
			$node=&$next_node_sub;
			redo DESCEND;
		     }

		  } elsif ($next_arg < $arg) {
		     $node->expand($min,$max,undef,$code,$labels);
		     $min=$next_arg+1 if $min<=$next_arg;
		     if (defined (my $next_node_sub=UNIVERSAL->can($node->signature))) {
			$node=&$next_node_sub;
			redo EXISTING;
		     }

		     my $uni_node=$node_type->new($min,$max,0);
		     if ($min<=$arg) {
			$uni_node->push_code($code,$arg-$min+1,$labels);
			$uni_node->default_args=$default_args;
			$min=$arg+1;
		     }
		     $uni_node->signature=$signature;
		     $uni_node->next_arg=$arg;
		     define_function("UNIVERSAL", $node->signature, sub : method { $uni_node });

		  } else { # $next_arg > $arg
		     my $uni_node=$node->clone;
		     assign_max($uni_node->min_arg, $arg+1);
		     $node->expand($min,$max,undef,$code,$labels);
		     $min=$arg+1 if $min<=$arg;
		     $node->signature=$signature;
		     $node->next_arg=$arg;
		     define_function("UNIVERSAL", $signature, sub : method { $uni_node });
		  }

	       } else {
		  # existing signature is a prefix of the new one
		  my $uni_node= (!defined($node->max_arg) || $node->max_arg > $arg)
		     && $node_type->new(max($node->min_arg, $arg+1), $node->max_arg, 0);
		  if ($uni_node) {
		     $uni_node->signature=$node->signature;
		     $node->signature=$signature;
		     $uni_node->default_args=$node->default_args;
		     push @{$uni_node->code}, splice @{$node->code}, max($arg+1-$node->min_arg, 0);
		     if (!defined($node->max_arg)) {
			$uni_node->ellipsis_code=$node->ellipsis_code;
			$node->ellipsis_code='';
		     }
		     define_function("UNIVERSAL", $signature, sub : method { $uni_node });
		  }
		  $node->next_arg=$arg;
		  $node->expand($min,$max,undef,$code,$labels);
		  if ($min<=$arg) {
		     $node->default_args=$default_args;
		     $min=$arg+1;
		  }
		  return $code if !$uni_node;
	       }

	       @last_glob=($proto[$arg], $signature);
               $last_repeated=$repeated->[$arg];
	       $signature .= ",$proto[$arg]$last_repeated";
	       $signature =~ s/::/\@/g;
	    }
	 } else {
	    for (;;) {
	       $node->expand($min,$max,$arg,$code,$labels);
	       if (defined (my $next_arg=$node->next_arg)) {
		  if (!defined($max) || $max>$next_arg) {
		     if (defined (my $next_node_sub=UNIVERSAL->can($node->signature))) {
			$min=$next_arg+1 if $min<=$next_arg;
			$node=&$next_node_sub;
			next;
		     } else {
			--$arg;
			@last_glob=("UNIVERSAL", $node->signature);
			last;
		     }
		  }
	       }
	       return $code;
	    }
	 }
      }
   } else {
      # first instance of this function
      $signature=".$pkg\@$name";
      $signature =~ s/::/\@/g;
   }

   my $min_reached=$min<=$arg;
   for (;;) {
      while (++$arg <= $#proto  &&  $proto[$arg] eq "\$"  &&  !$last_repeated  &&  ($arg<$min || !@kw)) { $signature.=",\$" }

      my $node=$node_type->new($min, $max, @last_glob && $last_glob[0] !~ /^UNIVERSAL::/);
      if ($min<=$arg) {
	 $node->default_args=$default_args;
         if (@kw) {
            $node->keywords=\@kw;
            $node->push_ellipsis_code($code, $labels);
            if ($min_reached && @last_glob) {
               my $kw_node=$node_type->new($min-1, undef, 0);
               $kw_node->signature="$last_glob[1],\$";
               $kw_node->default_args=$default_args;
               $kw_node->keywords=\@kw;
               $kw_node->push_ellipsis_code($code, $labels);
               define_function("Poly::Overload::keyword", $last_glob[1], sub : method { $kw_node });
            }
         } else {
	    $node->push_code($code,$arg-$min+1,$labels);
         }

	 $min=$arg+1;
         $min_reached=1;
      }
      $node->signature=$signature;

      if (@last_glob) {
	 define_function(@last_glob, sub : method { $node });

         if ($last_repeated) {
            my $repeat_node=$node->clone;
            $repeat_node->next_arg=$arg;
            undef $repeat_node->backtrack;
            define_function($last_glob[0], $signature, sub : method { ++$_[0]; $repeat_node });
         }

      } else {
	 $dictionary{$pkg}->{$name}=$node;
	 define_function($pkg, $name,
			 sub { &{ $node->resolve(\@_) || complain($pkg,$name,$is_method,@_) } },
			 $is_method);
	 if ($is_method  and  !UNIVERSAL::isa($pkg, "Poly::Overload::can")) {
	    no strict 'refs';
	    push @{"$pkg\::ISA"}, "Poly::Overload::can";
	 }
      }

      if ($arg > $#proto) {
         if (@kw) {
            if ($last_repeated) {
               my $kw_node=$node_type->new($node->min_arg,undef,0);
               $kw_node->signature="$signature,\$";
               $kw_node->default_args=$default_args;
               $kw_node->keywords=\@kw;
               $kw_node->push_ellipsis_code($code, $labels);
               define_function("Poly::Overload::keyword", $signature, sub : method { $kw_node });
               $node->next_arg=$arg;
            }
	 } else {
           $node->push_ellipsis_code($code,$labels) unless defined($max);
         }
	 last;
      }

      $node->next_arg=$arg;
      @last_glob=($proto[$arg] ne "\$" ? $proto[$arg] : "UNIVERSAL", $signature);
      $last_repeated=$repeated->[$arg];
      $signature .= ",$proto[$arg]$last_repeated";
      $signature =~ s/::/\@/g;
   }
   $code;
}
####################################################################################
sub complain {
   my ($pkg, $name, $is_method)=splice @_, 0, 3;
   my @args=map { ref($_) || "\$" } @_;
   if (my $leading_object=$is_method && shift @args) {
      croak( "no matching overloaded instance of $leading_object\->$name(" . join(",", @args) . ")" );
   } else {
      croak( "no matching overloaded instance of $pkg\::$name(" . join(",", @args) . ")" );
   }
}
####################################################################################
sub add {
   shift;	# get rid of own package name
   my $caller=caller;
   my $label=ref($_[0]) && shift;
   $label=[ $label ] if is_object($label);
   if (is_code($_[1])) {
      # without signature
      croak( "neither labels nor signature specified" ) unless $label;
      my ($name, $code)=@_;
      my $is_method=is_method($code);
      my $pkg= $name =~ s/^(.*)::([^:]+)$/$2/ ? $1 : $caller;
      my $node=dict_node($pkg, $name, $is_method, "Poly::Overload::Labeled");
      if (!defined($node)) {
	 $node=$dictionary{$pkg}->{$name}=new Labeled;
	 define_function($pkg, $name, sub { goto &{ $node->[0] } }, $is_method);
      }
      Poly::Overload::LabeledNode::create_controls($node, $code, $label);
   } else {
      # with signature
      my $code=_add($caller, $label, @_);
      if ($label) {
	 $_[0]=~/([^:]+)$/;
	 set_sub_name($code, $1);
	 set_prototype($code, $_[1]);
      }
   }
}
####################################################################################
sub add_global {
   shift;	# get rid of own package name
   my $caller=caller;
   my $label=ref($_[0]) && shift;
   $label=[ $label ] if is_object($label);
   my $name=$_[0];
   my $code=$_[-1];
   croak( "cannot declare a non-method '$name' as global" ) unless is_method($code);
   croak( "package $caller tries to declare method '$name' as global although it comes from different package" )
      unless method_owner($code) eq $caller;
   $code=_add($caller, undef, @_);
   $name =~ s/^.*::([^:]+)$/$1/;
   if ($label) {
      set_sub_name($code, $name);
      set_prototype($code, $_[1]);
   }
   _add("Poly::Overload::Global", $label, $name, @_[1..$#_-1], sub { $code });
}
####################################################################################
# for labeled functions returns the entire control list!
sub resolve {
   (undef, my $function)=splice @_, 0, 2;
   my $pkg= $function =~ s/^(.*)::([^:]+)$/$2/ ? $1 : caller;
   my $node;
   $node=$dictionary{$pkg}  and  $node=$node->{$function}  and  Poly::Overload::Node::resolve($node,\@_);
}
####################################################################################
sub process_keywords {
   my $tables=shift;

   # process the given arguments
   # for performance reasons we duplicate some code instead of branching in the loop

   my (@unknown, @processed_args, $table, $t);
   if (@$tables>1) {
      my $direct_table=0;
      push @processed_args, {} for 0..$#$tables;
      for (my $i=0; $i<=$#_; ++$i) {
	 my $key=$_[$i];
	 if (is_hash($key)) {
	    if ($direct_table > $#$tables) {
	       croak( "too many hash arguments" );
	    }
	    push %{$processed_args[$direct_table++]}, %$key;

	 } elsif (ref($key) || ++$i > $#_) {
	    croak( "KEYWORD => value pairs expected" );

	 } else {
	    my $known;
	    $t=0;
	    foreach $table (@$tables) {
	       if (exists $table->{$key}) {
		  $processed_args[$t]->{$key} = $_[$i];
		  $known=1;
	       }
	       ++$t;
	    }
	    push @unknown, $key unless $known;
	 }
      }

   } else {
      my $args=$processed_args[0]={ };
      $table=$tables->[0];
      for (my $i=0; $i<=$#_; ++$i) {
	 my $key=$_[$i];
	 if (is_hash($key)) {
	    @$args{ keys %$key }=values %$key;
	 } elsif (ref($key) || ++$i > $#_) {
	    croak( "KEYWORD => value pairs expected" );
	 } elsif (exists $table->{$key}) {
	    $args->{$key} = $_[$i];
	 } else {
	    push @unknown, $key;
	 }
      }
   }

   if (@unknown) {
      my %known;
      push %known, %$_ for @$tables;
      delete @known{ keys %$_ } for @processed_args;
      croak( "unknown keyword argument", (@unknown>1 && "s"), ": ", join(", ", @unknown),
	     "\nallowed keywords are: ", join(", ", sort keys %known) );
   }

   # filter the values and fill in the defaults
   $t=0;
   foreach $table (@$tables) {
      my $args=$processed_args[$t++];
      while (my ($key, $descr)=each %$table) {
	 if (exists $args->{$key}) {
	    $descr=$descr->[0] if is_ARRAY($descr);
	    $descr->($args,$key) if is_code($descr);

	 } elsif (is_ARRAY($descr)) {
	    my $default=$descr->[1];
	    if (is_code($default)) {
	       $default->($args, $key);
	    } elsif (defined($default)) {
	       $args->{$key}=$default;
	       $descr=$descr->[0];
	       $descr->($args,$key) if is_code($descr);
	    }
	 } elsif (defined($descr) && !is_code($descr)) {
	    $args->{$key}=$descr;
	 }
      }
   }

   @processed_args
}

sub Poly::enum {
   my ($default, %enum);
   foreach my $name (@_) {
      if ($name =~ /=default$/) {
	 $default=$`;
	 $enum{$`}=1;
      } else {
	 $enum{$name}=1;
      }
   }
   my $accept=sub {
      my ($self, $key)=@_;
      $enum{$self->{$key}}
         or croak( "unknown option value: $key => $self->{$key}" );
   };
   defined($default) ? [ $accept, $default ] : $accept;
}
####################################################################################

package Poly::Overload::can;

sub can {
   my $head=&UNIVERSAL::can or return undef;
   my ($method)=splice @_, 1, 1;
   my $node=$dictionary{method_owner($head)};
   ($node &&= $node->{$method}) ? $head=$node->resolve(\@_) : @_==1 ? $head : undef
}

####################################################################################

1