File Coverage

blib/lib/Rope.pm

Criterion	Covered	Total	%
statement	405	431	93.9
branch	145	192	75.5
condition	51	81	62.9
subroutine	40	42	95.2
pod	9	11	81.8
total	650	757	85.8

package Rope;

use 5.006; use strict; use warnings;
our $VERSION = '0.45';
use Rope::Object;
use Rope::Pro;
my (%META, %PRO);
our @ISA;

BEGIN {
	%PRO = Rope::Pro->new(
		scope => sub {
			my ($caller, $self, %props) = @_;
			for my $prop (keys %{$props{properties}}) {
				if ($props{properties}{$prop}{value} && ref $props{properties}{$prop}{value} eq 'CODE') {
					my $cb = $props{properties}{$prop}{value};
					$props{properties}{$prop}{value} = sub { $cb->($META{initialised}{$caller}{${$self}->{identifier}}, @_) };
				}

				for (qw/predicate clearer/) {
					if ($props{properties}->{$prop}->{$_}) {
						my $prep = $_ eq 'predicate' ? 'has_' : 'clear_';
						my $pred = $props{properties}->{$prop}->{$_};
						my $ref = ref($pred);
						if ( !$ref ) {
							$props{properties}->{$pred =~ m/^\d+$/ ? "$prep$prop" : $pred} = {
								value => $_ eq 'predicate'
									? sub { return defined $META{initialised}{$caller}{${$self}->{identifier}}->{$prop} ? 1 : '' }
									: sub { $META{initialised}{$caller}{${$self}->{identifier}}->{$prop} = undef; 1; }
							};
						} elsif ($ref eq 'CODE') {
							$props{properties}->{"$prep$prop"} = {
								value => sub { $pred->($META{initialised}{$caller}{${$self}->{identifier}}, $prop) }
							};
						} elsif ($ref eq 'HASH') {
							my $cb = $pred->{value};
							$pred->{value} = sub { $cb->($META{initialised}{$caller}{${$self}->{identifier}}, $prop) };
							$props{properties}->{$pred->{name} || "$prep$prop"} = $pred;
						}
					}
				}
				for (qw/trigger delete_trigger/) {
					my $trigger = $props{properties}{$prop}{$_};
					if (defined $trigger) {
						$props{properties}{$prop}{$_} = sub {
							$trigger->($META{initialised}{$caller}{${$self}->{identifier}}, @_)
						};
					}
				}
				for (qw/before after/) {
					my $mod = $props{properties}{$prop}{$_};
					if (defined $mod && scalar @{$mod}) {
						my $cb = sub {
							my $cb = shift;
							$cb->($META{initialised}{$caller}{${$self}->{identifier}}, @_);
						};
						$props{properties}{$prop}{$_} = sub {
							my (@params) = @_;
							for (my $i = 0; $i < scalar @{$mod} - 1; $i++) {
								my @new_params = ($cb->($mod->[$i], @params));
								@params = @new_params if @new_params;
							}
							return $cb->($mod->[-1], @params);
						};
					}
				}
				my $mod = $props{properties}{$prop}{around};
				if (defined $mod && scalar @{$mod}) {
					my $cb = sub {
						my $cb = shift;
						$cb->($META{initialised}{$caller}{${$self}->{identifier}}, @_);
					};
					$props{properties}{$prop}{around} = sub {
						my ($orig, @params) = @_;
						my $code = (ref($orig) || "") eq 'CODE';
						@params = ($orig) if (!$code);
						my @stack;
						for (my $i = 0; $i < scalar @{$mod}; $i++) {
							my $current = $mod->[$i];
							my $next = $stack[-1] ? $stack[-1] : $code ? $orig : sub { $_[0] };
							my $calling = sub {
								return $cb->($current, $next, @_);
							};
							push @stack, $calling;
						}
						return $stack[-1]->(@params);
					};
				}
				my $handles = $props{properties}{$prop}{handles};
				if ($handles) {
					$props{handles} = {%{ $props{handles} || {} }, map { $_ => $prop } keys %{$handles}};
				}
			}
			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;
		},
		set_prop => sub {
			my ($caller, $prop, %options) = @_;
			if (exists $META{$caller}{properties}{$prop}) {
				defined $options{$_} && do { $META{$caller}{properties}{$prop}{$_} = $options{$_} } for qw/builder trigger delete_trigger handles handles_via/;
				if ($META{$caller}{properties}{$prop}{writeable}) {
					$META{$caller}{properties}{$prop}{value} = $options{value} if exists $options{value};
					$META{$caller}{properties}{$prop}{class} = $caller;
				} elsif ($META{$caller}{properties}{$prop}{configurable}) {
					if ((ref($META{$caller}{properties}{$prop}{value}) || "") eq (ref($options{value}) || "")) {
						$META{$caller}{properties}{$prop}{value} = $options{value} if exists $options{value};
						$META{$caller}{properties}{$prop}{class} = $caller;
					} else {
						die "Cannot inherit $META{$caller}{properties}{$prop}{class} and change property $prop type";
					}
				} else {
					die "Cannot inherit $META{$caller}{properties}{$prop}{class} and change property $prop type";
				}
			} else {
				$META{$caller}{properties}{$prop} = {
					class => $options{class} || $caller,
					index => ++$META{$caller}{keys},
					%options
				};
			}
		},
		requires => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] && $_[0] eq $caller;
				my (@requires) = @_;
				$META{$caller}{requires}{$_}++ for (@requires);
			};
		},
		readonly => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my ($prop, @options) = @_;
				$prop = shift @options if ( @options > 1 );
				$PRO{set_prop}(
					$caller,
					$prop,
					value => $options[0],
					enumerable => 0,
					writeable => 0,
					initable => 1,
					readonly => 1,
				);
			};
		},
		private => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my ($prop, @options) = @_;
				$prop = shift @options if ( @options > 1 );
				$PRO{set_prop}(
					$caller,
					$prop,
					value => $options[0],
					enumerable => 0,
					writeable => 0,
					initable => 0,
					private => 1,
				);
			};
		},
		function => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my ($prop, @options) = @_;
				$prop = shift @options if ( @options > 1 );
				$PRO{set_prop}(
					$caller,
					$prop,
					value => $options[0],
					enumerable => 0,
					writeable => 0,
					initable => 0,
					configurable => 0
				);
			};
		},
		properties => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my (@properties) = @_;
				while (@properties) {
					my ($prop, $options) = (shift @properties, shift @properties);
					my $ref = ref $options;
					if (!$ref || $ref ne 'HASH' || ! grep { defined $options->{$_} }
						qw/initable writeable builder enumerable configurable trigger clearer predicate delete_trigger value handles_via handles/
					) {
						$options = {
							initable => 1,
							enumerable => 1,
							writeable => 1,
							configurable => 1,
							value => $options
						};
					}

					for (ref $prop ? @{$prop} : ($prop)) {
						$PRO{set_prop}(
							$caller,
							$_,
							%{$options}
						)
					};
				}
			};
		},
		property => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my ($prop, @options) = @_;
				if (scalar @options % 2) {
					$prop = shift @options;
				}
				for (ref $prop ? @{$prop} : ($prop)) {
					$PRO{set_prop}(
						$caller,
						$_,
						@options
					);
				}
			};
		},
		prototyped => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my (@proto) = @_;
				while (@proto) {
					my ($prop, $value) = (shift @proto, shift @proto);
					for (ref $prop ? @{$prop} : ($prop)) {
						$PRO{set_prop}(
							$caller,
							$_,
							enumerable => 1,
							writeable => 1,
							configurable => 1,
							initable => 1,
							value => $value
						);
					}
				}
			}
		},
		with => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my (@withs) = @_;
				for my $with (@withs) {
					if (!$META{$with}) {
						(my $name = $with) =~ s!::!/!g;
						$name .= ".pm";
						CORE::require($name);
					}
					my $initial = $META{$caller};
					my $merge = $PRO{clone}($META{$with});
					push @{$merge->{with}}, $merge->{name};
					$merge->{name} = $initial->{name};
					$merge->{locked} = $initial->{locked};
					for my $prop (keys %{$initial->{properties}}) {
						$merge->{properties}->{$prop}->{index} = ++$merge->{keys};
						my $modifier;
						for (qw/before around after/) {
							if ($initial->{properties}->{$prop}->{$_}) {
								$modifier = 1;
								unshift @{$merge->{properties}->{$prop}->{$_}}, @{$initial->{properties}->{$prop}->{$_}}
							}
						}
						next if $modifier;
						next if grep { $META{$with}->{properties}->{$prop}->{$_} } qw/before around after/;
						if (scalar keys %{$merge->{properties}->{$prop}} > 1) {
							if ($merge->{properties}->{writeable}) {
								$merge->{properties}->{$prop} = $initial->{properties}->{$prop};
							} elsif ($merge->{properties}->{configurable}) {
								if ((ref($merge->{properties}->{$prop}->{value}) || "") eq (ref($initial->{properties}->{$prop}->{value} || ""))) {
									$merge->{properties}->{$prop} = $initial->{properties}->{$prop};
								} else {
									die "Cannot include $with and change property $prop type";
								}
							} else {
								die "Cannot include $with and override property $prop";
							}
						} else {
							$merge->{properties}->{$prop} = $initial->{properties}->{$prop};
						}
					}
					$merge->{requires} = {%{$merge->{requires}}, %{$initial->{requires}}};
					$META{$caller} = $merge;
				}
			}
		},
		extends => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				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});
					push @{$merge->{extends}}, $merge->{name};
					$merge->{name} = $initial->{name};
					$merge->{locked} = $initial->{locked};
					for my $prop (keys %{$initial->{properties}}) {
						$initial->{properties}->{$prop}->{index} = ++$merge->{keys};
						for (qw/before around after/) {
							unshift @{$merge->{properties}->{$prop}->{$_}}, @{$initial->{properties}->{$prop}->{$_}} if $initial->{properties}->{$prop}->{$_};
						}
						if ($merge->{properties}->{$prop}) {
							if ($merge->{properties}->{writeable}) {
								$merge->{properties}->{$prop} = $initial->{properties}->{$prop};
							} elsif ($merge->{properties}->{configurable}) {
								if ((ref($merge->{properties}->{$prop}->{value}) || "") eq (ref($initial->{properties}->{$prop}->{value} || ""))) {
									$merge->{properties}->{$prop} = $initial->{properties}->{$prop};
								} else {
									die "Cannot inherit $extend and change property $prop type";
								}
							} else {
								die "Cannot inherit $extend and override property $prop";
							}
						} else {
							$merge->{properties}->{$prop} = $initial->{properties}->{$prop};
						}
					}
					$merge->{requires} = {%{$merge->{requires}}, %{$initial->{requires}}};
					my $isa = '@' . $caller . '::ISA';
					eval "push $isa, '$extend'";
					$META{$caller} = $merge;
				}
			}
		},
		before => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my ($prop, $cb) = @_;
				push @{$META{$caller}{properties}{$prop}{before}}, $cb;
			};
		},
		around => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my ($prop, $cb) = @_;
				push @{$META{$caller}{properties}{$prop}{around}}, $cb;
			};
		},
		after => sub {
			my ($caller) = shift;
			return sub {
				shift @_ if $_[0] eq $caller;
				my ($prop, $cb) = @_;
				push @{$META{$caller}{properties}{$prop}{after}}, $cb;
			};
		},
		locked => sub {
			my ($caller) = shift;
			return sub {
				my ($self, $locked) = @_;
				if (ref $self) {
					$self->{locked} = $locked;
					return;
				} else {
					$META{$caller}{locked} = 1;
				}
			};
		},
		destroy => sub {
			my ($caller) = shift;
			return sub {
				my ($self, $locked) = @_;
				if (ref $self) {
					return $self->DESTROY;
				}
			};
		},
		DESTROY => sub {
			my ($caller) = shift;
			return sub {
				my ($self, $locked) = @_;
				if (ref $self) {
					delete $META{initialised}{$caller}{${$self}->{identifier}};
					return;
				}
			};
		},
		new => sub {
			my ($caller) = shift;
			return sub {
				my ($class, %params) = (shift, scalar @_ == 1 ? %{$_[0]} : @_);
				my $self = \{
					prototype => {},
					identifier => $META{initialised}{$caller}{identifier}++
				};
				$self = bless $self, $caller;
				my $build = $PRO{clone}($META{$caller});
				for (keys %params) {
					next if $_ =~ m/^_/;
					if ($build->{properties}->{$_}) {
						if ($build->{properties}->{$_}->{initable}) {
							$build->{properties}->{$_}->{value} = $params{$_};
						} else {
							die "Cannot initalise Object ($caller) property ($_) as initable is not set to true.";
						}
					} else {
						$build->{properties}->{$_} = {
							value => $params{$_},
							initable => 1,
							writeable => 1,
							enumerable => 1,
							configurable => 1,
							index => ++$META{$caller}{keys}
						};
					}
				}
				for ( sort { ($build->{properties}->{$a}->{index} || 0) <=> ($build->{properties}->{$b}->{index} || 0) } keys %{ $build->{properties} } ) {
					if ( !defined $build->{properties}->{$_}->{value} && defined $build->{properties}->{$_}->{builder}) {
						my $builder = $build->{properties}->{$_}->{builder};
						$build->{properties}->{$_}->{value} = ref $builder ? $builder->($build) : $caller->$builder($build);
					}
				}
				exists $build->{properties}->{INITIALISE}
					? $build->{properties}->{INITIALISE}->{value}->($self, $build, \%params)
					: $self->can('INITIALISE') && $self->INITIALISE($build, \%params);
				tie %{${$self}->{prototype}}, 'Rope::Object', $PRO{scope}($caller, $self, %{$build});
				$META{initialised}{$caller}->{${$self}->{identifier}} = $self;
				$self->{ROPE_init}->();

				exists $build->{properties}->{INITIALISED}
					? $build->{properties}->{INITIALISED}->{value}->(\%params)
					: $self->can('INITIALISED') && $self->INITIALISED(\%params);
				return $self;
			};
		}
	);
}

