#
# Copyright (c) 2004 RA Micro Products & Services Limited
# Author: Rob Quince
# EMail : robq@fiendish-demon-co-uk
# 
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in all
# copies of this software.
# 
# IN NO EVENT SHALL RA MICRO PRODUCTS & SERVICES LTD BE LIABLE TO ANY
# PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
# DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION,
# EVEN IF RA MICRO PRODUCTS & SERVICES LTD HAS BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# 
# RA MICRO PRODUCTS & SERVICES LTD SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE
# PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND
# RA MICRO PRODUCTS & SERVICES LTD HAS NO OBLIGATION TO PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
# 

package Persister;

use strict;

my $XMLcapable = 1;

eval {
	require XML::Parser::PerlSAX;
};
if ( $@ ) {
	$XMLcapable = 0;
}

my $indent;
my %refs;
my @path;
my $inHashVal;
my $nodes;

=head1 NAME

Persister - package to dump Perl variables

=head1 SYNOPSIS

 use Persister;

 Persister->save( 'filename', \%somehash, 'somehash' );
 Persister->save( 'othername', $object, 'object', 1 );
 $object = Persister->readXML( 'othername' );

=head1 AUTHOR

 Robert Quince (robq@fiendish-demon-co-uk)

=head1 DESCRIPTION

This package allows Perl variables to be dumped
either in a format that can be read straight back into a script
via the C<eval> function, or in an XML tagged format that requires
interpretation to reconstruct the variable. The tagged format
is more suited to large variables that would otherwise take a
significant amount of time to eval.

It will only dump a reference to a variable, this is so that any
type of variable can be passed and treated in the same manner.

The passed in reference can be of any of the following types:

    * scalar
    * array
    * hash
    * blessed object

The package will also print references to typeglobs, but these
are not dealt with very well as they are references to B<all>
variables of the given name. The output for a glob of the form
C<\*SOMEVAR> will look like C<\*{<package>::SOMEVAR}>. Dumping
globs should be avoided as they cannot be reconstructed.

The Perl C<eval> mode output file is split into two sections, one
for the "body" of the dumped variable, and one for any circular
references within the structure. In the main body, any circular
references are indicated by a value 'ref', the actual value of
these are then set at the end of the file by a simple assignment
statement.

The first line of the output file is an assignment statement of
the form:

    $<name> = <val>

where the <val> is appropriate to the type of variable referenced,
and <name> is whatever was passed to the C<save> method. When the
dumped file is read back in to a script, care must be taken to
ensure that a variable $<name> is predeclared if the script is
using the C<strict> pragma.

The XML mode output file makes use of node reference numbers to
handle the circular references during reconstruction.

For both output modes tabbed indentation is used to indicate levels
of array and hash.

If a file name of zero length is given then output will be written
to the C<STDOUT> stream instead.

=head1 METHODS

=over 4

=cut

###################################################################

=item Persister->readXML

 Input:    $file    - name of the output file

 This method reads the given XML file and reconstructs the variable
 contained within. The method depends on the availability of the
 C<XML::Parser::PerlSAX> module.

 Return:   reconstructed variable upon success, undef otherwise

=cut

sub readXML {
	unless ( $XMLcapable ) {
		print STDERR "Persister::readXML: XML input requested, but no XML capability present\n";
		return undef;
	}

	my $proto   = shift if ( $_[0] eq __PACKAGE__ );
	my $fName   = shift;
	my $builder = new PersisterXMLReader();
	my $parser  = XML::Parser::PerlSAX->new( DocumentHandler => $builder ) || return undef;
	my $xml     = $parser->parse( Source => { SystemId => $fName } ) || return undef;

	return $xml->{ object };
}

###################################################################

=item Persister->save

 Input:    $file    - name of the output file
           $thing   - reference to a variable
           $name    - name of variable to put in output
           $mode    - undef or 0 for Perl mode, else XML mode

 This method dumps the referenced variable to the named file,
 $file, calling it C<$name>. If $file has no length, then output
 will be written to STDOUT instead of to a file.

 Return:   true upon success, false otherwise

=cut

