File Coverage

blib/lib/DBIx/Admin/BackupRestore.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package DBIx::Admin::BackupRestore;

# Documentation:
#	POD-style documentation is at the end. Extract it with pod2html.*.
#
# Reference:
#	Object Oriented Perl
#	Damian Conway
#	Manning
#	1-884777-79-1
#	P 114
#
# Note:
#	o Tab = 4 spaces || die.
#
# Author:
#	Ron Savage
#	Home page: http://savage.net.au/index.html
#
# Licence:
#	Australian copyright (c) 2003 Ron Savage.
#
#	All Programs of mine are 'OSI Certified Open Source Software';
#	you can redistribute them and/or modify them under the terms of
#	The Artistic License, a copy of which is available at:
#	http://www.opensource.org/licenses/index.html

use strict;
use warnings;

use Carp;
use File::Spec;
use XML::Records;

require 5.005_62;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use DBIx::Admin::BackupRestore ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);
our $VERSION = '1.17';

my(%_decode_xml) =
(
	'&'		=> '&',
	'<'		=> '<',
	'>'		=> '>',
	'"'	=> '"',
);

my(%_encode_xml) =
(
	'&' => '&',
	'<' => '<',
	'>' => '>',
	'"' => '"',
);

# -----------------------------------------------

# Preloaded methods go here.

# -----------------------------------------------

# Encapsulated class data.

{
	my(%_attr_data) =
	(
		_clean					=> 0,
		_croak_on_error			=> 1,
		_dbh					=> '',
		_dbi_catalog			=> undef,
		_dbi_schema				=> undef,
		_dbi_table				=> '%',
		_dbi_type				=> 'TABLE',
		_fiddle_timestamp		=> 1,
		_odbc					=> 0,
		_output_dir_name		=> '',
		_rename_columns			=> {},
		_rename_tables			=> {},
		_skip_schema			=> [],
		_skip_tables			=> [],
		_transform_tablenames	=> 0,
		_verbose				=> 0,
	);

	sub _default_for
	{
		my($self, $attr_name) = @_;

		$_attr_data{$attr_name};
	}

	sub _standard_keys
	{
		keys %_attr_data;
	}

}	# End of encapsulated class data.

# -----------------------------------------------

sub adjust_case
{
	my($self, $s) = @_;

	$$self{'_dbh'}{'FetchHashKeyName'} eq 'NAME_uc' ? uc $s : $$self{'_dbh'}{'FetchHashKeyName'} eq 'NAME_lc' ? lc $s : $s;

}	# End of adjust_case.

# -----------------------------------------------

sub backup
{
	my($self, $database) = @_;

	Carp::croak('Missing parameter to new(): dbh') if (! $$self{'_dbh'});

	$$self{'_quote'}	= $$self{'_dbh'} ? $$self{'_dbh'} -> get_info(29) : ''; # SQL_IDENTIFIER_QUOTE_CHAR.
	$$self{'_tables'}	= $$self{'_odbc'} ? $self -> odbc_tables() : $self -> tables();
	$$self{'_xml'}		= qq|\n|;
	$$self{'_xml'}		.= qq|\n|;

	my($column_name);
	my($data, $display_sql, $display_table);
	my($field);
	my($i);
	my($output_column_name);
	my($sql, $sth);
	my($table_name);
	my($xml);

	for $table_name (@{$$self{'_tables'} })
	{
		$self -> process_table('backup', $table_name);

		next if ($$self{'_skipping'});

		$display_table	= $self -> adjust_case($$self{'_current_table'});
		$sql			= "select * from $$self{'_current_table'}";
		$display_table	= $$self{'_rename_tables'}{$display_table} ? $$self{'_rename_tables'}{$display_table} : $display_table;
		$display_sql	= "select * from $display_table";
		$display_sql	= $self -> adjust_case($display_sql);
		$display_sql	= $self -> encode_xml($display_sql);
		$$self{'_xml'}	.= qq|\t\n|;
		$sth			= $$self{'_dbh'} -> prepare($sql) || Carp::croak("Can't prepare($sql): $DBI::errstr");

		eval{$sth -> execute()};

		if ($@)
		{
			Carp::croak("Can't execute($sql): $DBI::errstr") if ($$self{'_croak_on_error'});

			print STDERR "$@" if ($$self{'_verbose'});

			next;
		}

		$column_name							= $$sth{$$self{'_dbh'}{'FetchHashKeyName'} };
		$$self{'_column_name'}{$display_table}	= [map{$i = $$self{'_rename_columns'}{$_} ? $$self{'_rename_columns'}{$_} : $_; $i =~ tr/ /_/; $i} sort @$column_name];

		while ($data = $sth -> fetch() )
		{
			$i		= - 1;
			$xml	= '';

			for $field (@$data)
			{
				$i++;

				if (defined($field) )
				{
					$field				=~ tr/\x20-\x7E//cd if ($$self{'_clean'});
					$output_column_name	= $$self{'_rename_columns'}{$$column_name[$i]} ? $$self{'_rename_columns'}{$$column_name[$i]} : $$column_name[$i];
					$output_column_name	=~ tr/ /_/;
					$xml				.= "\t\t\t<$output_column_name>" . $self -> encode_xml($field) . '\n";
				}
			}

			$$self{'_xml'} .= "\t\t\n$xml\t\t\n" if ($xml);
		}

		Carp::croak("Can't fetchrow_hashref($sql): $DBI::errstr") if ($DBI::errstr);

		$$self{'_xml'} .= "\t\n";
	}

	$$self{'_xml'} .= "\n";

}	# End of backup.

