package Pony::Object;

# "You will never find a more wretched hive of scum and villainy.
#  We must be careful."

use feature ':5.10';
use Storable qw/dclone/;
use Module::Load;
use Carp qw(confess);
use Scalar::Util qw(refaddr);

use constant DEBUG => 0;

BEGIN
    {
        if ( DEBUG )
        {
            say STDERR "\n[!] Pony::Object DEBUGing mode is turning on!\n";
            
            *{dumper} = sub
                {
                    use Data::Dumper;
                    $Data::Dumper::Indent = 1;
                    Dumper(@_);
                }
        }
    }

our $VERSION = 0.05;


# This function will runs on each use of this module.
# It changes caller - adds new keywords,
#   makes caller more strict and modern,
#   create from simple package almost normal class.
# Also it provides some useful methods.
#
# Don't forget: it's still OOP with blessed refs,
# but now it looks better - more sugar for your code.

sub import
    {
        my $this = shift;
        my $call = caller;
        
        # Modify caller just once.
        # We suppose, that only we can create function ALL.
        
        return if defined *{$call.'::ALL'};
        
        # Keywords, base methods, attributes.
        predefine( $call );
        
        # Pony objects must be strict and modern.
        strict  ->import;
        warnings->import;
        feature ->import(':5.10');
        
        # Base classes and params.
        parseParams($call, "${call}::ISA", @_);
        
        methodsInheritance($call);
        propertiesInheritance($call);
        
        *{$call.'::new'} = sub { importNew($call, @_) };
    }


# Constructor for Pony::Objects.
# @param string - caller package.

sub importNew
    {
        my $call = shift;
        
        if ( $call->META->{isAbstract} )
        {
            confess "Trying to use an abstract class $call";
        }
        else
        {
            $call->AFTER_LOAD_CHECK;
        }
        
        # For singletons.
        return ${$call.'::instance'} if defined ${$call.'::instance'};
        
        my $this = shift;
        
        my $obj = dclone { %{${this}.'::ALL'} };
        $this = bless $obj, $this;
        
        ${$call.'::instance'} = $this if $call->META->{isSingleton};
        
        # 'After' for user.
        $this->init(@_) if $call->can('init');
        
        return $this;
    }


# Load all base classes and read class params.
# @param string - caller package.
# @param ArrayRef - ref to @ISA.
# @param array - import params.

sub parseParams
    {
        my ( $call, $isaRef, @params ) = @_;
        
        for my $param ( @params )
        {
            given ( $param )
            {
                # Define singleton class
                # via use param.
                
                when ( /^-?singleton$/ )
                {
                    $call->META->{isSingleton} = 1;
                    next;
                }
                
                # Define abstract class
                # via use param.
                
                when ( /^-?abstract$/ )
                {
                    $call->META->{isAbstract} = 1;
                    next;
                }
            }
            
            load $param;
            $param->AFTER_LOAD_CHECK if $param->can('AFTER_LOAD_CHECK');
            
            push @$isaRef, $param;
        }
    }


# Predefine keywords and base methods.
# @param string - caller package.

