package Common;
use strict;
no strict 'refs';

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(&ACCESS_NONE &ACCESS_READ &ACCESS_WRITE &ACCESS_ALL &DeclareProperty &DumpCaller &PropertyList &CloneObject);

our $Debug;

$Debug = 1 if not defined $Debug;

my %ListProperties;
my %GlobalContext;

1;

sub ACCESS_NONE () { 0 }
sub ACCESS_READ () { 1 }
sub ACCESS_WRITE () { 2 }
sub ACCESS_ALL () {ACCESS_READ | ACCESS_WRITE}

sub PropertyList {
	return $ListProperties{ref($_[0]) || $_[0] || caller} || {};
}

sub DeclareProperty {
	my ($attrName,$accessRights,%Mutators) = @_;
	
	my $Package = caller;
	my $Method = $Package.'::'.$attrName;
	my $fldName;
	
	my $getMutator = $Mutators{'get'};
	my $setMutator = $Mutators{'set'};
	
	($fldName = $Method) =~ s/:+/_/g;
	
	$ListProperties{$Package} = {} if not exists $ListProperties{$Package};
	$ListProperties{$Package}->{$attrName} = $fldName;
	
	if ($Debug) {
		*$Method = sub {
			my $this = shift;
			
			die new Exception( 'too many args ['.scalar(@_).'\]' , "'$Method' called from: ".DumpCaller() ) if (@_ > 1);
			
			my $Rights = $accessRights;
			$Rights = ACCESS_ALL if $Package eq caller;
			
			if (@_){
				die new Exception("access denied 'write $Method'", "'$Method' called from: ".DumpCaller()) if not $Rights & ACCESS_WRITE;
				if (defined $setMutator) {
					&$setMutator($this,$fldName,shift);
				} else {
					$this->{$fldName} = $_[0];
				}
				
			} elsif (defined wantarray) {
				die new Exception("access denied 'read $Method'", "'$Method' called from: ".DumpCaller()) if not $Rights & ACCESS_READ;
				if (defined $getMutator) {
					&$getMutator($this,$fldName);
				} else {
					if (wantarray){
						if(ref $this->{$fldName} eq 'ARRAY' ) {
							return @{$this->{$fldName}};
						} elsif (not exists $this->{$fldName}) {
							return;
						} else {
							return $this->{$fldName};
						}
					} else {
						return $this->{$fldName};
					}
				}
			} else {
				undef;
			}
		};
		*$Method = \$fldName;
	} else {
		*$Method = sub {
			my $this = shift;
			#return undef if @_ > 1;
			#my $Rights = $accessRights;
			#$Rights = ACCESS_ALL if $Package eq caller;
			
			if (@_){
			#	return undef if not $Rights & ACCESS_WRITE;
				if (defined $setMutator) {
					&$setMutator($this,$fldName,shift);
				} else {
					$this->{$fldName} = shift;
				}
			} elsif (defined wantarray) {
			#	return undef if not $Rights & ACCESS_READ;
				if (defined $getMutator) {
					&$getMutator($this,$fldName);
				} else {
					if (wantarray){
						if(ref $this->{$fldName} eq 'ARRAY' ) {
							return @{$this->{$fldName}};
						} elsif (not defined $this->{$fldName}) {
							return;
						} else {
							return $this->{$fldName};
						}
					} else {
						return $this->{$fldName};
					}
				}
			} else {
				undef;
			}
		};
		*$Method = \$fldName;
	}
}

sub DumpCaller {
	return join(" ",(caller($_[0]))[1,2],(caller($_[0]+1))[3]);
}

sub Owner {
	return undef if not tied $_[0];
	return undef if not tied($_[0])->UNIVERSAL::can('owner');
	return tied($_[0])->owner();
};

