#!/usr/bin/perl

use strict;
use warnings;

use Carp 'confess';
#use Hash::Util 'lock_keys', 'unlock_keys';
use Scalar::Util 'blessed';
#use Data::Dumper ();

our $DISPATCH_TRACE = 0;

{   ## Opaque instances     
    # These functions build opaque instance
    # variables and access their internal data.
    # This is basically the implementation of
    # the p6opaque candidate as described in A12 
    
    # Every instance should have a unique ID
    my $GLOBAL_INSTANCE_COUNT = 0;

    # Input: reference to class and a slurpy attr hash
    sub ::create_opaque_instance {
        my ($class, %attrs) = @_;
        bless [
            ++$GLOBAL_INSTANCE_COUNT, # 'id'    => 
            $class,                   # 'class' => 
            \%attrs,                  # 'attrs' => 
        ], 'Dispatchable';
    }

    # Accessors for the inside of the opaque structure
    sub ::opaque_instance_id { 
        $_[0]->[0];
    }
    sub ::opaque_instance_class {  
        ${$_[0]->[1]};
    }
    sub ::opaque_instance_attr : lvalue { 
        $_[0]->[2]->{$_[1]};
    }
    
    sub ::opaque_instance_add_new_attribute {
        $_[0]->[2]->{$_[1]} = $_[2];            
    }
    
    sub ::opaque_instance_change_class {
        ${$_[0]->[1]} = $_[1]; 
    }    
}