sub predefine
    {
        my $call = shift;
        
        # Predefine ALL and META.
        
        %{$call.'::ALL' } = ();
        %{$call.'::META'} = ();
        ${$call.'::META'}{isSingleton} = 0;
        ${$call.'::META'}{isAbstract}  = 0;
        ${$call.'::META'}{abstracts}   = [];
        ${$call.'::META'}{methods}     = {};
        ${$call.'::META'}{symcache}    = {};
        ${$call.'::META'}{checked}     = 0;
        
        #====================
        # Define "keywords".
        #====================
        
        *{$call.'::has'}       = sub { addProperty ($call, @_) };
        *{$call.'::public'}    = sub { addPublic   ($call, @_) };
        *{$call.'::private'}   = sub { addPrivate  ($call, @_) };
        *{$call.'::protected'} = sub { addProtected($call, @_) };
        
        
        #=========================
        # Define special methods.
        #=========================
        
        # Getters for REFs to special variables %ALL and %META.
        
        *{$call.'::ALL'}  = sub { \%{ $call.'::ALL' } };
        *{$call.'::META'} = sub { \%{ $call.'::META'} };
        
        # This method provides deep copy
        # for Pony::Objects
        *{$call.'::clone'}  = sub { dclone shift };
        
        # Convert object's data into hash.
        # Uses ALL() to get properties' list.
        
        *{$call.'::toHash'} = sub
        {
            my $this = shift;
            my %hash = map { $_, $this->{$_} } keys %{ $this->ALL() };
              \%hash;
        };
        
        # Simple Data::Dumper wrapper.
        
        *{$call.'::dump'} = sub {
                                    use Data::Dumper;
                                    $Data::Dumper::Indent = 1;
                                    Dumper(@_);
                                };
        
        *{$call.'::AFTER_LOAD_CHECK'} = sub { checkImplenets($call) };
        
        # Save method's attributes.
        
        *{$call.'::MODIFY_CODE_ATTRIBUTES'} = sub
        {
            my ($pkg, $ref, @attrs) = @_;
            
            my $sym = findsym($call, $pkg, $ref);
            
            $call->META->{methods}->{ *{$sym}{NAME} } =
                {
                    attributes => \@attrs,
                    package => $pkg
                };
            
            for ( @attrs )
            {
                given( $_ )
                {
                    when ('Public'   ) { makePublic   ($call,$pkg,$sym,$ref) }
                    when ('Protected') { makeProtected($call,$pkg,$sym,$ref) }
                    when ('Private'  ) { makePrivate  ($call,$pkg,$sym,$ref) }
                    when ('Abstract' ) { makeAbstract ($call,$pkg,$sym,$ref) }
                }
            }
            
            return;
        };
    }

# Inheritance of methods.
# @param string - caller package.

sub methodsInheritance
    {
        my $this = shift;
        
        for my $base ( @{$this.'::ISA'} )
        {
            # All Pony-like classes.
            if ( $base->can('META') )
            {
                my $methods = $base->META->{methods};
                
                while ( my($k, $v) = each %$methods )
                {
                    $this->META->{methods}->{$k} = $v
                        unless exists $this->META->{methods}->{$k};
                }
                
                # Abstract classes.
                if ( $base->META->{isAbstract} )
                {
                    my $abstracts = $base->META->{abstracts};
                    
                    push @{ $this->META->{abstracts} }, @$abstracts;
                }
            }
        }
    }


# Check for implementing abstract methods
# in our class in non-abstract classes.
# @param string - caller package.

sub checkImplenets
    {
        my $this = shift;
        
        return if $this->META->{checked};
        $this->META->{checked} = 1;
        
        # Check: does all abstract methods implemented.
        for my $base ( @{$this.'::ISA'} )
        {
            
            if ( $base->can('META') && $base->META->{isAbstract} )
            {
                my $methods = $base->META->{abstracts};
                my @bad;
                
                # Find Abstract methods,
                # which was not implements.
                
                for my $method ( @$methods )
                {
                    # Get Abstract methods.
                    push @bad, $method
                      if grep { $_ eq 'Abstract' }
                        @{ $base->META->{methods}->{$method}->{attributes} };
                    
                    # Get abstract methods,
                    # which doesn't implement.
                    @bad = grep { !exists $this->META->{methods}->{$_} } @bad;
                }
                
                if ( @bad )
                {
                    my @messages = map
                        {"Didn't find method ${this}::$_() defined in $base."}
                            @bad;
                    
                    push @messages, "You should implement abstract methods before.\n";
                    
                    confess join("\n", @messages);
                }
            }
            
        }
    }


# Guessing access type of property.
# @param string - caller package.
# @param $attr - name of property.
# @param $value - default value of property.

sub addProperty
    {
        my ( $this, $attr, $value ) = @_;
        
        given( $attr )
        {
            when( /^__/ ) { return addPrivate(@_) }
            when( /^_/  ) { return addProtected(@_) }
            default       { return addPublic(@_) }
        }
    }


# Create public property with accessor.
# Save it in special variable ALL.
# @param string - caller package.
# @param $attr - name of property.
# @param $value - default value of property.

sub addPublic
    {
        my ( $this, $attr, $value ) = @_;
        
        # Save pair (property name => default value)
        %{ $this.'::ALL' } = ( %{ $this.'::ALL' }, $attr => $value );
        
        *{$this."::$attr"} = sub : lvalue { my $this = shift; $this->{$attr} };
    }


# Create protected property with accessor.
# Save it in special variable ALL.
# Can die on wrong access attempt.
# @param string - caller package.
# @param $attr - name of property.
# @param $value - default value of property.