sub import {
	my ($pkg, $options, $caller) = (shift, {@_}, caller());
	return if $options->{no_import};
	$caller = $options->{caller} if $options->{caller};
	if (!$META{$caller}) {
		$META{$caller} = {
			name => $caller,
			locked => 0,
			properties => {},
			requires => {},
			keys => 0
		};
	}
	$PRO{keyword}($caller, 'can', sub { ref $_[0] and ($_[0]->{$_[1]} || $META{$caller}->{properties}->{$_[1]}) || $_[0]->CORE::can($_[1]) });
	$PRO{keyword}($caller, '(bool', sub { 1; });
	$PRO{keyword}($caller, '(eq', sub { $_[1]; });
	$PRO{keyword}($caller, '((', sub { });
	$PRO{keyword}($caller, '(%{}', sub {
		${$_[0]}->{prototype};
	});
	$PRO{keyword}($caller, $_, $PRO{$_}($caller))
		for $options->{import}
			? @{$options->{import}}
			: qw/function property properties prototyped private readonly extends with requires before around after locked destroy DESTROY new/;
}

sub new {
	my ($pkg, $meta, %params) = @_;

	my $name = $meta->{name} || 'Rope::Anonymous' . $META{ANONYMOUS}++;

	if (!$META{$name}) {
		$META{$name} = {
			name => $name,
			locked => 0,
			properties => {},
			requires => {},
			keys => 0
		};

		my $use = 'use Rope;';
		$use .= "use ${_};" for (@{$meta->{use}});

		my $c = sprintf(q|
			package %s;
			%s
			1;
		|, $name, $use);
		eval $c;
	}

	$pkg->set_meta($meta, $name);

	if (grep { $_ eq 'Rope::Monkey' } @{$meta->{use}}) {
		$meta->{name}->monkey();
	}

	return $PRO{new}($name)($name, %params);
}

