File Coverage

blib/lib/DBIx/Table2Hash.pm

Criterion	Covered	Total	%
statement	9	81	11.1
branch	0	24	0.0
condition	0	18	0.0
subroutine	3	12	25.0
pod	0	5	0.0
total	12	140	8.5

package DBIx::Table2Hash;

# Name:
#	DBIx::Table2Hash.
#
# 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) 1999-2002 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;

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::Hash2Table ':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';

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

# Preloaded methods go here.

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

# Encapsulated class data.

{
	my(%_attr_data) =
	(
		_child_column	=> '',
		_dbh			=> '',
		_skip_columns	=> [],
		_hash_ref		=> '',
		_key_column		=> '',
		_parent_column	=> '',
		_table_name		=> '',
		_value_column	=> '',
		_where			=> '',
	);

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

		$_attr_data{$attr_name};
	}

	sub _get_column_names
	{
		my($self, $table_name) = @_;
		my($sth) = $$self{'_dbh'} -> prepare("select * from $table_name where 1=2");

		$sth -> execute();

		$$self{'_column_name'} = $$sth{'NAME_lc'};

		$sth -> finish();

	}	# End of _get_column_names.

	sub _select_tree
	{
		my($self, $root, $children, $parent_id) = @_;
		my($skip)	= join('|', $$self{'_key_column'}, $$self{'_child_column'}, $$self{'_parent_column'}, @{$$self{'_skip_columns'} });
		$skip		= qr/$skip/;

		my($child, $name, $key);

		for my $child (@{$$children{$parent_id} })
		{
			$name			= $$child{$$self{'_key_column'} };
			$$root{$name}	= {};

			for $key (keys %$child)
			{
				next if ($key =~ /$skip/);

				$$root{$name}{$key} = $$child{$key} if ($$child{$key});
			}

			$self -> _select_tree($$root{$$child{$$self{'_key_column'} } }, $children, $$child{$$self{'_child_column'}});
		}

	}	# End of _select_tree.

	sub _standard_keys
	{
		keys %_attr_data;
	}

}	# End of encapsulated class data.

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

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);
		}
	}

	return $self;

}	# End of new.

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

sub select
{
	my($self, %arg) = @_;

	$self -> set(%arg);

	croak(__PACKAGE__ . '. You must supply a value for the parameters dbh, table_name, key_column and value_column')
		if (! ($$self{'_dbh'} && $$self{'_table_name'} && $$self{'_key_column'} && $$self{'_value_column'}) );

	my($sql) = "select $$self{'_key_column'}, $$self{'_value_column'} from $$self{'_table_name'} $$self{'_where'}";
	my($sth) = $$self{'_dbh'} -> prepare($sql);

	$sth -> execute();

	my($data, %h);

	while ($data = $sth -> fetch() )
	{
		$h{$$data[0]} = $$data[1] if (defined $$data[0]);
	}

	$$self{'_hash_ref'} = \%h;

}	# End of select.

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

sub select_hashref
{
	my($self, %arg) = @_;

	$self -> set(%arg);

	croak(__PACKAGE__ . '. You must supply a value for the parameters dbh, table_name and key_column')
		if (! ($$self{'_dbh'} && $$self{'_table_name'} && $$self{'_key_column'}) );

	$self -> _get_column_names($$self{'_table_name'});

	my(%column_name);

	@column_name{@{$$self{'_column_name'} } } = (1) x @{$$self{'_column_name'} };

	# Due to a bug in MySQL, we cannot say 'col, *', we must say '*, col'.

	my($column_set)	= $column_name{lc $$self{'_key_column'} } ? '*' : "*, $$self{'_key_column'}";
	my($sql)		= "select $column_set from $$self{'_table_name'} $$self{'_where'}";
	my($sth)		= $$self{'_dbh'} -> prepare($sql);

	$sth -> execute();

	my($data, %h);

	while ($data = $sth -> fetchrow_hashref() )
	{
		$h{$$data{$$self{'_key_column'} } } = {%$data} if (defined $$data{$$self{'_key_column'} });
	}

	$$self{'_hash_ref'} = \%h;

}	# End of select_hashref.

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

sub select_tree
{
	my($self, %arg) = @_;

	$self -> set(%arg);

	croak(__PACKAGE__ . '. You must supply a value for the parameters child_column and parent_column')
		if (! ($$self{'_child_column'} && $$self{'_parent_column'}) );

	$self -> select_hashref() if (! $$self{'_hash_ref'});

	my($id, $parent_id, %children);

	for $id (keys %{$$self{'_hash_ref'} })
	{
		$parent_id				= $$self{'_hash_ref'}{$id}{$$self{'_parent_column'} };
		$children{$parent_id}	= [] if (! $children{$parent_id});
		push @{$children{$parent_id} }, $$self{'_hash_ref'}{$id};
	}

	my($tree) = {};

	$self -> _select_tree($tree, \%children, 0);

	$tree;

}	# End of select_tree.

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

sub set
{
	my($self, %arg) = @_;

	for my $arg (keys %arg)
	{
		$$self{"_$arg"} = $arg{$arg} if (exists($$self{"_$arg"}) );
	}

}	# End of set.

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

1;

__END__