sub save {
	my $proto   = shift if ( $_[0] eq __PACKAGE__ );
	my $file    = shift;
	my $thing   = shift;
	my $name    = shift;
	my $XMLMode = shift;
	my $fh;

	# Expects a ref to something to save
	# and it's name (so that it can be
	# eval loaded later on) from the
	# file given

	unless ( ref $thing ) {
		print STDERR "Persister::save: Variable '$thing' not reference\n";
		return 0;
	}

	if ( length $file ) {
		unless ( open( FILE, ">$file" ) ) {
			print STDERR "Persister::save: cannot create save file '$file'\n";
			return 0 ;
		}
		$fh = *FILE;
	} else {
		$fh = *STDOUT;
	}

	my $saveFH = select $fh;
	$| = 1;
	select $saveFH;

	return _saveAsPerl( $fh, $thing, $name ) unless $XMLMode;
	return _saveAsXML( $fh, $thing, $name );
}

###################################################################

sub _saveAsPerl {
	my $fh       = shift;
	my $thing    = shift;
	my $name     = shift;
	my $retVal;

	push @path, "\$$name->";

	print $fh "\$$name = ";
	$retVal = _dumpPerlValue( $fh, $thing );
	print $fh ";\n";

	# Okay, now need to print the table of
	# paths and refs so that they get set

	foreach my $ref ( values %refs ) {
		foreach my $path ( @{ $ref->{ paths } } ) {
			print $fh "$path = $$ref{value};\n";
		}
	}

	close( $fh ) unless ( fileno $fh == fileno STDOUT );

	# Re-Initialise for multi-use
	$indent    = '';
	%refs      = ( );
	@path      = ( );
	$nodes     = 0;
	$inHashVal = 0;

	return $retVal;
}

###################################################################

sub _dumpPerlValue {
	my $fh    = shift;
	my $value = shift;

	if ( ref $value ) {
		_dumpPerlRef( $fh, $value, ref $value );
	} else {

		if ( defined $value ) {

			$value =~ s/\\/\\\\/g;
			$value =~ s/\$/\\\$/g;
			$value =~ s/"/\\"/g;
			$value =~ s/\n/\\n/g;
			$value =~ s/\r/\\r/g;
			$value =~ s/\t/\\t/g;

			print $fh qq("$value");
		} else {
			print $fh "undef";
		}
	}
}

###################################################################

sub _dumpPerlRef {
	my $fh    = shift;
	my $thing = $_[0];
	my $ref   = $_[1];

	my $pad = "\t" x $indent;

	# If the ref is not blessed, then need
	# to determine whether it has been seen
	# before, if so print the ref to it
	# otherwise store and print the real
	# thing

	unless ( $thing =~ /=/ ) {
		if ( defined $refs{ $thing } ) {
			# Seen this thing before, so
			# remember the path to it

			push @{ $refs{ $thing }->{ paths } }, join( '', @path );

			# Next print a place holder

			print $fh "'ref'";

			return;
		} else {
			$refs{ $thing } = {
				paths => [ ],
				value => join( '', @path ),
			};
		}
	}

	if ( $ref eq 'HASH' ) {
		print $fh "{\n";
		_dumpPerlHash( $fh, %$thing );
		print $fh "$pad}";
	} elsif ( $ref eq 'ARRAY' ) {
		print $fh "[\n";
		_dumpPerlArray( $fh, @$thing );
		print $fh "$pad]";
	} elsif ( $ref eq 'SCALAR' ) {
		print $fh "\\";
		_dumpPerlValue( $fh, $$thing );
	} elsif ( $ref eq 'GLOB' ) {
		print $fh "\\*\{";
		_dumpPerlGlob( $fh, $_[0] );
		print $fh "}";
	} elsif ( $thing =~ /=/ ) {
		# A blessed ref then
		my $sort = ( $thing =~ /=([^\(]+)/ )[ 0 ];
		print $fh "bless( ";
		_dumpPerlRef( $fh, $thing, $sort );
		print $fh ", '$ref' )";
	} else {
		print $fh $thing;		
	}

	return 1;
}

###################################################################

sub _dumpPerlGlob {
	my $fh = shift;
	print $fh ( "'",*{$_[0]}{PACKAGE},'::',*{$_[0]}{NAME},"'" );
}

###################################################################

sub _dumpPerlArray {
	my $fh    = shift;
	my @array = @_;

	my $pad = "\t" x ++$indent;

	for( my $i = 0; $i < @array; $i++ ) {
		push @path, "[$i]";
		print $fh $pad;
		_dumpPerlValue( $fh, $array[ $i ] );
		print $fh ",\n";
		pop @path;
	}

	$indent--;
}

###################################################################

sub _dumpPerlHash {
	my $fh   = shift;
	my %hash = @_;

	my $pad = "\t" x ++$indent;

	foreach my $key ( sort keys %hash ) {
		push @path, "\{'$key'}";
		print $fh "$pad'$key' => ";
		_dumpPerlValue( $fh, $hash{ $key } );
		print $fh ",\n";
		pop @path;
	}
	$indent--;
}

###################################################################

sub _saveAsXML {
	my $fh       = shift;
	my $thing    = shift;
	my $name     = shift;
	my $retVal;

	push @path, "\$$name->";

	print $fh "<?xml version=\"1.0\" ?>\n";
	print $fh "<PERSIST>\n";
	$retVal = _dumpXMLValue( $fh, $thing );

#	# Okay, now need to print the table of
#	# paths and refs so that they get set
#
#	foreach my $ref ( values %refs ) {
#		foreach my $path ( @{ $ref->{ paths } } ) {
#			print $fh "$path = $$ref{value};\n";
#		}
#	}

	print $fh "</PERSIST>\n";
	close( $fh ) unless ( fileno $fh == fileno STDOUT );

	# Re-Initialise for multi-use
	$indent    = '';
	%refs      = ( );
	@path      = ( );
	$nodes     = 0;
	$inHashVal = 0;

	return $retVal;
}

###################################################################

sub _dumpXMLValue {
	my $fh    = shift;
	my $value = shift;

	if ( ref $value ) {
		_dumpXMLRef( $fh, $value, ref $value );
	} else {
		$value =~ s/\$/\\\$/g;

		if ( defined $value ) {
			print $fh ( _encodeStr($value) );
		} else {
			print $fh "<UNDEF/>";
		}
	}
}

###################################################################

sub _dumpXMLRef {
	my $fh    = shift;
	my $thing = $_[0];
	my $ref   = $_[1];

	my $pad = "\t" x $indent;

	# If the ref is not blessed, then need
	# to determine whether it has been seen
	# before, if so print the ref to it
	# otherwise store and print the real
	# thing

	unless ( $thing =~ /=/ ) {
		if ( defined $refs{ $thing } ) {
			# Seen this thing before, so
			# remember the path to it

#			push @{ $refs{ $thing }->{ paths } }, join( '', @path );

			# Next print a place holder

			if ( $inHashVal ) {
				print $fh "<REF node=\"".$refs{ $thing }->{ value }."\"/>";
			} else {
				print $fh "$pad<REF node=\"".$refs{ $thing }->{ value }."\"/>\n";
			}

			return;
		}

		$refs{ $thing } = {
			paths => [ ],
			value => $nodes,
		};
	}

	if ( $ref eq 'HASH' ) {
		if ( $inHashVal ) {
			print $fh "<HASH node=\"".$nodes++."\">\n";
			_dumpXMLHash( $fh, %$thing );
			print $fh "$pad</HASH>";
		} else {
			print $fh "$pad<HASH node=\"".$nodes++."\">\n";
			_dumpXMLHash( $fh, %$thing );
			print $fh "$pad</HASH>\n";
		}

	} elsif ( $ref eq 'ARRAY' ) {
		if ( $inHashVal ) {
			print $fh "<ARRAY node=\"".$nodes++."\">\n";
			_dumpXMLArray( $fh, @$thing );
			print $fh "$pad</ARRAY>";
		} else {
			print $fh "$pad<ARRAY node=\"".$nodes++."\">\n";
			_dumpXMLArray( $fh, @$thing );
			print $fh "$pad</ARRAY>\n";
		}

	} elsif ( $ref eq 'SCALAR' ) {
		if ( $inHashVal ) {
			print $fh "<SCALAR node=\"".$nodes++."\">";
			_dumpXMLValue( $fh, $$thing );
			print $fh "</SCALAR>\n";
		} else {
			print $fh "$pad<SCALAR node=\"".$nodes++."\">\n";
			_dumpXMLValue( $fh, $$thing );
			print $fh "$pad</SCALAR>\n";
		}

	} elsif ( $ref eq 'GLOB' ) {
		print $fh "$pad<GLOB>\n";
		_dumpXMLGlob( $fh, $_[0] );
		print $fh "$pad</GLOB>\n";

	} elsif ( $thing =~ /=/ ) {
		# A blessed ref then
		my $sort = ( $thing =~ /=([^\(]+)/ )[ 0 ];

		if ( $inHashVal ) {
			print $fh "<BLESS class=\""._encodeStr($ref)."\">";
			_dumpXMLRef( $fh, $thing, $sort );
			print $fh "</BLESS>";
		} else {
			print $fh "$pad<BLESS class=\""._encodeStr($ref)."\">";
			_dumpXMLRef( $fh, $thing, $sort );
			print $fh "$pad</BLESS>\n";
		}

	} else {
		print $fh ( _encodeStr($thing), "\n" );
	}

	return 1;
}

###################################################################

sub _dumpXMLGlob {
	my $fh = shift;
	print $fh ( "'",*{$_[0]}{PACKAGE},'::',*{$_[0]}{NAME},"'\n" );
}

###################################################################

sub _dumpXMLArray {
	my $fh    = shift;
	my @array = @_;

	my $pad = "\t" x ++$indent;

	for( my $i = 0; $i < @array; $i++ ) {
		push @path, "[$i]";

		if ( $inHashVal ) {
			print $fh "$pad<ARRAYSUB node=\"".$nodes++."\">";
			_dumpXMLValue( $fh, $array[ $i ] );
			print $fh "</ARRAYSUB>\n";
		} else {
			print $fh "$pad<ARRAYSUB node=\"".$nodes++."\">\n";
			_dumpXMLValue( $fh, $array[ $i ] );
			print $fh "$pad</ARRAYSUB>\n";
		}

		pop @path;
	}

	$indent--;
}

###################################################################

sub _dumpXMLHash {
	my $fh   = shift;
	my %hash = @_;

	my $pad = "\t" x ++$indent;

	foreach my $key ( sort keys %hash ) {
		push @path, "\{'$key'}";

		print $fh "$pad<HASHVAL key=\""._encodeStr($key)."\" node=\"".$nodes++."\">";
		$inHashVal++;
		_dumpXMLValue( $fh, $hash{ $key }, );
		$inHashVal--;
		print $fh "</HASHVAL>\n";
		pop @path;
	}
	$indent--;
}

###################################################################

sub _encodeStr {
	my $str = shift;

	$str =~ s/"/&quot;/g;
	$str =~ s/</&lt;/g;
	$str =~ s/>/&gt;/g;
	$str =~ s/&/&amp;/g;

	return $str;
}

=back

=cut

package PersisterXMLReader;

# Change package to an internal one that
# just provides the means to parse the XML
# text version of the index

use vars qw( $DEBUG );

###################################################################

sub new {
	my $proto = shift;
	my $class = ref $proto || $proto;
	my $self  = {
		inEl		=> [],
		nodes		=> [],
		blessings	=> [],
		curNode		=> [],
		curRef		=> undef,
		hashKeys	=> [],
		object		=> undef,
	};
	$self = bless( $self, $class );
	return $self;
}

###################################################################

sub start_document {
	my $self = shift;
}

###################################################################

sub end_document {
	my $self = shift;
}

###################################################################
# Valid types of element are :
# ARRAY
# ARRAYSUB
# BLESS
# GLOB
# HASH
# HASHVAL
# SCALAR
# UNDEF

sub start_element {
	my $self  = shift;
	my $args  = shift;
	my $name  = $args->{ Name };
	my $attrs = $args->{ Attributes };
	my $aScalar;

	if ( $DEBUG ) {
		print "$name\n";
		foreach my $key ( keys %$attrs ) {
			print "$key => $$attrs{$key}\n";
		}
	}

	if ( $name eq 'ARRAY' ) {
		push @{ $self->{ curNode } }, $self->_createNode( $attrs->{ node }, [] );

	} elsif ( $name eq 'HASH' ) {
		push @{ $self->{ curNode } }, $self->_createNode( $attrs->{ node }, {} );

	} elsif ( $name eq 'SCALAR' ) {
		push @{ $self->{ curNode } }, $self->_createNode( $attrs->{ node }, \$aScalar );

	} elsif ( $name eq 'HASHVAL' ) {
		push @{ $self->{ hashKeys } }, $attrs->{ key };

	} elsif ( $name eq 'BLESS' ) {
		push @{ $self->{ blessings } }, $attrs->{ class };

	} elsif ( $name eq 'UNDEF' ) {
		$self->{ curData } = undef;

	} elsif ( $name eq 'REF' ) {
		$self->{ curRef } = $self->{ nodes }->[ $attrs->{ node } ];
	}

	push @{ $self->{ inEl } }, $name;

	if ( $DEBUG ) {
		if ( $self->{hashKeys}->[-1] eq 'configs' ) {
			Persister->save( '', $self->{hashKeys}, 'haskeys' );
			Persister->save( '', $self->{curNode}, 'curnode' );
		}
	}
}

###################################################################

sub _createNode {
	my $self    = shift;
	my $nodeNum = shift;
	my $data    = shift;

	# Bless this thing into the latest class

	if ( $self->{ inEl }->[ -1 ] eq 'BLESS' ) {
		$data = bless( $data, $self->{ blessings }->[ -1 ] );
	}

	$self->{ object } = $data unless ( defined $self->{ object } );

	$self->{ nodes }->[ $nodeNum ] = $data if ( defined $nodeNum );

	return $data;
}

###################################################################

sub end_element {
	my $self = shift;
	my $args = shift;
	my $node;

	pop @{ $self->{ inEl } };

	my $elName = $self->{ inEl }->[ -1 ];

	if ( $args->{ Name } =~ /^(ARRAY|HASH)$/ ) {
		$node = pop @{ $self->{ curNode } } unless ( $elName eq 'BLESS' );

	} elsif ( $args->{ Name } eq 'ARRAYSUB' ) {
		if ( exists $self->{ curData } ) {
			push @{ $self->{ curNode }->[ -1 ] }, $self->{ curData };
			delete $self->{ curData };
		}

	} elsif ( $args->{ Name } eq 'HASHVAL' ) {
		if ( exists $self->{ curData } ) {
			$self->{ curNode }->[ -1 ]->{ pop @{ $self->{ hashKeys } } } = $self->{ curData };
			delete $self->{ curData };
		}

	} elsif ( $args->{ Name } eq 'SCALAR' ) {
		if ( exists $self->{ curData } ) {
			${ $self->{ curNode }->[ -1 ] } = $self->{ curData };
			delete $self->{ curData };
		}
		$node = pop @{ $self->{ curNode } } unless ( $elName eq 'BLESS' );

	} elsif ( $args->{ Name } eq 'REF' ) {
		$node = $self->{ curRef };
		undef $self->{ curRef };

	} elsif ( $args->{ Name } eq 'UNDEF' ) {
		if ( exists $self->{ curData } ) {
			$node = $self->{ curData };
			delete $self->{ curData };
		}

	} elsif ( $args->{ Name } eq 'BLESS' ) {
		pop @{ $self->{ blessings } };
		$node = pop @{ $self->{ curNode } };
	}

	if ( $elName eq 'HASHVAL' ) {
		$self->{ curNode }->[ -1 ]->{ pop @{ $self->{ hashKeys } } } = $node;

	} elsif ( $elName eq 'ARRAYSUB' ) {
		push @{ $self->{ curNode }->[ -1 ] }, $node;

	}
}

###################################################################

sub characters {
	my $self = shift;
	my $args = shift;
	my $data = $args->{ Data };

	my $elName = $self->{ inEl }->[ -1 ];
	return unless ( $elName =~ /^(ARRAYSUB|HASHVAL|SCALAR)$/ );

	if ( exists $self->{ curData } ) {
		$self->{ curData } .= $data;
	} else {
		$self->{ curData } = $data;
	}

	print "Data:\t'$data'\n" if ( $DEBUG );
}

###################################################################

sub start_cdata {
	my $self = shift;
	my $args = shift;

	print "CData:\t\n" if ( $DEBUG );
}

###################################################################

sub end_cdata {
	my $self = shift;
	my $args = shift;

	print "\t/CData\n" if ( $DEBUG );
}

1;

__END__