sub from_array {
	my ($pkg, $data, $meta) = @_;

	$meta ||= {};
	$meta->{name} ||= 'Rope::Anonymous' . $META{ANONYMOUS}++;
	my $len = scalar @{$data};
	for (my $i = 0; $i < $len; $i++) {
		my ($key, $value) = ($data->[$i++], $data->[$i]);
		$meta->{properties}->{$key} = {
			value => $value,
			writeable => 1,
			enumerable => 1
		};
	}

	return $pkg->new($meta)->new();
}


sub from_data {
	my ($pkg, $data, $meta) = @_;

	$meta ||= {};
	$meta->{name} ||= 'Rope::Anonymous' . $META{ANONYMOUS}++;

	for (keys %{$data}) {
		$meta->{properties}->{$_} = {
			value => $data->{$_},
			writeable => 1,
			enumerable => 1
		};
	}

	return $pkg->new($meta)->new();
}

sub from_nested_array {
	my ($pkg, $data, $meta) = @_;

	$data = $PRO{clone}($data);
	for (my $i = 0; $i < scalar @{$data}; $i++) {
		my ($key, $value) = ($data->[$i++], $data->[$i]);
		my $ref = ref $value;
		if ($ref eq 'ARRAY') {
			if ((ref($value->[-1]) || "") eq 'HASH' && $value->[-1]->{ROPE_scope} eq 'ARRAY') {
				pop @{$value};
				next;
			}
			elsif (ref $value->[0]) {
				for (my $x = 0; $x < scalar @{$value}; $x++) {
					my ($val) = ($value->[$x]);
					my $rref = ref($val); # || "";
					if ($rref eq 'ARRAY') {
						$val = $pkg->from_nested_array(
							$val,
							$meta
						);
						$value->[$x] = $val;
					}
				}
			} else {
				$data->[$i] = $pkg->from_nested_array($value, $meta);
			}
		}
	}

	return $pkg->from_array($data, $meta);
}

