package Rope;

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

use Rope::Object;
my (%META, %PRO);
our @ISA;
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;
		},
		set_prop => sub {
			my ($caller, $prop, %options) = @_;
			if ($META{$caller}{properties}{$prop}) {
				if ($META{$caller}{properties}{$prop}{writeable}) {
					$META{$caller}{properties}{$prop}{value} = $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};
						$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 => $caller,
					index => ++$META{$caller}{keys},	
					%options
				};
			}
		},
		requires => sub {
			my ($caller) = shift;
			return sub {
				my (@requires) = @_;
				$META{$caller}{requires}{$_}++ for (@requires);
			};
		},
		function => sub {
			my ($caller) = shift;
			return sub {
				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 {
				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 value/) {
						$options = {
							initable => 1,
							enumerable => 1,
							writeable => 1,
							configurable => 1,
							value => $options 
						};
					}

					$PRO{set_prop}(
						$caller,
						$prop,
						%{$options}
					);
				}
			};
		},
		property => sub {
			my ($caller) = shift;
			return sub {
				my ($prop, @options) = @_;
				if (scalar @options % 2) {
					$prop = shift @options;
				}
				$PRO{set_prop}(
					$caller,
					$prop,
					@options
				);
			};
		},
		prototyped => sub {
			my ($caller) = shift;
			return sub {
				my (@proto) = @_;
				while (@proto) {
					my ($prop, $value) = (shift @proto, shift @proto);
					$PRO{set_prop}(
						$caller,
						$prop,
						enumerable => 1,
						writeable => 1,
						configurable => 1,
						initable => 1,
						value => $value
					);
				}
			}
		},
		with => sub {
			my ($caller) = shift;
			return sub {
				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});
					$merge->{name} = $initial->{name};
					$merge->{locked} = $initial->{locked};
					for (keys %{$initial->{properties}}) {
						$initial->{properties}->{$_}->{index} = ++$merge->{keys};
						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 include $with and change property $_ type";
								}
							} else {
								die "Cannot include $with and override property $_";
							}
						} else {
							$merge->{properties}->{$_} = $initial->{properties}->{$_};
						}
					}
					$merge->{requires} = {%{$merge->{requires}}, %{$initial->{requires}}};
					$META{$caller} = $merge;
				}
			}
		},
		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}}) {
						$initial->{properties}->{$_}->{index} = ++$merge->{keys};
						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}->{$_};
						}
					}
					$merge->{requires} = {%{$merge->{requires}}, %{$initial->{requires}}};
					my $isa = '@' . $caller . '::ISA';
					eval "push $isa, '$extend'";
					$META{$caller} = $merge;
				}
			}
		},
		locked => sub {
			my ($caller) = shift;
			return sub {
				my ($self, $locked) = @_;
				if (ref $self) {
					$self->{locked} = $locked;
					return;
				} else {
					$META{$caller}{locked} = 1;
				}
			};
		},
		new => sub {
			my ($caller) = shift;
			return sub {
				my ($class, %params) = @_;
				my $self = \{
					prototype => {},
				};
				$self = bless $self, $caller;
				my $build = $PRO{clone}($META{$caller});
				for (keys %params) {
					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} <=> $build->{properties}->{$b}->{index} } 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);
					}
				}
				tie %{${$self}->{prototype}}, 'Rope::Object', $PRO{scope}($self, %{$build});

				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, '(bool', sub { scalar keys %{${$_[0]}->{prototype}}; });
	$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 extends with requires locked 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;
	}

	$META{$name}{locked} = $meta->{locked} if (defined $meta->{locked});
	$PRO{requires}($name)(@{$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});
	return $PRO{new}($name)($name, %params);
}

1;

__END__

=head1 NAME

Rope - Tied objects

=head1 VERSION

Version 0.12

=cut

=head1 SYNOPSIS

	package Knot;

	use Rope;

	prototyped (
		loops => 1,
		hitches => 10,
		...

	);

	properties (
		bends => {
			type => sub { $_[0] =~ m/^\d+$/ ? $_[0] : die "$_[0] != integer" },
			value => 10,
			initable => 1,
			configurable => 1,
			enumerable => 1,
			required => 1
		},
		...
	);

	function add_loops => sub {
		my ($self, $loop) = @_;
		$self->{loops} += $loop;
	};

	1;

...

	my $k = Knot->new();

	say $k->{loops}; # 1;
	
	$k->{add_loops}(5);

	say $k->{loops}; # 6;

	$k->{add_loops} = 5; # errors


=head1 DESCRIPTION

C<Rope> is an Object Orientation system that is built on top of perls core hash tying implementation. It extends the functionality which is available with all the modern features you would expect from an modern OO system. This includes clear class and role definitions. With Rope you also get out of the box sorted objects, where the order you define persists.

=head1 CONFIGURE PROPERTIES

=head2 initable

If set to a true value then this property can be initialised during the object creationg, when calling ->new(%params). If set to false then on initialisation the code will die with a relevant error when you try to initialise it. (Cannot initalise Object ($name) property ($key) as initable is not set to true.)

=head2 writeable

If set to a true value then this property value can be updated after initialisation with any other value. If set to false then the code will die with a relevant error. If writeable is true then configurable is not checked and redundent. (Cannot set Object ($name) property ($key) it is only readable)

=head2 configurable

If set to a true value then this property value can be updated after initialisation with a value that matches the type of the existing. If you try to set a value which is not of the same type the code will die with a relevant error. (Cannot change Object ($name) property ($key) type). If you set to false and writeable is also false you will get the same error as writeable false.

=head2 enumerable

If set to a true value then the property will be enumerable when you itterate the object for example when you call keys %{$self}. If set to false then the property will be hidden from any itteration. Note also that when itterating your object keys are already ordered based on the order they were assigned.

