File Coverage

lib/Pony/Object.pm

Criterion	Covered	Total	%
statement	376	388	96.9
branch	103	118	87.2
condition	42	55	76.3
subroutine	54	56	96.4
pod	0	18	0.0
total	575	635	90.5

package Pony::Object {
  # "I am 100% sure that we're not completely sure"

  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;
        say Dumper(@_);
        say '=' x 79;
      }
    }
  }

  our $VERSION = "1.01";

  # Var: $DEFAULT
  #   Use it to redefine default Pony's options.
  our $DEFAULT = {
    '' => {
      'withExceptions' => 0,
      'baseClass' => [],
    }
  };

  # Function: import
  #   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'};

    # Parse parameters.
    my $default = dclone $DEFAULT;
    my $profile;

    # Get predefined params.
    for my $prefix (sort {length $b <=> length $a} keys %$DEFAULT) {
      if ($call =~ /^$prefix/) {
        my @doesnt_exist = grep {
          not exists $profile->{$_}
        } keys %{ $default->{$prefix} };

        $profile->{$_} = $default->{$prefix}->{$_} for @doesnt_exist;
        next;
      }

      last if keys %{$default->{''}} == keys %{$default->{$call}};
    }

    $profile->{isAbstract} = 0; # don't do default object abstract.
    $profile->{isSingleton} = 0; # don't do default object singleton.
    $profile = parseParams($call, $profile, @_);

    # Keywords, base methods, attributes.
    predefine($call, $profile);

    # Pony objects must be strict and modern.
    strict  ->import;
    warnings->import;
    feature ->import(':5.10');
    feature ->import('signatures') if $] >= 5.020;

    unless ($profile->{noObject}) {
      # Base classes and params.
      prepareClass($call, "${call}::ISA", $profile);

      methodsInheritance($call);
      propertiesInheritance($call);

      *{$call.'::new'} = sub { importNew($call, @_) };
    }
  }

  # Function: importNew
  #  Constructor for Pony::Objects.
  #
  # Parameters:
  #   $call - Str - caller package.
  #
  # Returns:
  #   self
  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'} };

    while (my ($k, $p) = each %{$this->META->{properties}}) {
      if (grep {$_ eq 'static'} @{$p->{access}}) {
        tie $obj->{$k}, 'Pony::Object::TieStatic',
          $call->META->{static}, $k, $call->META->{static}->{$k} || $obj->{$k};
      }
    }

    $this = bless $obj, $this;

    ${$call.'::instance'} = $this if $call->META->{isSingleton};

    # 'After hook' for user.
    $this->init(@_) if $call->can('init');
    return $this;
  }

  # Function: parseParams
  #   Load all base classes and read class params.
  #
  # Parameters:
  #   $call    - Str      - caller package.
  #   $profile - HashRef  - profile of this use.
  #   @params  - Array    - import params.
  #
  # Returns:
  #   HashRef - $profile
  sub parseParams {
    my ($call, $profile, @params) = @_;

    for my $param (@params) {

      # Define singleton class.
      if ($param =~ /^-?singleton$/) {
        $profile->{isSingleton} = 1;
        next;
      }

      # Define abstract class.
      elsif ($param =~ /^-?abstract$/) {
        $profile->{isAbstract} = 1;
        next;
      }

      # Features:

      # Use exceptions featureset.
      elsif ($param =~ /^:exceptions?$/ || $param =~ /^:try$/) {
        $profile->{withExceptions} = 1;
        next;
      }

      # Don't use exceptions featureset.
      elsif ($param =~ /^:noexceptions?$/ || $param =~ /^:notry$/) {
        $profile->{withExceptions} = 0;
        next;
      }

      # Don't create an object.
      # Just make package strict modern and add some staff.
      elsif ($param =~ /^:noobject$/) {
        $profile->{noObject} = 1;
        next;
      }

      # Base classes:

      # Save class' base classes.
      else {
        push @{$profile->{baseClass}}, $param;
      }
    }

    return $profile;
  }

  # Function: prepareClass
  #   Load all base classes and process class params.
  #
  # Parameters:
  #   $call     - Str       - caller package.
  #   $isaRef   - ArrayRef  - ref to @ISA.
  #   $profile  - HashRef   - parsed params profile.
  sub prepareClass {
    my ($call, $isaRef, $profile) = @_;

    $call->META->{isSingleton} = $profile->{isSingleton} // 0;
    $call->META->{isAbstract} = $profile->{isAbstract} // 0;

    for my $base (@{ $profile->{baseClass} }) {
      next if $call eq $base;
      load $base;
      $base->AFTER_LOAD_CHECK if $base->can('AFTER_LOAD_CHECK');
      push @$isaRef, $base;
    }
  }

  # Function: predefine
  #   Predefine keywords and base methods.
  #
  # Parameters:
  #   $call - Str - caller package.
  #   $profile - HashRef
  sub predefine {
    my ($call, $profile) = @_;

    # Only for objects.
    unless ($profile->{noObject}) {
      # Predefine ALL and META.
      %{$call.'::ALL' } = ();
      %{$call.'::META'} = ();
      ${$call.'::META'}{isSingleton}= 0;
      ${$call.'::META'}{isAbstract} = 0;
      ${$call.'::META'}{abstracts}  = [];
      ${$call.'::META'}{methods}    = {};
      ${$call.'::META'}{properties} = {};
      ${$call.'::META'}{symcache}   = {};
      ${$call.'::META'}{checked}    = 0;
      ${$call.'::META'}{static}     = {};

      # Access for properties.
      *{$call.'::has'}      = sub { addProperty ($call, @_) };
      *{$call.'::static'}   = sub { addStatic   ($call, @_) };
      *{$call.'::public'}   = sub { addPublic   ($call, @_) };
      *{$call.'::private'}  = sub { addPrivate  ($call, @_) };
      *{$call.'::protected'}= sub { addProtected($call, @_) };

      # Convert object's data into hash.
      # Uses ALL() to get properties' list.
      *{$call.'::toHash'} = *{$call.'::to_h'} = sub {
        my $this = shift;
        my %hash = map { $_, $this->{$_} } keys %{ $this->ALL() };
        return \%hash;
      };

      *{$call.'::AFTER_LOAD_CHECK'} = sub { checkImplementations($call) };

      # Save method's attributes.
      *{$call.'::MODIFY_CODE_ATTRIBUTES'} = sub {
        my ($pkg, $ref, @attrs) = @_;
        my $sym = findsym($pkg, $ref);

        $call->META->{methods}->{ *{$sym}{NAME} } = {
          attributes => \@attrs,
          package => $pkg
        };

        for my $attr (@attrs) {
          if    ($attr eq 'Public'   ) { makePublic   ($pkg, $sym, $ref) }
          elsif ($attr eq 'Protected') { makeProtected($pkg, $sym, $ref) }
          elsif ($attr eq 'Private'  ) { makePrivate  ($pkg, $sym, $ref) }
          elsif ($attr eq 'Abstract' ) { makeAbstract ($pkg, $sym, $ref) }
        }
        return;
      };

      # Getters for REFs to special variables %ALL and %META.
      *{$call.'::ALL'}  = sub { \%{ $call.'::ALL' } };
      *{$call.'::META'} = sub { \%{ $call.'::META'} };
    }

    # Try, Catch, Finally.
    # Define them if user wants.
    if ($profile->{withExceptions}) {
      *{$call.'::try'} = sub (&;@) {
        my($try, $catch, $finally) = @_;
        local $@;

        # If some one wanna to get some
        # values from try/catch/finally blocks.
        if (defined wantarray) {
          if (wantarray == 0) {
            my $ret = eval{ $try->() };
            $ret = $catch->($@) if $@ && defined $catch;
            $ret = $finally->() if defined $finally;
            return $ret;
          }
          elsif (wantarray == 1) {
            my @ret = eval{ $try->() };
            @ret = $catch->($@) if $@ && defined $catch;
            @ret = $finally->() if defined $finally;
            return @ret;
          }
        }
        else {
          eval{ $try->() };
          $catch->($@) if $@ && defined $catch;
          $finally->() if defined $finally;
        }
      };
      *{$call.'::catch'} = sub (&;@) { @_ };
      *{$call.'::finally'} = sub (&) { @_ };
    }

    # This method provides deep copy
    # for Pony::Objects
    *{$call.'::clone'}  = sub { dclone shift };

    # Simple Data::Dumper wrapper.
    *{$call.'::dump'} = sub {
      use Data::Dumper;
      $Data::Dumper::Indent = 1;
      Dumper(@_);
    };
  }

  # Function: methodsInheritance
  #   Inheritance of methods.
  #
  # Parameters:
  #   $this - Str - 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;
        }
      }
    }
  }

  # Function: checkImplementations
  #   Check for implementing abstract methods
  #   in our class in non-abstract classes.
  #
  # Parameters:
  #   $this - Str - caller package.
  sub checkImplementations {
    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);
        }
      }
    }
  }

  # Function: addProperty
  #   Guessing access type of property.
  #
  # Parameters:
  #   $this - Str - caller package.
  #   $attr - Str - name of property.
  #   $value - Mixed - default value of property.
  sub addProperty {
    my ($this, $attr, $value) = @_;

    # Properties
    if (ref $value ne 'CODE') {
      if ($attr =~ /^__/) {
        return addPrivate(@_);
      } elsif ($attr =~ /^_/) {
        return addProtected(@_);
      } else {
        return addPublic(@_);
      }
    }

    # Methods
    else {
      *{$this."::$attr"} = $value;
      my $sym = findsym($this, $value);
      my @attrs = qw/Public/;

      if ($attr =~ /^__/) {
        @attrs = qw/Private/;
        return makePrivate($this, $sym, $value);
      } elsif ($attr =~ /^_/) {
        @attrs = qw/Protected/;
        return makeProtected($this, $sym, $value);
      } else {
        return makePublic($this, $sym, $value);
      }

      $this->META->{methods}->{ *{$sym}{NAME} } = {
        attributes => \@attrs,
        package => $this
      };
    }
  }

  # Function: addStatic
  #   Add static property or make property static.
  #
  # Parameters:
  #   $call - Str - caller package.
  #   $name - Str - property's name.
  #   $value - Mixed - default value.
  #
  # Returns:
  #   $name - Str - property's name.
  #   $value - Mixed - default value.
  sub addStatic {
    my $call = shift;
    my ($name, $value) = @_;
    push @{ $call->META->{statics} }, $name;
    addPropertyToMeta('static', $call, @_);
    return @_;
  }

  # Function: addPropertyToMeta
  #   Save property's info into META
  #
  # Parameters:
  #   $access - Str - property's access type.
  #   $call - Str - caller package.
  #   $name - Str - property's name.
  #   $value - Mixed - property's default value.
  sub addPropertyToMeta {
    my $access = shift;
    my $call = shift;
    my ($name, $value) = @_;

    my $props = $call->META->{properties};

    # Delete inhieritated properties for polymorphism.
    delete $call->META->{properties}->{$name} if
      exists $call->META->{properties}->{$name} &&
      $call->META->{properties}->{$name}->{package} ne $call;

    # Create if doesn't exist
    %$props = (%$props, $name => {access => []}) if
      not exists $props->{$name} ||
      ( $props->{$name}->{package} && $props->{$name}->{package} ne $call );

    push @{$props->{$name}->{access}}, $access;
    $props->{$name}->{package} = $call;
  }

  # Function: addPublic
  #   Create public property with accessor.
  #   Save it in special variable ALL.
  #
  # Parameters:
  #   $call  - Str - caller package.
  #   $name  - Str - name of property.
  #   $value - Mixed - default value of property.
  sub addPublic {
    my $call = shift;
    my ($name, $value) = @_;
    addPropertyToMeta('public', $call, @_);

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

  # Function: addProtected
  #   Create protected property with accessor.
  #   Save it in special variable ALL.
  #   Can die on wrong access attempt.
  #
  # Parameters:
  #   $pkg  - Str - caller package.
  #   $name - Str - name of property.
  #   $value - Mixed - default value of property.
  sub addProtected {
    my $pkg = shift;
    my ($name, $value) = @_;
    addPropertyToMeta('protected', $pkg, @_);

    # Save pair (property name => default value)
    %{$pkg.'::ALL'} = (%{$pkg.'::ALL'}, $name => $value);

    *{$pkg."::$name"} = sub : lvalue {
      my $this = shift;
      my $call = caller;
      confess "Protected ${pkg}::$name called"
        unless ($call->isa($pkg) || $pkg->isa($call)) and $this->isa($pkg);
      $this->{$name};
    };
    return @_;
  }

  # Function: addPrivate
  #   Create private property with accessor.
  #   Save it in special variable ALL.
  #   Can die on wrong access attempt.
  #
  # Parameters:
  #   $pkg  - Str - caller package.
  #   $name - Str - name of property.
  #   $value - Mixed - default value of property.
  sub addPrivate {
    my $pkg = shift;
    my ($name, $value) = @_;
    addPropertyToMeta('private', $pkg, @_);

    # Save pair (property name => default value)
    %{ $pkg.'::ALL' } = ( %{ $pkg.'::ALL' }, $name => $value );

    *{$pkg."::$name"} = sub : lvalue {
      my $this = shift;
      my $call = caller;
      confess "Private ${pkg}::$name called"
        unless $pkg->isa($call) && $this->isa($pkg);
      $this->{$name};
    };
    return @_;
  }

  # Function: makeProtected
  #   Function's attribute.
  #   Uses to define, that this code can be used
  #   only inside this class and his childs.
  #
  # Parameters:
  #   $pkg - Str - name of package, where this function defined.
  #   $symbol - Symbol - reference to perl symbol.
  #   $ref - CodeRef - reference to function's code.
  sub makeProtected {
    my ($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: makePrivate
  #   Function's attribute.
  #   Uses to define, that this code can be used
  #   only inside this class. NOT for his childs.
  #
  # Parameters:
  #   $pkg - Str - name of package, where this function defined.
  #   $symbol - Symbol - reference to perl symbol.
  #   $ref - CodeRef - reference to function's code.
  sub makePrivate {
    my ($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) && $this->isa($pkg);
      goto &$ref;
    }
  }

  # Function: makePublic
  #   Function's attribute.
  #   Uses to define, that this code can be used public.
  #
  # Parameters:
  #   $pkg - Str - name of package, where this function defined.
  #   $symbol - Symbol - reference to perl symbol.
  #   $ref - CodeRef - reference to function's code.
  sub makePublic {
    # do nothing
  }

  # Function: makeAbstract
  #   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.
  #
  # Parameters:
  #   $pkg - Str - name of package, where this function defined.
  #   $symbol - Symbol - reference to perl symbol.
  #   $ref - CodeRef - reference to function's code.
  sub makeAbstract {
    my ($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 $pkg->META->{isAbstract};

    # Push abstract method
    # into object meta.
    push @{ $pkg->META->{abstracts} }, $method;

    no warnings 'redefine';

    # Can't call abstract method.
    *{$symbol} = sub { confess "Abstract ${pkg}::$method() called" };
  }

  # Function: propertiesInheritance
  #   This function calls when we need to get
  #   properties (with thier default values)
  #   form classes which our class extends to our class.
  #
  # Parameters:
  #   $this - Str - caller package.
  sub propertiesInheritance {
    my $this = shift;
    my %classes;
    my @classes = @{ $this.'::ISA' };
    my @base;
    my %props;

    # 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')) {
        # Default values
        my $all = $base->ALL();
        for my $k (keys %$all) {
          unless (exists ${$this.'::ALL'}{$k}) {
            %{$this.'::ALL'} = (%{$this.'::ALL'}, $k => $all->{$k});
          }
        }
        # Statics
        $all = $base->META->{properties};
        for my $k (keys %$all) {
          unless (exists $this->META->{properties}->{$k}) {
            %{$this->META->{properties}} = (%{$this->META->{properties}},
              $k => $base->META->{properties}->{$k});
          }
        }
      }
    }
  }

  # Function: findsym
  #   Get perl symbol by ref.
  #
  # Parameters:
  #   $pkg - Str - package, where it defines.
  #   $ref - CodeRef - reference to method.
  #
  # Returns:
  #   Symbol
  sub findsym {
    my ($pkg, $ref) = @_;
    my $symcache = $pkg->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;
    }
  }
}


###############################################################################
# Class: Pony::Object::TieStatic
#   Tie class. Use for make properties are static.
package Pony::Object::TieStatic {
  # "When you see me again, it won't be me"

  # Method: TIESCALAR
  #   tie constructor
  #
  # Parameters:
  #   $storage - HashRef - data storage
  #   $name - Str - property's name
  #   $val - Mixed - Init value
  #
  # Returns:
  #   Pony::Object::TieStatic
  sub TIESCALAR {
    my $class = shift;
    my ($storage, $name, $val) = @_;
    $storage->{$name} = $val unless exists $storage->{$name};

    bless {name => $name, storage => $storage}, $class;
  }

  # Method: FETCH
  #   Defines fetch for scalar.
  #
  # Returns:
  #   Mixed - property's value
  sub FETCH {
    my $self = shift;
    return $self->{storage}->{ $self->{name} };
  }

  # Method: STORE
  #   Defines store for scalar.
  #
  # Parameters:
  #   $val - Mixed - property's value
  sub STORE {
    my $self = shift;
    my $val = shift;
    $self->{storage}->{ $self->{name} } = $val;
  }
}

1;

__END__