# -----------------------------------------------

sub decode_xml
{
	my($self, $s) = @_;

	for my $key (keys %_decode_xml)
	{
		$s =~ s/$key/$_decode_xml{$key}/eg;
	}

	$s;

}	# End of decode_xml.

# -----------------------------------------------

sub encode_xml
{
	my($self, $str)	= @_;
	$str			=~ s/([&<>"])/$_encode_xml{$1}/eg;

	$str;

}	# End of encode_xml.

# -----------------------------------------------

sub get_column_names
{
	my($self) = @_;

	$$self{'_column_name'};

}	# End of get_column_names.

# -----------------------------------------------

sub new
{
	my($class, %arg)	= @_;
	my($self)			= bless({}, $class);

	for my $attr_name ($self -> _standard_keys() )
	{
		my($arg_name) = $attr_name =~ /^_(.*)/;

		if (exists($arg{$arg_name}) )
		{
			$$self{$attr_name} = $arg{$arg_name};
		}
		else
		{
			$$self{$attr_name} = $self -> _default_for($attr_name);
		}
	}

	$$self{'_column_name'}		= {};
	$$self{'_current_schema'}	= '';
	$$self{'_current_table'}	= '';
	$$self{'_database'}			= [];
	$$self{'_key'}				= [];
	$$self{'_output_is_open'}	= 0;
	$$self{'_quote'}			= '';
	$$self{'_restored'}			= {};
	$$self{'_skipped'}			= {};
	$$self{'_skipping'}			= 0;
	@{$$self{'_skip_schema_name'} }{@{$$self{'_skip_schema'} } }	= (1) x @{$$self{'_skip_schema'} };
	@{$$self{'_skip_table_name'} }{@{$$self{'_skip_tables'} } }		= (1) x @{$$self{'_skip_tables'} };
	$$self{'_value'}			= [];
	$$self{'_xml'}				= '';

	return $self;

}	# End of new.

# -----------------------------------------------

sub odbc_tables
{
	my($self) = @_;

	[
		map{s/^$$self{'_quote'}.+?$$self{'_quote'}\.$$self{'_quote'}(.+)$$self{'_quote'}/$1/; $_}
		grep{! /^BIN\$.+\$./}	# Discard 'funny' Oracle table names, like BIN$C544WGedCuHgRAADuk1i5g==$0.
		sort $$self{'_dbh'} -> tables()
	];

}	# End of odbc_tables.

# -----------------------------------------------

sub process_table
{
	my($self, $action, $table_name) = @_;
	$$self{'_current_table'} = $self -> decode_xml($table_name);

	if ( ($$self{'_transform_tablenames'} == 1) && ($$self{'_current_table'} =~ /^(.+?)\.(.+)$/) )
	{
		$$self{'_current_schema'}	= $1;
		$$self{'_current_table'}	= $2;
	}

	if ($$self{'_skip_schema_name'}{$$self{'_current_schema'} } || $$self{'_skip_table_name'}{$$self{'_current_table'} })
	{
		# With restore_in_order we read the input file N times,
		# but we don't want to _report_ the same table N times.
		# Hence the hash $$self{'_skipped'}.

		print STDERR "Skip table: $$self{'_current_table'}. \n" if ($$self{'_verbose'} && ! $$self{'_skipped'}{$$self{'_current_table'} });

		$$self{'_skipping'}								= 1;
		$$self{'_skipped'}{$$self{'_current_table'} }	= 1;
	}
	else
	{
		# With restore_in_order we read the input file N times,
		# but we don't want to _report_ or _restore_ the same table N times.
		# Hence the hash $$self{'_restored'}.

		print STDERR "$action table: $$self{'_current_table'}. \n" if ($$self{'_verbose'} && ! $$self{'_restored'}{$$self{'_current_table'} });

		$$self{'_skipping'}								= 0;
		$$self{'_restored'}{$$self{'_current_table'} }	= 1;
	}

}	# End of process_table.

# -----------------------------------------------

sub restore
{
	my($self, $file_name) = @_;

	Carp::croak('Missing parameter to new(): dbh') if (! $$self{'_dbh'});

	open(INX, $file_name) || Carp::croak("Can't open($file_name): $!");

	my($line);

	while ($line = )
	{
		next if ($line =~ m!^(<\?xml|

		if ($line =~ m!!i)
		{
			$self -> process_table('Restore', $1);
		}
		elsif ( (! $$self{'_skipping'}) && ($line =~ m!!i) )
		{
			# There may be a different number of fields from one row to the next.
			# Remember, only non-null fields are output by method backup().

			$$self{'_key'}		= [];
			$$self{'_value'}	= [];

			while ( ($line = ) !~ m!!i)
			{
				if ($line =~ m!^\s*<(.+?)>(.*?)!i)
				{
					push @{$$self{'_key'} }, $1;

					$self -> transform($1, $self -> decode_xml($2) );
				}
			}

			$self -> write_row();
		}
	}

	close INX;

	[sort keys %{$$self{'_restored'} }];

}	# End of restore.

# -----------------------------------------------

sub restore_in_order
{
	my($self, $input_file_name, $table) = @_;

	Carp::croak('Missing parameter to new(): dbh') if (! $$self{'_dbh'});

	my($table_name, $parser, $type, $record, $candidate_table, $row);

	for $table_name (@$table)
	{
		$parser = XML::Records -> new($input_file_name);

		$parser -> set_records('resultset');

		for (;;)
		{
			($type, $record) = $parser -> get_record();

			# Exit if no data found.

			last if (! $record);

			$candidate_table = $1 if ($$record{'statement'} =~ m!select \* from (.+)!);

			# Skip if the data is not for the 'current' table.

			next if ($candidate_table ne $table_name);

			# Skip if the data is not wanted.

			next if ($$self{'_skipping'});

			$self -> process_table('Restore', $candidate_table);

			# Warning: At this point, if the input file has no data for a table,
			# $$record{'row'} will be undef, so don't access @{$$record{'row'} }.

			next if (! $$record{'row'});

			# Warning. If the XML file contains 1 'record', XML::Records
			# returns text or a hash ref, not an array ref containing one element.
			# Due to the nature of our data, we can ignore the case of textual data.

			$$record{'row'} = [$$record{'row'}] if (ref $$record{'row'} ne 'ARRAY');

			for $row (@{$$record{'row'} })
			{
				# There may be a different number of fields from one row to the next.
				# Remember, only non-null fields are output by method backup().

				@{$$self{'_key'} }	= keys %$row;
				$$self{'_value'}	= [];

				$self -> transform($_, $$row{$_}) for @{$$self{'_key'} };
				$self -> write_row();
			}

			# Exit if table restored.

			last;
		}
	}

}	# End of restore_in_order.

# -----------------------------------------------

sub split
{
	my($self, $file_name) = @_;

	open(INX, $file_name) || Carp::croak("Can't open($file_name): $!");

	my($line, $table_name, $output_file_name);

	while ($line = )
	{
		next if ($line =~ m!^(<\?xml|

		if ($line =~ m!^!i)
		{
			$$self{'_database'} = $1;

			next;
		}

		if ($line =~ m!!i)
		{
			$table_name = $1;

			$self -> process_table('Split', $table_name);

			# Close off the previous output file, if any.

			if ($$self{'_output_is_open'})
			{
				$$self{'_output_is_open'} = 0;

				print OUT qq|\t\n|;
				print OUT qq|\n|;

				close OUT;
			}

			if (! $$self{'_skipping'})
			{
				# Start the next output file.

				$output_file_name			= "$$self{'_current_table'}.xml";
				$output_file_name			= "$$self{'_current_schema'}.$output_file_name" if ($$self{'_current_schema'});
				$output_file_name			= File::Spec -> catdir($$self{'_output_dir_name'}, $output_file_name);
				$$self{'_output_is_open'}	= 1;

				open(OUT, "> $output_file_name") || Carp::croak("Can't open($output_file_name): $!");

				print OUT qq|\n|;
				print OUT qq|\n|;
				print OUT qq|\t\n|;
			}
		}
		elsif ( (! $$self{'_skipping'}) && ($line =~ m!!i) )
		{
			# There may be a different number of fields from one row to the next.
			# Remember, only non-null fields are output by method backup().

			print OUT qq|\t\t\n|;

			while ( ($line = ) !~ m!!i)
			{
				print OUT $line;
			}

			print OUT qq|\t\t\n|;
		}
	}

	close INX;

	# Close off the previous file, if any.

	if ($$self{'_output_is_open'})
	{
		print OUT qq|\t\n|;
		print OUT qq|\n|;

		close OUT;
	}

	[sort keys %{$$self{'_restored'} }];

}	# End of split.

# -----------------------------------------------

sub tables
{
	my($self) = @_;

	[
		sort
		map{s/$$self{'_quote'}//g; $_}
		grep{! /^BIN\$.+\$./}	# Discard 'funny' Oracle table names, like BIN$C544WGedCuHgRAADuk1i5g==$0.
		map{$$_{'TABLE_NAME'} }
		@{$$self{'_dbh'}
		-> table_info($$self{'_dbi_catalog'}, $$self{'_dbi_schema'}, $$self{'_dbi_table'}, $$self{'_dbi_type'})
		-> fetchall_arrayref({})}
	];

}	# End of tables.

# -----------------------------------------------

sub transform
{
	my($self, $key, $value) = @_;

	if ($key =~ /timestamp/)
	{
		if ($$self{'_fiddle_timestamp'} & 0x01)
		{
			$value = '19700101' if ($value =~ /^0000/);
			$value = substr($value, 0, 4) . '-' . substr($value, 4, 2) . '-' . substr($value, 6, 2) . ' 00:00:00';
		}
		elsif ($$self{'_fiddle_timestamp'} & 0x02)
		{
			$value = '1970-01-01 00:00:00' if ($value =~ /^0000/);
		}

		if ($$self{'_fiddle_timestamp'} & 0x80)
		{
			$value = '1970-01-01 00:00:01' if ($value eq '1970-01-01 00:00:00');
		}
	}

	push @{$$self{'_value'} }, $value;

}	# End of transform.

# -----------------------------------------------

sub write_row
{
	my($self) = @_;

	if ($$self{'_skip_schema_name'}{$$self{'_current_schema'} } || $$self{'_skip_table_name'}{$$self{'_current_table'} })
	{
	}
	else
	{
		my($sql) = "insert into $$self{'_current_table'} (" . join(', ', @{$$self{'_key'} }) . ') values (' . join(', ', ('?') x @{$$self{'_key'} }) . ')';
		my($sth) = $$self{'_dbh'} -> prepare($sql) || Carp::croak("Can't prepare($sql): $DBI::errstr");

		$sth -> execute(@{$$self{'_value'} }) || Carp::croak("Can't execute($sql): $DBI::errstr");
		$sth -> finish();
	}

}	# End of write_row.

# -----------------------------------------------

1;

__END__