=head2 required

If set to a true value then this property is required at initialisation, either by a value key being set or via passing into ->new. I would suggest using this in conjunction with initable when you require a value is passed. If no value is passed and required is set to true then the code will die with a relevant error. (Required property ($key) in object ($object) not set)

=head2 type

The type property/key expects a code ref to be passed, all values that are then set either during initialisation or writing will run through this ref. Rope expects that you return the final value from this ref so you can use coercion via a type.

=head2 builder

The buidler property/key expects either a code ref or a scalar that represents the name of a sub routine in your class (currently not functions/properties but may extend in the future). It expects the value for that property to be returned from either the code ref or sub routine. Within a builder you can also add new properties to your object by extending the passed defintion, when extending this way I would suggest using ++$_[0]->{keys} to set the index so that sorting is persistent further down the line.

=head2 index

The index property/key expects an integer, if you do not set then this integer it's automatically generated and associated to the property. You will only want to set this is you always want to have a property last when itterating

=head1 KEYWORDS

=head2 property

Extends the current object definition with a single new property

	property one => (
		initable => 1,
		writeable => 0,
		enumerable => 1,
		builder => sub {
			return 200;
		}
	);


=head2 properties

Extends the current object definition with multiple new properties

	properties (
		two => {
			type => sub { $_[0] =~ m/^\d+$/ ? $_[0] : die "$_[0] != integer" },
			value => 10,
			initable => 1,
			configurable => 1,
			enumerable => 1,
			required => 1
		},
		...
	);

=head2 prototyped

Extends the current object definition with multiple new properties where initable, writable and enumerable are all set to a true value.

	prototyped (
		two => 10
		...
	);

=head2 function

Extends the current object definition with a new property that acts as a function. A function has initable, writeable, enumerable and configurable all set to false so it cannot be changed/set once the object is instantiated.

	function three => sub {
		my ($self, $param) = @_;
		...
	};

NOTE: normal sub tradditional routines work and should be inherited also.	

	sub three {
		my ($self, $param) = @_;
		...
	}

=head2 extends

The extends keyword allows you to extend your current definition with another object, your objext will inherit all the properties of that extended object.

	package Ping;
	use Rope;
	extends 'Pong';

=head2 with

The with keyword allows you to include roles in your current object definition, your objext will inherit all the properties of that role.

	package Ping;
	use Rope;
	with 'Pong';

=head2 requires

The requires keyword allows you to define properties which are required for either a role or an object, it works in both directions.

	package Pong;
	use Rope::Role;
	requires qw/host/;
	function ping => sub { ... };
	function pong => sub { ... };

	package Ping;
	use Rope;
	requires qw/ping pong/;
	with 'Pong';
	prototyped (
		host => '...'
	);

=head2 locked

The locked keyword can be used to lock your Object so that it can no longer be extended with new properties/keys.

	package Locked;

	use Rope;

	property one => ( ... );

	locked;

	1;

Once you have an object initialised you can toggle whether is locked by calling 'locked' with either a true or false value.

	$obj->locked(1);

	$obj->locked(0);

=head1 METHODS

=head2 new

Along with class definitions you can also generate object using Rope itself, the options are the same as described above.

	my $knot = Rope->new({
		name => 'Knot',
		properties => [
			loops => 1,
			hitches => {
				type => Int,
				value => 10,
				initable => 0,
				configurable => 0,
			},
			add_loops => sub {
				my ($self, $loop) = @_;
				$self->{loops} += $loop;
			}
		]
	});

	my $with = Rope->new({
		use => [ 'Rope::Autoload' ],
		with => [ 'Knot' ],
		requires => [ qw/loops hitches add_loops/ ],
		properties => [ bends => { type => Int, initable => 1, configurable => 1 }, ... ]
	}, bends => 5);

	$knot->{loops};
	$with->loops;

=head1 OBJECT CLASS DEFINITION

	package Builder;

	use Rope;

	property one => (
		initable => 1,
		writeable => 0,
		enumerable => 1,
		builder => sub {
			return 200;
		}	
	);

	property two => (
		writeable => 0,
		enumerable => 0,
		builder => sub {
			$_[0]->{properties}->{three} = {
				value => 'works',
				writeable => 0,
				index => ++$_[0]->{keys}
			};
			return $_[0]->{properties}->{one}->{value} + 11;
		}
	);

	1;


=head1 OBJECT ROLE DEFINITION

	package Builder::Role;

	use Rope::Role;

	property one => (
		initable => 1,
		writeable => 0,
		enumerable => 1,
		builder => sub {
			return 200;
		}	
	);

	1;

=head1 AUTOLOADING

If you do not enjoy accessing properties as hash keys and would instead like to access them as package routines then you can simply include C<Rope::Autoload> and this will use perls internal AUTOLOAD functionality to expose your properties as routines.

	package Builder;

	use Rope;
	use Rope::Autoload;

	...

	1;

So you can write

	$builder->thing = 10;

Instead of

	$builder->{thing} = 10;

=head1 TYPES

Rope also includes additional helpers for defining properties with fixed types, see C<Rope::Type> for more information. ( internally that uses C<Type::Standard> for the actual type checking. )

	package Knot;
	 
	use Rope;
	use Rope::Type qw/int/;
	 
	int loops => 1;
	int hitches => 10;

	1;

=head1 AUTHOR

LNATION, C<< <email at lnation.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-rope at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Rope>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Rope

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Rope>

=item * CPAN Ratings

L<https://cpanratings.perl.org/d/Rope>

=item * Search CPAN

L<https://metacpan.org/release/Rope>

=back

=head1 ACKNOWLEDGEMENTS

=head1 LICENSE AND COPYRIGHT

This software is Copyright (c) 2023 by LNATION.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut

1; # End of Rope