sub CloneObject {
	my $object = shift;
	if (ref $object == undef) {
		return $object;
	} elsif (ref $object eq 'SCALAR') {
		return \CloneObject(${$object});
	} elsif (ref $object eq 'ARRAY') {
		return [map{CloneObject($_)}@{$object}];
	} elsif (ref $object eq 'HASH') {
		my %clone;
		while (my ($key,$value) = each %{$object}) {
			$clone{$key} = CloneObject($value);
		}
		return \%clone;
	} elsif (ref $object eq 'REF') {
		return \CloneObject(${$object});
	} else {
		if ($object->can('Clone')) {
			return $object->Clone();
		} else {
			die new Exception('Object doesn\'t supports cloning');
		}
	}
}

package Exception;
use base qw(IMPL::Exception);

package Persistent;
import Common;

sub newSurogate {
	my $class = ref($_[0]) || $_[0];
	return bless {}, $class;
}
sub load {
	my ($this,$context) = @_;
	die new Exception("invalid deserialization context") if ref($context) ne 'ARRAY';
	die new Exception("This is not an object") if not ref $this;
	
	my %Props = (@{$context});
	foreach my $BaseClass(@{ref($this).'::ISA'}) {
		while (my ($key,$value) = each %{PropertyList($BaseClass)}) {
			$this->{$value} = $Props{$value} if exists $Props{$value};
		}
	}
	
	while (my ($key,$value) = each %{PropertyList(ref($this))}) {
		$this->{$value} = $Props{$key} if exists $Props{$key};
	}
	return 1;
}
sub save {
	my ($this,$context) = @_;
	
	foreach my $BaseClass(@{ref($this).'::ISA'}) {
		while (my ($key,$value) = each %{PropertyList($BaseClass)}) {
			$context->AddVar($value,$this->{$value});
		}
	}
	
	while (my ($key,$value) = each %{PropertyList(ref($this))}) {
		$context->AddVar($key,$this->{$value});
	}
	return 1;
}

sub restore {
    my ($class,$context,$surogate) = @_;
    my $this = $surogate || $class->newNewSurogate;
    $this->load($context);
    return $this;
}

package Object;
import Common;

sub new {
  my $class = shift;
  my $self = bless {}, ref($class) || $class;
  $self->CTOR(@_);
  return $self;
}

sub cast {
  return bless {}, ref $_[0] || $_[0];
}

our %objects_count;
our %leaked_objects;

sub CTOR {
	my $this= shift;
	$objects_count{ref $this} ++ if $Debug;
	my %args = @_ if scalar (@_) > 0;
	return if scalar(@_) == 0;
	
	warn "invalid args in CTOR. type: ".(ref $this) if scalar(@_) % 2 != 0;
	my @packages = (ref($this));
	my $countArgs = int(scalar(@_) / 2);
	#print "Set ", join(', ',keys %args), "\n";
	LOOP_PACKS: while(@packages) {
		my $package = shift @packages;
		#print "\t$package\n";
		my $refProps = PropertyList($package);
		foreach my $name (keys %{$refProps}) {
			my $fld = $refProps->{$name}; 
			if (exists $args{$name}) {
				$this->{$fld} = $args{$name};
				#print "\t$countArgs, $name\n";
				delete $args{$name};
				$countArgs --;
				last LOOP_PACKS if $countArgs < 1;
			} else {
				#print "\t-$name ($fld)\n";
			}
		}
		push @packages, @{$package.'::ISA'};
	}
}

sub Dispose {
	my $this = shift;
	
	if ($Debug and UNIVERSAL::isa($this,'HASH')) {
		my @keys = grep { $this->{$_} and ref $this->{$_} } keys %{$this};
		warn "not all fields of the object were deleted\n".join("\n",@keys) if @keys;
	}
	
	bless $this,'Object::Disposed';
}

our $MemoryLeakProtection;

sub DESTROY {
	if ($MemoryLeakProtection) {
		my $this = shift;
		warn sprintf("Object leaks: %s of type %s %s",$this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
	}
}

package Object::Disposed;
our $AUTOLOAD;
sub AUTOLOAD {
	return if $AUTOLOAD eq __PACKAGE__.'::DESTROY';
	die new Exception('Object have been disposed',$AUTOLOAD);
}

END {
	$MemoryLeakProtection = 0 if not $Debug;
}
1;