{   ## Perl 6 Global Functions
    # This is a set of global functions
    # which implement certain global 
    # characteristics of the Perl 6 object 
    # space. 
    
    ## $?SELF, $?CLASS, $?PACKAGE and $?ROLE
    # this mimics the above magical variables    
    $::SELF    = undef;
    $::CLASS   = undef;   
    $::PACKAGE = undef;
    $::ROLE    = undef;
    # this allows us to investigate from where the
    # call came, it is used in private methods 
    $::CALLER::CLASS = undef;

    ## WALKMETH and WALKCLASS
    # these are actually two functions
    # which are detailed in A12 and are
    # called 'iterators', they basically
    # are ways to walk a dispatcher() 
    # object. They are very useful :)
    sub ::WALKMETH {
        my $dispatcher = shift;
        { ($dispatcher->() || return)->get_method(@_) || redo }       
    }
    
    sub ::WALKCLASS {      
        return $_[0]->();
    }
 
    ## Attribute Primitives
    # this is kind of a hack currently ..
    
    sub ::make_attribute ($) {
        my ($name) = @_;
        (defined $name)
            || confess "You must provide a name for the attribute";
        return bless \$name => 'Perl6::Attribute';
    }
    
    sub ::make_stub_attribute ($) {
        my ($name) = @_;
        (defined $name)
            || confess "You must provide a name for the attribute";
        return bless \$name => 'Perl6::StubAttribute';
    }     
    
    # this just initializes the instance attribute container type, in
    # perl 6 this should be done automatically
    sub ::instantiate_attribute_container ($) {       
        return [] if ${$_[0]} =~ /^@/o;
        return {} if ${$_[0]} =~ /^%/o;        
        return undef;
    }
    
    {   ## Attribute "Types"
        # these are just packages
        # so that I can 'tag' the
        # types of the attributes

        package Perl6::Attribute;

        package Perl6::StubAttribute;        
        @Perl6::StubAttribute::ISA = ('Perl6::Attribute');    
    }  
    
    # a convenience wrapper for binding/unbinding $?PACKAGE
    sub ::wrap_package_sub {
        my ($sub, $pkg) = @_;
        return sub {
            local $::PACKAGE = $pkg;
            return $sub->(@_);       
        };
    }         
 
    ## Method primitives
    # since Perl 5 does not have method
    # primitives, we have to make them.
    
    # a convenience wrapper for binding/unbinding $?ROLE
    sub ::wrap_role_method {
        my ($method, $role) = @_;
        (defined $method && blessed($method) && $method->isa('Perl6::Method'))
            || confess "You can only wrap proper methods for Roles";
        return bless sub {
            local $::ROLE = $role;
            return $method->(@_);       
        # NOTE:
        # we bless the new wrapper method 
        # into the same class as before 
        # because this operation should be 
        # fairly transparent to anything 
        # outside of the Role.
        } => blessed($method);
    }      
    
    # This sub basically takes a subroutine
    # and wraps it so that it binds values 
    # to $?SELF and $?CLASS are bound within
    # it.    
    sub ::bind_method_to_class ($$) {
        my ($method, $associated_with) = @_;
        (defined $method && blessed($method) && $method->isa('Perl6::Method'))
            || confess "Bad method (" . ($method || 'undef') . ")";
        (blessed($associated_with) && blessed($associated_with) eq 'Dispatchable')
            || confess "You must associate the method with a class";          
        # now wrap the method once again, 
        # making sure to rebless it
        $_[0] = bless sub {
            # bind the previous value of $?CLASS
            local $::CALLER::CLASS = $::CLASS;
            # get all the others
            local $::SELF  = $_[0];
            local $::CLASS = local $::PACKAGE = $associated_with;
            # and call the method ...
            $method->(@_);
        } => blessed($method);            
    }

    # make a basic method ...
    sub ::make_method ($) {
        my ($method) = @_;
        # this accounts for a strange optimization in Perl 5
        # it seems that sometimes when a sub being returned
        # from another sub has the same opcodes (a constant
        # subroutine basically), Perl 5 will optimze it and
        # return the exact same sub. This results in this
        # method being passed an already blessed method 
        # instead of a plain CODE ref. This solution is also
        # duplicated in the other ::make_*_method subs below
        return $method if blessed($method) && $method->isa('Perl6::Method');
        (defined $method && ref($method) eq 'CODE')
            || confess "Bad method body (" . ($method || 'undef') . ")";     
        return bless $method => 'Perl6::Method';
    }
    
    # make a method stub
    sub ::make_stub_method () {
        return bless sub { confess "Stub Method!" } => 'Perl6::StubMethod';
    }    
    
    # a class method is the same as a regular 
    # method, it just has a class as an invocant
    sub ::make_class_method ($) {  
        my ($method) = @_;
        return $method if blessed($method) && $method->isa('Perl6::ClassMethod');        
        (defined $method && ref($method) eq 'CODE')
            || confess "Bad method body (" . ($method || 'undef') . ")";          
        return bless $method => 'Perl6::ClassMethod';
    } 
    
    # this is a private method
    sub ::make_private_method ($) {
        my ($method) = @_;
        return $method if blessed($method) && $method->isa('Private::Method');        
        (defined $method && ref($method) eq 'CODE')
            || confess "Bad method body (" . ($method || 'undef') . ")"; 
        # then the private method wrapper is wrapped
        # around the basic method body. This checks
        # to see the $?CLASS of the previous call
        # and know if we are being called from within
        # our own class or not.
        return bless sub {
            (defined $::CALLER::CLASS                    && 
             $::CALLER::CLASS->[0] == $::CLASS->[0]      ||    # for instance methods
             $::CALLER::CLASS->[0] == ${$::CLASS->[1]}->[0])   # for EigenClass methods
                || confess "Cannot call private method from different class";   
            return $method->(@_);
        } => 'Perl6::PrivateMethod';
    }
    
    # a submethod is a method which has an 
    # implicit:
    #    next METHOD unless $?SELF.class =:= $?CLASS
    # in it. Submethods are also special in that
    # this implicit test can be overridden.
    sub ::make_submethod ($) {
        my ($method) = @_;
        return $method if blessed($method) && $method->isa('Perl6::Submethod');        
        (defined $method && ref($method) eq 'CODE')
            || confess "Bad method body (" . ($method || 'undef') . ")";     
        return bless sub {
            return ::next_METHOD()
                if ((!$_[0] || $_[0] ne $Perl6::Submethod::FORCE) 
                     &&
                     ${$_[0]->[1]}->[0] 
                     != 
                     $::CLASS->[0]); 
            # if it is a FORCE ....
            shift(@_) if $_[0] eq $Perl6::Submethod::FORCE;
            # XXX -
            # this is currently a hack to rebind the 
            # $?SELF variable, it is needed until we 
            # can properly handle the forcing of method
            # calls without the use of the FORCE 
            # parameter
            local $::SELF = $_[0];
            return $method->(@_);            
        } => 'Perl6::Submethod';
    }   
    
    {   ## Method "Types"
        # these are just packages
        # so that I can 'tag' the
        # types of the methods
        
        package Perl6::Method;
        
        package Perl6::StubMethod;
        @Perl6::StubMethod::ISA = ('Perl6::Method');                

        package Perl6::ClassMethod;        
        @Perl6::ClassMethod::ISA = ('Perl6::Method');
        
        package Perl6::PrivateMethod;        
        @Perl6::PrivateMethod::ISA = ('Perl6::Method');        
        
        package Perl6::Submethod;
        @Perl6::Submethod::ISA   = ('Perl6::Method');
        $Perl6::Submethod::FORCE = bless \(my $var) => 'FORCE';
    }       
}

