File Coverage

blib/lib/Venus/Prototype.pm

Criterion	Covered	Total	%
statement	46	65	70.7
branch	16	30	53.3
condition	11	19	57.8
subroutine	14	17	82.3
pod	5	8	62.5
total	92	139	66.1

package Venus::Prototype;

use 5.018;

use strict;
use warnings;

use Venus::Class 'base', 'with';

base 'Venus::Kind::Utility';

with 'Venus::Role::Valuable';
with 'Venus::Role::Buildable';
with 'Venus::Role::Proxyable';

use Scalar::Util ();

# HOOKS

sub _clone {
  my ($data) = @_;

  if (!defined($data)) {
    return $data;
  }
  elsif (!Scalar::Util::blessed($data) && ref($data) eq 'HASH') {
    my $copy = {};
    for my $key (keys %$data) {
      $copy->{$key} = _clone($data->{$key});
    }
    return $copy;
  }
  elsif (!Scalar::Util::blessed($data) && ref($data) eq 'ARRAY') {
    my $copy = [];
    for (my $i = 0; $i < @$data; $i++) {
      $copy->[$i] = _copy($data->[$i]);
    }
    return $copy;
  }
  else {
    return $data;
  }
}

sub _value {
  my ($data) = @_;

  if (keys %$data == 1 && exists $data->{value}) {
    return $data->{value};
  }
  else {
    return $data;
  }
}

# BUILDERS

sub build_args {
  my ($self, $data) = @_;

  if (keys %$data == 1 && exists $data->{value}) {
    return _clone($data);
  }
  return {
    value => _clone($data)
  };
}

sub build_proxy {
  my ($self, $package, $method, @args) = @_;

  # as a method/routine
  return sub {
    $self->{value}{"\&$method"}->($self, @args)
  }
  if defined $self->{value}{"\&$method"};

  # as a property/attribute
  return sub {
    @args ? $self->{value}{"\$$method"} = $args[0] : $self->{value}{"\$$method"}
  }
  if exists $self->{value}{"\$$method"};

  return undef;
}

# METHODS

sub apply {
  my ($self, $data) = @_;

  $data ||= {};

  return $self->do('value', _clone({%{_value($self)}, %{_value($data)}}));
}

sub call {
  my ($self, $method, @args) = @_;

  # as a method/routine
  return $self->{value}{"\&$method"}->($self, @args)
    if defined $self->{value}{"\&$method"};

  # as a property/attribute
  return @args ? $self->{value}{"\$$method"} = $args[0] : $self->{value}{"\$$method"}
    if exists $self->{value}{"\$$method"};
}

sub default {
  my ($self) = @_;

  return {};
}

sub extend {
  my ($self, $data) = @_;

  $data ||= {};

  return $self->class->new(_clone({%{_value($self)}, %{_value($data)}}));
}

sub get {
  my ($self, @args) = @_;

  return $self->value if !@args;

  my ($index) = @args;

  return $self->value->{$index};
}

sub set {
  my ($self, @args) = @_;

  return $self->value if !@args;

  return $self->value(@args) if @args == 1 && ref $args[0] eq 'HASH';

  my ($index, $value) = @args;

  return if not defined $index;

  return $self->value->{$index} = $value;
}

1;



=head1 NAME

Venus::Prototype - Prototype Class

=cut

=head1 ABSTRACT

Prototype Class for Perl 5

=cut

=head1 SYNOPSIS

  package main;

  use Venus::Prototype;

  my $prototype = Venus::Prototype->new(
    '$counter' => 0,
    '&decrement' => sub { $_[0]->counter($_[0]->counter - 1) },
    '&increment' => sub { $_[0]->counter($_[0]->counter + 1) },
  );

  # bless({value => {...}}, 'Venus::Prototype')

  # $prototype->counter # 0
  # $prototype->increment # 1
  # $prototype->counter # 1
  # $prototype->decrement # 0
  # $prototype->counter # 0

=cut

=head1 DESCRIPTION

This package provides a simple construct for enabling prototype-base
programming. Properties can be called as methods when prefixed with a dollar or
ampersand symbol. See L for more details.

=cut

=head1 INHERITS

This package inherits behaviors from:

L

=cut

=head1 INTEGRATES

This package integrates behaviors from:

L

L

L

=cut

=head1 METHODS

This package provides the following methods:

=cut

=head2 apply

  apply(HashRef $data) (Prototype)

The apply method extends the underlying data structure by merging the data
provided, and then returns the invocant.

I>

=over 4

=item apply example 1

  package main;

  my $person = Venus::Prototype->new({
    '$name' => '',
  });

  $person->apply;

  # bless({value => {'$name' => ''}}, 'Venus::Prototype')

=back

=over 4

=item apply example 2

  package main;

  my $person = Venus::Prototype->new({
    '$name' => '',
  });

  $person->apply({
    '$name' => 'Elliot Alderson',
  });

  # bless({value => {'$name' => 'Elliot Alderson'}}, 'Venus::Prototype')

=back

=over 4

=item apply example 3

  package main;

  my $person = Venus::Prototype->new({
    '$name' => '',
    '&greet' => sub {'hello'},
  });

  $person->apply({
    '$name' => 'Elliot Alderson',
  });

  # bless({value => {...}}, 'Venus::Prototype')

=back

=cut

=head2 call

  call(Str $method, Any @args) (Any)

The call method dispatches method calls based on the method name provided and
the state of the object, and returns the results. If the method name provided
matches an object property of the same name with an ampersand prefix, denoting
a method, then the dispatched method call acts as a method call providing the
invocant as the first argument. If the method name provided matches an object
property of the same name with a dollar sign prefix, denoting an attribute,
then the dispatched method call acts as an attribute accessor call. This method
is also useful for calling virtual methods when those virtual methods conflict
with the L methods.

I>

=over 4

=item call example 1

  package main;

  my $person = Venus::Prototype->new({
    '$name' => 'anonymous',
  });

  my $name = $person->call('name');

  # "anonymous"

=back

=over 4

=item call example 2

  package main;

  my $person = Venus::Prototype->new({
    '$name' => 'anonymous',
  });

  my $name = $person->call('name', 'unidentified');

  # "unidentified"

=back

=cut

=head2 extend

  extend(HashRef $data) (Prototype)

The extend method copies the underlying data structure, merging the data
provided if any, and then returns a new prototype object.

I>

=over 4

=item extend example 1

  package main;

  my $mrrobot = Venus::Prototype->new({
    '$name' => 'Edward Alderson',
    '$group' => 'fsociety',
  });

  my $elliot = $mrrobot->extend({
    '$name' => 'Elliot Alderson',
  });

  # bless({value => {...}}, 'Venus::Prototype')

=back

=over 4

=item extend example 2

  package main;

  my $mrrobot = Venus::Prototype->new({
    '$name' => 'Edward Alderson',
    '$group' => 'fsociety',
    '$login' => { username => 'admin', password => 'secret', },
  });

  my $elliot = $mrrobot->extend({
    '$name' => 'Elliot Alderson',
    '$login' => { password => '$ecr3+', },
  });

  # bless({value => {...}}, 'Venus::Prototype')

=back

=over 4

=item extend example 3

  package main;

  my $ability = {
    '&access' => sub {time},
  };

  my $person = Venus::Prototype->new;

  my $mrrobot = $person->extend($ability);

  my $elliot = $mrrobot->extend($ability);

  # bless({value => {...}}, 'Venus::Prototype')

=back

=cut

=head1 AUTHORS

Awncorp, C

=cut

=head1 LICENSE

Copyright (C) 2000, Al Newkirk.

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

=cut