sub from_nested_data {
	my ($pkg, $data, $meta) = @_;

	$data = $PRO{clone}($data);

	for my $d (keys %{$data}) {
		my $ref = ref $data->{$d};
		if ($ref eq 'HASH') {
			$data->{$d} = $pkg->from_nested_data($data->{$d}, $meta);
		} elsif ($ref eq 'ARRAY') {
			for (my $i = 0; $i < scalar @{$data->{$d}}; $i++) {
				my $val = $data->{$d}->[$i];
				my $rref = ref $val || "";
				if ($rref eq 'HASH') {
					$val = $pkg->from_nested_data(
						$val,
						$meta
					);
					$data->{$d}->[$i] = $val;
				}
			}
		}
	}

	return $pkg->from_data($data, $meta);
}

sub get_initialised {
	my ($self, $caller, $init) = @_;
	return $META{initialised}{$caller}{$init};
}

sub get_meta {
	my ($self, $caller) = @_;
	return $PRO{clone}($META{$caller || ref $self});
}

sub set_meta {
	my ($self, $meta, $name) = @_;
	$name = $meta->{name} if ! $name;
	$META{$name}{locked} = $meta->{locked} if (defined $meta->{locked});
	$PRO{requires}($name)(ref $meta->{requires} eq 'ARRAY' ? @{$meta->{requires}} : keys %{$meta->{requires}}) if ($meta->{requires});
	$PRO{extends}($name)(@{$meta->{extends}}) if ($meta->{extends});
	$PRO{with}($name)(@{$meta->{with}}) if ($meta->{with});
	$PRO{properties}($name)(ref $meta->{properties} eq 'ARRAY' ? @{$meta->{properties}} : %{$meta->{properties}}) if ($meta->{properties});
	$PRO{keyword}($name, 'INITIALISE', $meta->{INITIALISE}) if $meta->{INITIALISE};
	$PRO{keyword}($name, 'INITIALISED', $meta->{INITIALISED}) if $meta->{INITIALISED};
}

sub clear_meta {
	my ($self, $name) = @_;
	$META{$name} = {
		name => $name,
		locked => 0,
		properties => {},
		requires => {},
		keys => 0
	};
}

sub clear_property {
	my ($self, $name, $prop) = @_;
	delete $META{$name}{properties}{$prop};
}

sub set_property {
	my ($self, $name, $prop, $property) = @_;
	$META{$name}{properties}{$prop} = $property;
}


1;

__END__