{
    
    ## dispatcher
    # the Perl 6 method dispatcher needs to
    # have some basic abilities, one of which 
    # is to be able to stash the current dispatcher
    # for use by 'next METHOD', the other of which 
    # is to deal with the special case of the
    # early $::Class object.

    sub ::dispatcher {
        return _class_dispatch(@_)->($_[0], @{$_[2]}) if $_[0] == $::Class;
        return _normal_dispatch(@_);
    }

    # this will handle all dispatching 
    # for the root $::Class
    my %_class_dispatch_cache;
    sub _class_dispatch { 
        # memoize the method lookup ...
        return $_class_dispatch_cache{$_[1]} 
            if exists $_class_dispatch_cache{$_[1]};
            
        my $method_table_name = '%:methods';
        # check the private methods
        $method_table_name = '%:private_methods' if $_[1] =~ /^_/o;

        # gather all the classes to look through
        my @classes = ($_[0]);
        push @classes => ((scalar @{$_[0]->[2]->{'@:MRO'}}) ? @{$_[0]->[2]->{'@:MRO'}} : @{$_[0]->[2]->{'@:superclasses'}})
            # however, we dont actually need to go there
            # if what we are asking for is a private method
            if $method_table_name ne '%:private_methods';

        # now try and find out method ...
        foreach my $class (@classes) {
            my $method_table = $class->[2]->{$method_table_name};
            return ($_class_dispatch_cache{$_[1]} = $method_table->{$_[1]}) 
                if exists $method_table->{$_[1]};             
        }
        confess "Method ($_[1]) not found in \$::Class";          
    }

    # we use this to store the 
    # memoized method lookup :)
    my %_normal_dispatch_cache;
    sub _normal_dispatch {                    
        my $class = ${$_[0]->[1]};
        # XXX - 
        # this seems to prevent some GC issues,.. 
        # so I am leaving it here for now
        #warn "got an undef class here ... ($self)" 
        return unless defined $class;  
            
        my %opts;
                
        local $::ARGS = [ $_[1], \%opts, $_[0], $_[2] ];          

        return $_normal_dispatch_cache{$class}->{ $_[1] }->[0]->($_[0], @{$_[2]}) 
            if exists $_normal_dispatch_cache{$class}->{ $_[1] };        
        
        # check if this is a private method
        if ($_[1] =~ /^_/) {           
            my $method =  $::CLASS->get_method($_[1], for => 'private')          # for instance methods
                       || $::CLASS->class->get_method($_[1], for => 'private')   # for eigenclass methods
                       || confess "Private Method ($_[1]) not found for current class ($::CLASS)";
            $_normal_dispatch_cache{$::CLASS} = { $_[1] => [ $method, undef ] };
            return $method->($_[0], @{$_[2]});  
        }
        else {   
             
            # get the dispatcher instance ....
            my $dispatcher = $class->dispatcher(':canonical');  
            # walk the methods
            my $method = ::WALKMETH($dispatcher, $_[1], %opts);
                 
            unless (defined $method) {
                # if we find an AUTOLOAD anywhere in the chain, then we can use it ...
                $class->STORE('$AUTOLOAD' => $_[1]) 
                    if $method = ::WALKMETH($class->dispatcher(':canonical'), 'AUTOLOAD', %opts);
            }            
            
            (defined $method)
                || confess "Method ($_[1]) not found for " . ($opts{for} || 'instance') . " ($_[0])";   

            $_normal_dispatch_cache{$class} = { $_[1] => [ $method, $dispatcher->(1) ] };
            return $method->($_[0], @{$_[2]});     
        }        
    }

    ## next METHOD;
    # this mimics the 'next METHOD' 
    # construct to go to the next
    # applicable method it is localized
    # in each run of _normal_dispatch
    # so that 
    sub ::next_METHOD () {
        my $dispatcher;
        if ($::DISPATCHER) {
           $dispatcher = $::DISPATCHER; 
        }
        else {
                                                          # class-id               # label         # dispacther-depth
            my $dispatcher_depth = $_normal_dispatch_cache{${$::ARGS->[2]->[1]}}->{$::ARGS->[0]}->[1];
                            # class
            $dispatcher = ${$::ARGS->[2]->[1]}->dispatcher(':canonical');
            $dispatcher->() while $dispatcher_depth--;
        }
        local $::DISPATCHER = $dispatcher;
        my $method = ::WALKMETH($dispatcher, $::ARGS->[0], %{$::ARGS->[1]}); 
        confess "No next-method for $::ARGS->[0] found" unless defined $method;
        return $method->($::ARGS->[2], @{$::ARGS->[3]});         
    }

}

