Data::Polymorph - Yet another approach for polymorphism.

  my $poly = Data::Polymorph->new;

  ## defining external method 'freeze'

  $poly->define( 'FileHandle' => freeze => sub{
    "do{ require Symbol; bless Symbol::gensym(), '".ref($_[0])."'}"
  }  );

  $poly->define( "UNIVERSAL" => freeze => sub{
    use Data::Dumper;
    sprintf( 'do{ my %s }', Dumper $_[0]);
  });

  ## it returns `undef'
  FileHandle->can('freeze');
  UNIVERSAL->('freeze');

  ###
  ### applying defined method.
  ###

  ## returns "do{ requier Symbol; bless Symbol::gensym(), 'FileHandle'}"
  $poly->apply( FileHandle->new , 'freeze' );

    perldoc Data::Polymorph

use warnings;
use strict;

package Data::Polymorph;

use Carp;
use Scalar::Util qw( blessed looks_like_number );
use UNIVERSAL qw( isa can );

our $VERSION = '0.01';

{
  my @Template =
    (
     [ class_methods => sub{{}} ],
     [ type_methods => sub{
         return
           [
            [Undef     => sub{ !defined( $_[1] );         },{},'Any'],
            [ScalarRef => sub{ isa( $_[1], 'SCALAR' )     },{},'Ref'],
            [CodeRef   => sub{ isa( $_[1], 'CODE' )       },{},'Ref'],
            [ArrayRef  => sub{ isa( $_[1], 'ARRAY' )      },{},'Ref'],
            [HashRef   => sub{ isa( $_[1], 'HASH' )       },{},'Ref'],
            [GlobRef   => sub{ isa( $_[1], 'GLOB' )       },{},'Ref'],
            [RefRef    => sub{ isa( $_[1], 'REF' )        },{},'Ref'],
            [Ref       => sub{ ref( $_[1] ) and 1         },{},'Defined'],
            [Num       => sub{ looks_like_number( $_[1] ) },{},'Value'],
            [Glob      => sub{ isa(\$_[1],'GLOB' )        },{},'Value'],
            [Str       => sub{ isa(\$_[1],'SCALAR');      },{},'Value'],
            [Value     => sub{ 1                          },{},'Defined'],
            [Defined   => sub{ 1                          },{},'Any'],
            [Any       => sub{ 1                          },{},undef],
           ]
         }],

     [ _dic => sub{
         my $self = shift;
         return {  map{ ($_->[0] ,  $_)} @{$self->type_methods}   };
       }],

     [ runs_native     => sub{0} ],
     );

  sub{
    my ( $caller ) = caller;
    foreach (@_){
      my $field = $_;
      my $glob = do{ no strict 'refs'; \*{"${caller}::$field"} };
      *{$glob} = sub  ($;$){
        my $self = shift;
        return $self->{$field} unless @_;
        $self->{$field} = shift;
      };
    }
  }->( map { $_->[0]} @Template );

  sub new {
    my ($self, %args) = @_;
    $self = bless {} , (blessed $self) || $self;
    foreach my $spec ( @Template ){
      $self->{$spec->[0]} = $spec->[1]->($self);
    }
    $self->runs_native(1) if $args{runs_native};
    $self;
  }
}

sub type {
  my ( $self, $obj ) = @_;
  foreach my $slot ( @{$self->type_methods} ) {
    return $slot->[0] if $slot->[1]->($self, $obj) ;
  }
}

sub is_type {
  my ($self, $type) = @_;
  (exists $self->_dic->{$type}) ? 1 : 0;
}

sub super_type {
  my ($self, $type) = @_;
  confess "$type is not a type" unless $self->is_type( $type );
  ($self->_dic->{$type} || [])->[3];
}

sub class {
  my ( $self, $obj ) = @_;
  blessed( $obj ) or $self->type( $obj );
}

sub define_type_method {
  my ( $self, $class, $method , $code ) = @_;
  foreach my $slot ( @{$self->type_methods}) {
    next unless $slot->[0] eq $class;
    return $slot->[2]->{$method} = $code;
  }
  confess "unknown type: $class";
}

