use strict;
use warnings;

package Clownfish::Class;
use base qw( Clownfish::Symbol );
use Carp;
use Config;
use Clownfish::Function;
use Clownfish::Method;
use Clownfish::Util qw(
    verify_args
    a_isa_b
);
use Clownfish::Dumpable;
use File::Spec::Functions qw( catfile );
use Scalar::Util qw( reftype );

our %create_PARAMS = (
    source_class      => undef,
    class_name        => undef,
    cnick             => undef,
    parent_class_name => undef,
    methods           => undef,
    functions         => undef,
    member_vars       => undef,
    inert_vars        => undef,
    docucomment       => undef,
    inert             => undef,
    final             => undef,
    parcel            => undef,
    attributes        => undef,
    exposure          => 'parcel',
);

my $dumpable = Clownfish::Dumpable->new;

our %registry;

# Testing only.
sub _zap { delete $registry{ +shift } }

our %fetch_singleton_PARAMS = (
    parcel     => undef,
    class_name => undef,
);

sub fetch_singleton {
    my ( undef, %args ) = @_;
    verify_args( \%fetch_singleton_PARAMS, %args ) or confess $@;

    # Start with the class identifier.
    my $class_name = $args{class_name};
    confess("Missing required param 'class_name'") unless defined $class_name;
    $class_name =~ /(\w+)$/ or confess("Invalid class name: '$class_name'");
    my $key = $1;

    # Maybe prepend parcel prefix.
    my $parcel = $args{parcel};
    if ( defined $parcel ) {
        if ( !a_isa_b( $parcel, "Clownfish::Parcel" ) ) {
            $parcel = Clownfish::Parcel->singleton( name => $parcel );
        }
        $key = $parcel->get_prefix . $key;
    }

    return $registry{$key};
}

sub new { confess("The constructor for Clownfish::Class is create()") }

sub create {
    my ( $class_class, %args ) = @_;
    verify_args( \%create_PARAMS, %args ) or confess $@;
    $args{class_cnick} = $args{cnick};
    my $self = $class_class->SUPER::new(
        %create_PARAMS,
        micro_sym   => 'class',
        struct_sym  => undef,
        methods     => [],
        overridden  => {},
        functions   => [],
        member_vars => [],
        children    => [],
        parent      => undef,
        attributes  => {},
        autocode    => '',
        tree_grown  => 0,
        %args,
    );
    $self->{cnick} ||= $self->{class_cnick};

    # Make it possible to look up methods and functions by name.
    $self->{meth_by_name}{ $_->micro_sym } = $_ for $self->methods;
    $self->{func_by_name}{ $_->micro_sym } = $_ for $self->functions;

    # Derive struct name.
    confess("Missing required param 'class_name'") unless $self->{class_name};
    $self->{class_name} =~ /(\w+)$/;
    $self->{struct_sym} = $1;

    # Verify that members of supplied arrays meet "is a" requirements.
    for ( @{ $self->{functions} } ) {
        confess("Not a Clownfish::Function")
            unless a_isa_b( $_, 'Clownfish::Function' );
    }
    for ( @{ $self->{methods} } ) {
        confess("Not a Clownfish::Method")
            unless a_isa_b( $_, 'Clownfish::Method' );
    }
    for ( @{ $self->{member_vars} }, @{ $self->{inert_vars} } ) {
        confess("Not a Clownfish::Variable")
            unless a_isa_b( $_, 'Clownfish::Variable' );
    }

    # Assume that Foo::Bar should be found in Foo/Bar.h.
    $self->{source_class} = $self->{class_name}
        unless defined $self->{source_class};

    # Validate attributes.
    confess("Param 'attributes' not a hashref")
        unless reftype( $self->{attributes} ) eq 'HASH';

    # Store in registry.
    my $key      = $self->full_struct_sym;
    my $existing = $registry{$key};
    if ($existing) {
        confess(  "New class $self->{class_name} conflicts with previously "
                . "compiled class $existing->{class_name}" );
    }
    $registry{$key} = $self;

    # Validate inert param.
    confess("Inert classes can't have methods")
        if ( $self->{inert} and @{ $self->{methods} } );

    return $self;
}

sub file_path {
    my ( $self, $base_dir, $ext ) = @_;
    my @components = split( '::', $self->{source_class} );
    unshift @components, $base_dir
        if defined $base_dir;
    $components[-1] .= $ext;
    return catfile(@components);
}

sub include_h {
    my $self = shift;
    my @components = split( '::', $self->{source_class} );
    $components[-1] .= '.h';
    return join( '/', @components );
}

sub has_attribute { exists $_[0]->{attributes}{ $_[1] } }

sub get_cnick             { shift->{cnick} }
sub get_struct_sym        { shift->{struct_sym} }
sub get_parent_class_name { shift->{parent_class_name} }
sub get_source_class      { shift->{source_class} }
sub get_docucomment       { shift->{docucomment} }
sub get_parent            { shift->{parent} }
sub get_autocode          { shift->{autocode} }
sub inert                 { shift->{inert} }
sub final                 { shift->{final} }

