--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/Common.pm	Tue Jul 14 12:54:37 2009 +0400
@@ -0,0 +1,282 @@
+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;
\ No newline at end of file