sub addProtected
    {
        my ( $pkg, $attr, $value ) = @_;
        
        # Save pair (property name => default value)
        %{ $pkg.'::ALL' } = ( %{ $pkg.'::ALL' }, $attr => $value );
        
        *{$pkg."::$attr"} = sub : lvalue
        {
            my $this = shift;
            my $call = caller;
            
            confess "Protected ${pkg}::$attr called"
                unless ( $call->isa($pkg) || $pkg->isa($call) )
                    and ( $this->isa($pkg) );
            
            $this->{$attr};
        };
    }


# Create private property with accessor.
# Save it in special variable ALL.
# Can die on wrong access attempt.
# @param string - caller package.
# @param $attr - name of property.
# @param $value - default value of property.

sub addPrivate
    {
        my ( $pkg, $attr, $value ) = @_;
        
        # Save pair (property name => default value)
        %{ $pkg.'::ALL' } = ( %{ $pkg.'::ALL' }, $attr => $value );
        
        *{$pkg."::$attr"} = sub : lvalue
        {
            my $this = shift;
            my $call = caller;
            
            confess "Private ${pkg}::$attr called"
                unless $pkg->isa($call) && ref $this eq $pkg;
            
            $this->{$attr};
        };
    }

# Function's attribute.
# Uses to define, that this code can be used
# only inside this class and his childs.
# @param $pkg - name of package, where this function defined.
# @param $symbol - reference to perl symbol.
# @param $ref - reference to function's code.

sub makeProtected
    {
        my ( $this, $pkg, $symbol, $ref ) = @_;
        my $method = *{$symbol}{NAME};
        
        no warnings 'redefine';
        
        *{$symbol} = sub
        {
            my $this = $_[0];
            my $call = caller;
            
            confess "Protected ${pkg}::$method() called"
                unless ( $call->isa($pkg) || $pkg->isa($call) )
                    and ( $this->isa($pkg) );
            
            goto &$ref;
        }
    }

# Function's attribute.
# Uses to define, that this code can be used
# only inside this class. NOT for his childs.
# @param string $this - package where Pony::Object were used.
# @param string $pkg - name of package, where this function defined.
# @param ref $symbol - reference to perl symbol.
# @param coderef $ref - reference to function's code.

sub makePrivate
    {
        my ( $this, $pkg, $symbol, $ref ) = @_;
        my $method = *{$symbol}{NAME};
        
        no warnings 'redefine';
        
        *{$symbol} = sub
        {
            my $this = $_[0];
            my $call = caller;
            
            confess "Private ${pkg}::$method() called"
                unless $pkg->isa($call) && ref $this eq $pkg;
            
            goto &$ref;
        }
    }


# Function's attribute.
# Uses to define, that this code can be used public.
# @param string $this - package where Pony::Object were used.
# @param string $pkg - name of package, where this function defined.
# @param ref $symbol - reference to perl symbol.
# @param coderef ref - reference to function's code.

sub makePublic
    {
        # do nothing
    }


# Function's attribute.
# Define abstract attribute.
# It means, that it doesn't conteins realisation,
# but none abstract class, which will extends it,
# MUST implement it.
#
# @param string $this - package where Pony::Object were used.
# @param string $pkg - name of package, where this function defined.
# @param ref $symbol - reference to perl symbol.
# @param coderef $ref - reference to function's code.

sub makeAbstract
    {
        my ( $this, $pkg, $symbol, $ref ) = @_;
        my $method = *{$symbol}{NAME};
        
        # Can't define abstract method
        # in none-abstract class.
        
        confess "Abstract ${pkg}::$method() defined in non-abstract class"
            unless $this->META->{isAbstract};
        
        # Push abstract method
        # into object meta.
        push @{ $this->META->{abstracts} }, $method;
        
        # Can't call abstract method.
        #
        
        no warnings 'redefine';
        
        *{$symbol} = sub
        {
            confess "Abstract ${pkg}::$method() called";
        }
    }


# This function calls when we need to get
# properties (with thier default values)
# form classes which our class extends to our class.
# @param string - caller package.

sub propertiesInheritance
    {
        my $this = shift;
        my %classes;
        my @classes = @{ $this.'::ISA' };
        my @base;
        
        # Get all parent's properties
        while ( @classes )
        {
            my $c = pop @classes;
            next if exists $classes{$c};
            
            %classes = (%classes, $c => 1);
            
            push @base, $c;
            push @classes, @{ $c.'::ISA' };
        }
        
        for my $base ( reverse @base )
        {
            if ( $base->can('ALL') )
            {
                my $all = $base->ALL();
                
                for my $k ( keys %$all )
                {
                    unless ( exists ${$this.'::ALL'}{$k} )
                    {
                        %{ $this.'::ALL' } = ( %{ $this.'::ALL' },
                                               $k => $all->{$k} );
                    }
                }
            }
        }
    }


# Get perl symbol by ref.
# @param string - caller package.
# @param string - package, where it defines.
# @param coderef - reference to method.

sub findsym
    {
        my ( $this, $pkg, $ref ) = @_;
        my $symcache = $this->META->{symcache};
        
        return $symcache->{$pkg, $ref} if $symcache->{$pkg, $ref};
        
        my $type = 'CODE';
        
        for my $sym ( values %{$pkg."::"} )
        {
            next unless ref ( \$sym ) eq 'GLOB';
            
            return $symcache->{$pkg, $ref} = \$sym
                if *{$sym}{$type} && *{$sym}{$type} == $ref;
        }
    }

1;

__END__

=head1 NAME

Pony::Object the object system.

=head1 OVERVIEW

Pony::Object is an object system, which provides simple way to use cute objects.

=head1 SYNOPSIS

    use Pony::Object;

=head1 DESCRIPTION

When some package uses Pony::Object, it's becomes strict (and shows warnings)
and modern (can use perl 5.10 features like as C<say>). Also C<dump> function
is redefined and shows data structure. It's useful for debugging.

=head2 Specific moments

Besides new function C<dump> Pony::Object has other specific moments.

=head3 has

Keyword C<has> declares new fields.
All fields are public. You can also describe object methods via C<has>...
If you want.

    package News;
    use Pony::Object;
    
        # Fields
        has 'title';
        has text => '';
        has authors => [ qw/Alice Bob/ ];
        
        # Methods
        sub printTitle
            {
                my $this = shift;
                say $this->title;
            }

        sub printAuthors
            {
                my $this = shift;
                print @{ $this->authors };
            }
    1;

    package main;
    
    my $news = new News;
    $news->printAuthors();
    $news->title = 'Something important';
    $news->printTitle();

Pony::Object fields assigned via "=". For example: $obj->field = 'a'.

=head3 new

Pony::Object doesn't have method C<new>. In fact, of course it has. But C<new> is an
internal function, so you should not use it if you want not have additional fun.
Instead of this Pony::Object has C<init> function, where you can write the same,
what you wish write in C<new>. C<init> is after-hook for C<new>.

    package News;
    use Pony::Object;
    
        has title => undef;
        has lower => undef;
        
        sub init
            {
                my $this = shift;
                $this->title = shift;
                $this->lower = lc $this->title;
            }
    1;

    package main;
    
    my $news = new News('Big Event!');
    
    print $news->lower;

=head3 ALL

If you wanna get all default values of Pony::Object-based class
(fields, of course), you can call C<ALL> method. I don't know why you need them,
but you can do it.

    package News;
    use Pony::Object;
    
        has 'title';
        has text => '';
        has authors => [ qw/Alice Bob/ ];
        
    1;

    package main;
    
    my $news = new News;
    
    print for keys %{ $news->ALL() };

=head3 META

One more internal method. It provides access to special hash C<%META>.
You can use it for Pony::Object introspection but do not trust it. It can be
changed in next versions.

    my $news = new News;
    say dump $news->META;

=head3 toHash

Get object's data structure and return it in hash.

    package News;
    use Pony::Object;
    
        has title => 'World';
        has text => 'Hello';
        
    1;

    package main;
    
    my $news = new News;
    print $news->toHash()->{text};
    print $news->toHash()->{title};

=head3 dump

Return string which shows object current struct.

    package News;
    use Pony::Object;
    
        has title => 'World';
        has text => 'Hello';
        
    1;

    package main;
    
    my $news = new News;
    $news->text = 'Hi';
    print $news->dump();

Returns

    $VAR1 = bless( {
      'text' => 'Hi',
      'title' => 'World'
    }, 'News' );

=head3 protected, private properties

For properties you can use C<has> keyword if your variable starts with _ (for
protected) or __ (for private).

    package News;
    use Pony::Object;
    
        has text => '';
        has __authors => [ qw/Alice Bob/ ];
        
        sub getAuthorString
            {
                my $this = shift;
                return join(' ', @{ $this->__authors });
            }
        
    1;

    package main;
    
    my $news = new News;
    say $news->getAuthorString();

Or the same but with keywords C<public>, C<protected> and C<private>.

    package News;
    use Pony::Object;
    
        public text => '';
        private authors => [ qw/Alice Bob/ ];
        
        sub getAuthorString
            {
                my $this = shift;
                return join(' ', @{ $this->authors });
            }
        
    1;

    package main;
    
    my $news = new News;
    say $news->getAuthorString();

=head3 protected, private method

To define access for methods you can use attributes C<Public>, C<Private> and
C<Protected>.

    package News;
    use Pony::Object;
    
        public text => '';
        private authors => [ qw/Alice Bob/ ];
        
        sub getAuthorString : Public
            {
                return shift->joinAuthors(', ');
            }
        
        sub joinAuthors : Private
            {
                my $this = shift;
                my $delim = shift;
                
                return join( $delim, @{ $this->authors } );
            }
    1;

    package main;
    
    my $news = new News;
    say $news->getAuthorString();

=head3 Inheritance

To define base classes you should set them as params on Pony::Object use.
For example, use Pony::Object 'Base::Class';

    package FirstPonyClass;
    use Pony::Object;
    
        # properties
        has a => 'a';
        has d => 'd';
        
        # method
        has b => sub
            {
                my $this = shift;
                   $this->a = 'b';
                   
                return ( @_ ?
                            shift:
                            'b'  );
            };
        
        # traditional perl method
        sub c { 'c' }
    
    1;

    package SecondPonyClass;
    # extends FirstPonyClass
    use Pony::Object qw/FirstPonyClass/;
    
        # Redefine property.
        has d => 'dd';
        
        # Redefine method.
        has b => sub
            {
                my $this = shift;
                   $this->a = 'bb';
                   
                return ( @_ ?
                            shift:
                            'bb'  );
            };
        
        # New method.
        has e => sub {'e'};
    
    1;

=head3 Singletons

For singletons Pony::Object has simple syntax. You just should declare that
on use Pony::Object;

    package Notes;
    use Pony::Object 'singleton';
    
        has list => [];
        
        sub add
            {
                my $this = shift;
                push @{ $this->list }, @_;
            }
        
        sub flush
            {
                my $this = shift;
                $this->list = [];
            }
    
    1;

    package main;
    use Notes;
    
    my $n1 = new Notes;
    my $n2 = new Notes;
    
    $n1->add( qw/eat sleep/ );
    $n1->add( 'Meet with Mary at 8 o`clock' );
    
    $n2->flush;
    
    # Em... When I must meet Mary? 

=head3 Abstract methods and classes

You can use use abstract methods and classes in the following way:

    # Let's define simple interface for texts.
    package Text::Interface;
    use Pony::Object -abstract; # Use 'abstract' or '-abstract'
                                # params to define abstract class.
    
        sub getText : Abstract; # Use 'Abstract' attribute to
        sub setText : Abstract; # define abstract method.
    
    1;

    # Now we can define base class for texts.
    # It's abstract too but now it has some code.
    package Text::Base;
    use Pony::Object abstract => 'Text::Interface';
    
        protected text => '';
        
        sub getText : Public
            {
                my $this = shift;
                return $this->text;
            }
    
    1;

    # And in the end we can write Text class.
    package Text;
    use Pony::Object 'Text::Base';
    
        sub setText : Public
            {
                my $this = shift;
                $this->text = shift;
            }
    
    1;

    # Main file.
    package main;
    use Text;
    use Text::Base;
    
    my $text = new Text::Base;  # Raises an error!
    
    my $text = new Text;
    $text->setText('some text');
    print $text->getText();     # Returns 'some text';

Don't forget, that perl looking for function from left to right in list of
inheritance packages. You should define abstract classes in the end of
Pony::Object param list.

=head1 SEE

=over

=item Discussion

L<http://lorcode.org/thread/2338>

=item Git

L<https://github.com/h15/pony-object>

=back

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2011 - 2012, Georgy Bazhukov.

This program is free software, you can redistribute it and/or modify it under
the terms of the Artistic License version 2.0.

=cut