sub set_parent { $_[0]->{parent} = $_[1] }

sub full_struct_sym  { $_[0]->get_prefix . $_[0]->{struct_sym} }
sub short_vtable_var { uc( shift->{struct_sym} ) }
sub full_vtable_var  { $_[0]->get_PREFIX . $_[0]->short_vtable_var }
sub full_vtable_type { shift->full_vtable_var . '_VT' }

sub append_autocode { $_[0]->{autocode} .= $_[1] }

sub functions   { @{ shift->{functions} } }
sub methods     { @{ shift->{methods} } }
sub member_vars { @{ shift->{member_vars} } }
sub inert_vars  { @{ shift->{inert_vars} } }
sub children    { @{ shift->{children} } }

sub novel_methods {
    my $self = shift;
    return
        grep { $_->get_class_cnick eq $self->{cnick} } @{ $self->{methods} };
}

sub novel_member_vars {
    my $self = shift;
    return
        grep { $_->get_class_cnick eq $self->{cnick} }
        @{ $self->{member_vars} };
}

sub function {
    my ( $self, $micro_sym ) = @_;
    return $self->{func_by_name}{ lc($micro_sym) };
}

sub method {
    my ( $self, $micro_sym ) = @_;
    return $self->{meth_by_name}{ lc($micro_sym) };
}

sub novel_method {
    my ( $self, $micro_sym ) = @_;
    my $method = $self->{meth_by_name}{ lc($micro_sym) };
    if ( defined $method
        and $method->get_class_cnick eq $self->get_class_cnick )
    {
        return $method;
    }
    else {
        return;
    }
}

sub add_child {
    my ( $self, $child ) = @_;
    confess("Can't call add_child after grow_tree") if $self->{tree_grown};
    push @{ $self->{children} }, $child;
}

sub add_method {
    my ( $self, $method ) = @_;
    confess("Not a Method") unless a_isa_b( $method, "Clownfish::Method" );
    confess("Can't call add_method after grow_tree") if $self->{tree_grown};
    confess("Can't add_method to an inert class")    if $self->{inert};
    push @{ $self->{methods} }, $method;
    $self->{meth_by_name}{ $method->micro_sym } = $method;
}

# Create dumpable functions unless hand coded versions were supplied.
sub _create_dumpables {
    my $self = shift;
    $dumpable->add_dumpables($self) if $self->has_attribute('dumpable');
}

sub grow_tree {
    my $self = shift;
    confess("Can't call grow_tree more than once") if $self->{tree_grown};
    $self->_establish_ancestry;
    $self->_bequeath_member_vars;
    $self->_generate_automethods;
    $self->_bequeath_methods;
    $self->{tree_grown} = 1;
}

# Let the children know who their parent class is.
sub _establish_ancestry {
    my $self = shift;
    for my $child ( @{ $self->{children} } ) {
        # This is a circular reference and thus a memory leak, but we don't
        # care, because we have to have everything in memory at once anyway.
        $child->{parent} = $self;
        $child->_establish_ancestry;
    }
}

# Pass down member vars to from parent to children.
sub _bequeath_member_vars {
    my $self = shift;
    for my $child ( @{ $self->{children} } ) {
        unshift @{ $child->{member_vars} }, @{ $self->{member_vars} };
        $child->_bequeath_member_vars;
    }
}

# Create auto-generated methods.  This must be called after member vars are
# passed down but before methods are passed down.
sub _generate_automethods {
    my $self = shift;
    $self->_create_dumpables;
    for my $child ( @{ $self->{children} } ) {
        $child->_generate_automethods;
    }
}

sub _bequeath_methods {
    my $self = shift;

    for my $child ( @{ $self->{children} } ) {
        # Pass down methods, with some being overridden.
        my @common_methods;    # methods which child inherits or overrides
        for my $method ( @{ $self->{methods} } ) {
            if ( exists $child->{meth_by_name}{ $method->micro_sym } ) {
                my $child_method
                    = $child->{meth_by_name}{ $method->micro_sym };
                $child_method->override($method);
                push @common_methods, $child_method;
            }
            else {
                $child->{meth_by_name}{ $method->micro_sym } = $method;
                push @common_methods, $method;
            }
        }

        # Create array of methods, preserving exact order so vtables match up.
        my @new_method_set;
        my %seen;
        for my $meth ( @common_methods, @{ $child->{methods} } ) {
            next if $seen{ $meth->micro_sym };
            $seen{ $meth->micro_sym } = 1;
            if ( $child->final ) {
                $meth = $meth->finalize if $child->final;
                $child->{meth_by_name}{ $meth->micro_sym } = $meth;
            }
            push @new_method_set, $meth;
        }
        $child->{methods} = \@new_method_set;

        # Pass it all down to the next generation.
        $child->_bequeath_methods;
        $child->{tree_grown} = 1;
    }
}

sub tree_to_ladder {
    my $self   = shift;
    my @ladder = ($self);
    for my $child ( @{ $self->{children} } ) {
        push @ladder, $child->tree_to_ladder;
    }
    return @ladder;
}

1;

__END__

__POD__

=head1 NAME

