File Coverage

blib/lib/Rope.pm

Criterion	Covered	Total	%
statement	83	102	81.3
branch	12	30	40.0
condition	2	11	18.1
subroutine	12	13	92.3
pod			n/a
total	109	156	69.8

package Rope;

use 5.006; use strict; use warnings;
our $VERSION = '0.01';

use Rope::Object;
my (%META, %PRO);
BEGIN {
	%PRO = (
		keyword => sub {
			my ($caller, $method, $cb) = @_;
			no strict 'refs';
			*{"${caller}::${method}"} = $cb;
		},
		scope => sub {
			my ($self, %props) = @_;
			for (keys %{$props{properties}}) {
				$props{properties}->{$_} = {%{$props{properties}{$_}}};
				if ($props{properties}{$_}{value} && ref $props{properties}{$_}{value} eq 'CODE') {
					my $cb = $props{properties}{$_}{value};
					$props{properties}{$_}{value} = sub { $cb->($self, @_) };
				}
			}
			return \%props;
		},
		clone => sub {
			my $obj = shift;
			my $ref = ref $obj;
			return $obj if !$ref;
			return [ map { $PRO{clone}->($_) } @{$obj} ] if $ref eq 'ARRAY';
			return { map { $_ => $PRO{clone}->($obj->{$_}) } keys %{$obj} } if $ref eq 'HASH';
			return $obj;
		},
		property => sub {
			my ($caller) = shift;
			return sub {
				my ($prop, @options) = @_;
				if (scalar @options % 2) {
					$prop = shift @options;
				}
				$META{$caller}{properties}{$prop} = {
					@options,
					class => $caller
				};
			};
		},
		prototyped => sub {
			my ($caller) = shift;
			return sub {
				my ($proto) = @_;
				for (keys %{$proto}) {
					if ($META{$caller}{properties}{$_}) {
						if ($META{$caller}{properties}{$_}{writeable}) {
							$META{$caller}{properties}{$_}{value} = $proto->{$_};
							$META{$caller}{properties}{$_}{class} = $caller;
						} elsif ($META{$caller}{properties}{configurable}) {
							if ((ref($META{$caller}{properties}{$_}{value}) || "") eq (ref($proto->{$_}) || "")) {
								$META{$caller}{properties}{$_}{value} = $proto->{$_};
								$META{$caller}{properties}{$_}{class} = $caller;
							} else {
								die "Cannot inherit $META{$caller}{properties}{$_}{class} and change property $_ type";
							}
						} else {
							die "Cannot inherit $META{$caller}{properties}{$_}{class} and change property $_ type";
						}
					} else {
						$META{$caller}{properties}{$_} = {
							value => $proto->{$_},
							writable => 1,
							enumerable => 1,
							configurable => 1,
							class => $caller
						};
					}
				}
			}
		},
		extends => sub {
			my ($caller) = shift;
			return sub {
				my (@extends) = @_;
				for my $extend (@extends) {
					if (!$META{$extend}) {
						(my $name = $extend) =~ s!::!/!g;
						$name .= ".pm";
						CORE::require($name);
					}
					my $initial = $META{$caller};
					my $merge = $PRO{clone}($META{$extend});
					$merge->{name} = $initial->{name};
					$merge->{locked} = $initial->{locked};
					for (keys %{$initial->{properties}}) {
						if ($merge->{properties}->{$_}) {
							if ($merge->{properties}->{writeable}) {
								$merge->{properties}->{$_} = $initial->{properties}->{$_};
							} elsif ($merge->{properties}->{configurable}) {
								if ((ref($merge->{properties}->{$_}->{value}) || "") eq (ref($initial->{properties}->{$_}->{value} || ""))) {
									$merge->{properties}->{$_} = $initial->{properties}->{$_};
								} else {
									die "Cannot inherit $extend and change property $_ type";
								}
							} else {
								die "Cannot inherit $extend and override property $_";
							}
						} else {
							$merge->{properties}->{$_} = $initial->{properties}->{$_};
						}
					}
					$META{$caller} = $merge;
				}
			}
		},
		new => sub {
			my ($caller) = shift;
			return sub {
				my ($class, %params) = @_;
				my $self = \{
					prototype => {},
				};
				$self = bless $self, $caller;
				tie %{${$self}->{prototype}}, 'Rope::Object', $PRO{scope}($self, %{$META{$caller}});
				for (keys %params) {
					$self->{$_} = $params{$_};
				}
				return $self;
			};
		}
	);
}

sub import {
	my ($pkg, $options, $caller) = (shift, {}, caller());
	if (!$META{$caller}) {
		$META{$caller} = {
			name => $caller,
			locked => 0,
			properties => {}
		};
	}
	$PRO{keyword}($caller, '((', sub {});
	$PRO{keyword}($caller, '(%{}', sub {
		${$_[0]}->{prototype};
	});
	$PRO{keyword}($caller, $_, $PRO{$_}($caller))
		for qw/property prototyped extends new/;
}

1;

__END__