###############################################################################
## Perl 5 magic sugar down here ...

{ ## Perl 5 dispatcher magic
    package Dispatchable;
    
    use strict;
    use warnings;
    
    use overload 
        '0+' => sub { $_[0]->[0] },       
        '""' => sub {
            "#<" . (exists ${$_[0]->[1]}->[2]->{'$:name'} ?
                        (${$_[0]->[1]}->[2]->{'$:name'} || 'AnonClass')
                        : 
                        'AnonClass') . "=(" . $_[0]->[0] . ")>"
        }, 
        fallback => 1;

    sub isa { our $AUTOLOAD = 'isa'; goto &AUTOLOAD; }
    sub can { our $AUTOLOAD = 'can'; goto &AUTOLOAD; }

    sub AUTOLOAD {
        my @autoload = (split '::', our $AUTOLOAD);
        my $label = $autoload[-1];
        #my $self = shift;   
        # NOTE:
        # DESTROYALL is what should really be called
        # so we just deal with it like this, and we deal
        # with it here since this is a p5 issue.
        if ($label =~ /DESTROY/) {
            # this is to avoid GC errors during global destruction
            # I am not 100% sure it will work 100% of the time
            return if $::IN_GLOBAL_DESTRUCTION || !defined($::Class);            
            $label = 'DESTROYALL';
        }        
        # go about our dispatching ....      
        return ::dispatcher(shift, $label, \@_);
    }
}

## add on to Class::Multimethods::Pure 
## to make method composition easier

{
    use Class::Multimethods::Pure ();
    
    sub ::multi_sub {
        my $wrapper;
        my $registry; 
        $registry = {
            # maybe we should start our own multi registry to handle scoping
            multi => \%Class::Multimethods::Pure::MULTI,
            multiparam => \%Class::Multimethods::Pure::MULTIPARAM,
            install_wrapper => sub { 
                my (undef, $_name) = @_;
                $wrapper = $registry->{multi}->{$_name};
            },
        };

        my $name = shift;
        Class::Multimethods::Pure::process_multi($registry,
            $name, -core => 'DumbCache', @_);

        return sub {
            my $call = $wrapper->can('call');
            unshift @_, $wrapper;
            goto &$call;
        };
    }    
}

# NOTE:
# this *might* work correctly, it should
# collect all the classes, then call DESTROY
# on all them, then set a flag to tell the
# dispatcher to ignore any futher DESTROY calls
$::IN_GLOBAL_DESTRUCTION = 0;
END {
    $::IN_GLOBAL_DESTRUCTION = 1;
    if (defined $::Class && defined $::Object) {
        my @classes;
        my %seen;
        my $traversal;
        $traversal = sub {
            foreach my $subclass (@{$_[0]->subclasses}) {
                unless (exists $seen{$subclass}) {
                    $seen{$subclass} = undef;
                    push @classes => $subclass;
                    $traversal->($subclass);
                }
            }
        };
        $traversal->($::Object);
        # now destroy them... destroy then ALL .... muhahahahaha
        $_->DESTROYALL() foreach ((reverse @classes), $::Object);
        $::IN_GLOBAL_DESTRUCTION = 1;
    }
}

1;

__END__

=pod

=head1 NAME

chaos

=head1 DESCRIPTION

=head1 AUTHORS

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=cut