view release on metacpan or  search on metacpan

Eroot.pm  view on Meta::CPAN

	my %id = ();

	while( @objs ){
		$obj = shift @objs;
		next if( ! defined $obj );
		$class = "";
		"$obj" =~ /^([^=]+)=/o && do { $class = $1 };
		if( "$obj" =~ /([A-Z]+)\((0x[a-f0-9]+)\)$/o ){
			($type,$ident) = ($1,$2);
			next if( defined $id{$ident} );
			$id{$ident}++;
			push( @s, "end $ident" );

			# Suspend the object.
			eval { $obj->suspend } if( $class ne '' );

			if( $type eq 'ARRAY' ){
				if( @$obj ){
					$self->StoreArray( $obj, $ident, \@s, \@objs );
				}
			}
			elsif( $type eq 'HASH' ){
				if( keys %$obj ){
					$self->StoreHash( $obj, $ident, \@s, \@objs );
				}
			}
			# The following also catches anything
			# you thought was REF (REF is actually SCALAR^2).
			elsif( $type eq 'SCALAR' ){
				$self->StoreScalar( $obj, $ident, \@s, \@objs );
			}
			else{
				die "Don't know how to handle $type $obj";
			}
			if( defined $roots->{$ident} ){
				$n = $id2name->{$ident};
				push( @s, "root $ident $n" );
				$roots->{$ident} = undef;
			}
			push( @s, "object $ident $type $class" );
		}
		else{
			warn "Eroot: Unable to recognize object $obj";
		}
	}
	$self->DumpStack( \@s )			if $EROOT::DumpStack;
	$self->WriteStack( $key, $name, \@s )	if $EROOT::WriteStack;
}


# Turn the stack into perl code.
# This will create a method named Continue in the EROOT class.
# This assumes that keys and values for the "objects" can be safely
# represented as text within single quotes.
#

## private
sub WriteStack {
	my $self = shift;
	my( $key, $name, $s ) = @_;
	my $fh = (caller)[0] . "::$name";
	my $i = @$s;
	my( $type, @v, $v );
	my( $junk, $word, $ident, $stuff );
	my @roots = ();
	my @keep = ();
	my @keepwake = ();
	my @wake = ();
	my %wake = ();
	my( $e1, $e2, $elem, $whack );
	my @delayed = ();

	open( $fh, ">$name" ) || do{
		warn "Eroot: Cannot save objects, unable to write to file $name";
		return;
	};
	print $fh "#KEY:$key\n";
	print $fh "# Persistent objects\n";
	print $fh "sub EROOT::Continue {\n";
	print $fh "  my \$self = shift;\n";
	print $fh "  my \%ref = ();\n";
	print $fh "  die \"These persistent objects (key=$key) do not belong to this application.\\n\"\n";
	print $fh "    if( \$self->{\'key\'} ne \'$key\' );\n";
	while( $i-- > 0 ){
		($junk, $word, $ident, $stuff) =
			split( /^(\w+) ([^\s]+) ?/o, $s->[$i], 2 );
		if( $word eq 'object' ){
			@v = split( ' ', $stuff );
			$e1 = $e2 = $type = $whack = '';
			if( $v[0] eq 'ARRAY' ){
				$e1 = "[";
				$e2 = "]";
				$type = " = []";
			}
			elsif( $v[0] eq 'HASH' ){
				$e1 = "{\'";
				$e2 = "\'}";
				$type = " = {}";
			}
			elsif( $v[0] eq 'SCALAR' ){
				$whack = "\\";
			}
			if( defined $v[1] ){
				push( @wake, "$ident!\$self->Resume( \'$v[1]\', \$ref{\'$ident\'} );" );
				$wake{$ident} = $#wake;
			}
			print $fh "  {\n    my \$x$type;\n";
		}
		elsif( $word eq 'root' ){
			push( @keep, "\$self->Keep( \'$stuff\', \$ref{\'$ident\'} );" );
			if( $wake{$ident} ){
				push( @keepwake, "\$self->Resume( \'$v[1]\', \$ref{\'$ident\'} );" );
				delete $wake{$ident};
			}
		}
		elsif( $word eq 'end' ){
			print $fh "    \$ref{\'$ident\'} = $whack\$x;\n  }\n";
		}
		elsif( $word eq 'ref' ){
			($junk, @v) = split( /^\(([^)]*)\) /o, $stuff, 0 );
			$elem = ($v[0] ne '') ? "->$e1$v[0]$e2" : "";