sub define_class_method {
  my ( $self, $class, $method , $code ) = @_;
  my $slot = ($self->class_methods->{$method} ||= []);
  my $i = 0;
  for(; $i < scalar @$slot ; $i++){
    my $klass = $slot->[$i]->[0];

    if( $klass eq $class ){
      $slot->[$i]->[1] = $code;
      return;
    }

    last if isa $class => $klass;
  }
  splice @$slot, $i, 0, [$class => $code];
}

sub define {
  my ( $self, $class, $method, $code ) = @_;
  goto ( $self->is_type( $class )
         ? \&define_type_method
         : \&define_class_method );
}

sub type_method {
  my ( $self, $type, $method ) = @_;
  confess "$type is not a type" unless $self->is_type( $type );
  while ( $type ){
    my $slot = $self->_dic->{$type};
    my $code = $slot->[2]->{$method};
    return $code if $code;
    $type = $slot->[3];
  }
  undef;
}

sub super_type_method {
  my ($self, $type, $method ) = @_;
  confess "$type is not a type" unless $self->is_type( $type );
  my $count = 0;
  for (my $slot; $type ; $type = $slot->[3] ){
    $slot = $self->_dic->{$type};
    my $code = $slot->[2]->{$method};
    next unless $code;
    return $code if $count;
    $count++;
  }
  undef;
}

sub class_method {
  my ( $self, $class, $method ) = @_;
  my $slot = ($self->class_methods->{$method} ||= []);
  foreach my $meth ( @$slot ){
    next unless isa( $class, $meth->[0] );
    return $meth->[1];
  }
}

sub super_class_method {
  my ( $self, $class, $method ) = @_;
  my $slot  = ($self->class_methods->{$method} ||= []);
  my $count = 0;
  foreach my $meth ( @$slot ){
    next unless isa( $class, $meth->[0] );
    return $meth->[1] if $count;
    $count++;
  }
}

sub method {
  my ( $self, $obj, $method ) = @_;
  my $class = blessed( $obj );
  my $type  = $self->type( $obj );
  ($class
   ? ( $self->class_method( $class, $method ) or
       $self->type_method( $type, $method ) or
       ( $self->runs_native and UNIVERSAL::can( $obj , $method ) ))
   :  $self->type_method( $type, $method ));
}

sub _native_super {

  my ( $class, $method ) = @_;
  my $glob = do{ no strict 'refs'; \*{"$class::$method"} };
  my @isa  = do{ no strict 'refs'; @{"${class}::ISA"} };

  if( *{$glob}{CODE} ){
    foreach my $parent ( @isa ){
      my $code = UNIVERSAL::can( $parent, $method );
      return $code if $code;
    }
  }
  else {
    foreach my $parent ( @isa ){
      my $code = _native_super( $parent, $method );
      return $code if $code;
    }
  }
}

sub super_method {
  my ( $self, $obj, $method ) = @_;
  my $class  = blessed( $obj );
  my $type   = $self->type( $obj );

  if ( $class ){
    my $uni = $self->class_method( UNIVERSAL => $method );
    if( $class eq 'UNIVERSAL' ) {

      return $self->type_method( $type => $method ) if $uni;

    }
    else {

      my $code = $self->super_class_method( $class, $method );
      return $code if $code;

      if( $self->runs_native ) {
        $code = _native_super( $class, $method );
        return $code if $code;
      }

      return $self->type_method( $type => $method ) if $uni;
    }
  }

  $self->super_type_method( $type => $method );
}

sub apply {
  my $self   = shift;
  my $obj    = $_[0];
  my $method = splice @_, 1, 1;
  goto (  $self->method( $obj => $method ) or
          sub{ confess sprintf( 'method "%s" is not defined in %s',
                                $method,
                                $self->class($obj)) });
}

sub super {
  my $self   = shift;
  my $obj    = $_[0];
  my $method = splice @_, 1, 1;
  goto (  $self->super_method( $obj => $method ) or
          sub{ confess sprintf( 'method "SUPER::%s" is not defined in %s',
                                $method,
                                $self->class($obj)) });
}

1; # End of Data::Polymorph

__END__