Clownfish::Class - An object representing a single class definition.

=head1 CONSTRUCTORS

Clownfish::Class objects are stored as quasi-singletons, one for each
unique parcel/class_name combination.

=head2 fetch_singleton 

    my $class = Clownfish::Class->fetch_singleton(
        parcel     => 'Crustacean',
        class_name => 'Crustacean::Lobster::LobsterClaw',
    );

Retrieve a Class, if one has already been created.

=head2 create

    my $class = Clownfish::Class->create(
        parcel     => 'Crustacean',                        # default: special
        class_name => 'Crustacean::Lobster::LobsterClaw',  # required
        cnick      => 'LobClaw',                           # default: special
        exposure   => 'public',                            # default: 'parcel'
        source_class      => undef,              # default: same as class_name
        parent_class_name => 'Crustacean::Claw', # default: undef
        inert             => undef,              # default: undef
        methods           => \@methods,          # default: []
        functions         => \@funcs,            # default: []
        member_vars       => \@members,          # default: []
        inert_vars        => \@inert_vars,       # default: []
        docucomment       => $documcom,          # default: undef,
        attributes        => \%attributes,       # default: {}
    );

Create and register a quasi-singleton.  May only be called once for each
unique parcel/class_name combination.

=over

=item * B<parcel>, B<class_name>, B<cnick>, B<exposure> - see
L<Clownfish::Symbol>.

=item * B<source_class> - The name of the class that owns the file in which
this class was declared.  Should be "Foo" if "Foo::FooJr" is defined in
C<Foo.cfh>.

=item * B<parent_class_name> - The name of this class's parent class.  Needed
in order to establish the class hierarchy.

=item * B<inert> - Should be true if the class is inert, i.e. cannot be
instantiated.

=item * B<methods> - An array where each element is a Clownfish::Method.

=item * B<functions> - An array where each element is a Clownfish::Method.

=item * B<member_vars> - An array where each element is a
Clownfish::Variable and should be a member variable in each instantiated
object.

=item * B<inert_vars> - An array where each element is a
Clownfish::Variable and should be a shared (class) variable.

=item * B<docucomment> - A Clownfish::DocuComment describing this Class.

=item * B<attributes> - An arbitrary hash of attributes.

=back

=head1 METHODS

=head2 get_cnick get_struct_sym get_parent_class_name get_source_class
get_docucomment get_parent get_autocode inert final

Accessors.

=head2 set_parent

    $class->set_parent($ancestor);

Set the parent class.

=head2 add_child

    $class->add_child($child_class);

Add a child class. 

=head2 add_method

    $class->add_method($method);

Add a Method to the class.  Valid only before grow_tree() is called.

=head2 function 

    my $do_stuff_function = $class->function("do_stuff");

Return the inert Function object for the supplied C<micro_sym>, if any.

=head2 method

    my $pinch_method = $class->method("Pinch");

Return the Method object for the supplied C<micro_sym> / C<macro_sym>, if any.

=head2 novel_method

    my $pinch_method = $class->novel_method("Pinch");

Return a Method object if the Method corresponding to the supplied string is
novel.

=head2 children 

    my @child_classes = $class->children;

Return all child classes as a list.

=head2 functions

    my @functions = $class->functions;

Return all (inert) functions as a list.

=head2 methods

    my @methods = $class->methods;

Return all methods as a list.

=head2 inert_vars

    my @inert_vars = $class->inert_vars;

Return all inert (shared, class) variables as a list.

=head2 member_vars

    my @members = $class->member_vars;

Return all member variables as a list.

=head2 novel_methods

    my @novel_methods = $class->novel_methods;

Return all novel methods as a list.

=head2 novel_member_vars

    my @new_members = $class->novel_member_vars;

Return all novel member variables as a list.

=head2 grow_tree

    $class->grow_tree;

Bequeath all inherited methods and members to children.

=head2 tree_to_ladder

    my @ordered = $class->tree_to_ladder;

Return this class and all its child classes as an array, where all children
appear after their parent nodes.

=head2 file_path

    # /path/to/Foo/Bar.c, if source class is Foo::Bar.
    my $path = $class->file_path( '/path/to', '.c' );

Provide an OS-specific path for a file relating to this class could be found,
by joining together the components of the C<source_class> name.

=head2 include_h

    my $relative_path = $class->include_h;

Return a relative path to a C header file, appropriately formatted for a
pound-include directive.

=head2 append_autocode

    $class->append_autocode($code);

Append auxiliary C code.

=head2 short_vtable_var

The short name of the global VTable object for this class.

=head2 full_vtable_var

Fully qualified vtable variable name, including the parcel prefix.

=head2 full_vtable_type

The fully qualified C type specifier for this class's vtable, including the
parcel prefix.  Each vtable needs to have its own type because each has a
variable number of methods at the end of the struct, and it's not possible to
initialize a static struct with a flexible array at the end under C89.

=head2 full_struct_sym

Fully qualified struct symbol, including the parcel prefix.

=head1 COPYRIGHT AND LICENSE

Copyright 2008-2011 Marvin Humphrey

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut
