File Coverage

blib/lib/Soo.pm

Criterion	Covered	Total	%
statement	67	70	95.7
branch	10	18	55.5
condition	5	11	45.4
subroutine	16	16	100.0
pod			n/a
total	98	115	85.2

use strict;
use warnings;

package Soo;

use Carp 'croak';

our $VERSION = '0.0.2';


my $extends = sub {
  eval "package ${\scalar(caller)}; use parent '${\shift}';";
};

my $has = sub {
  my ($method, $meta) = @_;

  my $package = caller;

  no strict 'refs';

  if($method eq 'new') {
    no warnings;
    *{"$package\::__soo_new_set__"} = $meta->{set} if($meta->{set});
    return;
  }

  my $fn = sub {
    my $self = shift;

    my $set = $meta->{set} || sub {$_[1]};

    my ($callpkg, $callfn) = split(/::/, +(caller(1))[3]);

    $self->__soo_get_set__($method, $set->($self, shift)) if(@_ && ( $meta->{rw} || ($callpkg eq 'Soo' && $callfn eq '__ANON__') ));

    $self->__soo_get_set__($method) || $meta->{default};
  };

  # set method
  *{"$package\::$method"} = $fn;

};

my $new = sub {
  my ($class, $params) = @_;

  my $self = bless({}, $class);

  # init/clean context
  $self->__soo_init__;

  # constructor set
  $params = $self->__soo_new_set__($params);

  # default behaviour of the constructor is receive a hash ref
  $self->$_($params->{$_}) foreach (keys %$params);

  $self;
};

sub import {
  my $package = caller;

  no strict 'refs';

  # context, we will use this closure context to encapsulate data and provide readonly or readwrite capabilities
  # the context is at class level and will differ object data by using the object ref as key
  my $context = {};

  *{"$package\::__soo_init__"} = sub {
    $context->{+shift} = {};
  };

  *{"$package\::__soo_get_set__"} = sub {
    my $self = shift;
    my $field = shift;

    return unless($field);

    my ($callpkg, $callfn) = split(/::/, +(caller(1))[3]);

    croak "Access denied for $callpkg\::$callfn" unless($callpkg eq 'Soo' && $callfn eq '__ANON__');

    $context->{$self}->{$field} = shift if(@_);

    $context->{$self}->{$field};
  };

  # export extends
  *{"$package\::extends"} = $extends;

  # export has
  *{"$package\::has"} = $has;

  # default constructor
  *{"$package\::new"} = $new unless(defined(*{"$package\::new"}));

  # default constructor setter
  *{"$package\::__soo_new_set__"} = sub {$_[1]} unless(defined(*{"$package\::__soo_new_set__"}));

}


1;

__END__