package TableCache;
use Moose;
use namespace::autoclean;

#
# the main purpose of this class is to capture cache hits
# to ensure the cache is working properly
#

has 'data' => (
    is       => 'rw',
    required => 1,
    default  => sub { [] }
);

before 'data' => sub {
    my $self = shift;
    if ( !scalar(@_) ) 
        { $self->hits( $self->hits() + 1 ) }    # cache hit
};

has 'hits' => (
    is       => 'rw',
    isa      => 'Int',
    required => 0,
    default  => 0
);

package MySQL::Util;
use Moose;
use namespace::autoclean;
use DBI;
use Carp;

=head1 NAME

MySQL::Util - Utility functions for working with MySQL.

=head1 VERSION

Version 0.10

=cut

our $VERSION = '0.10';

=head1 SYNOPSIS

=for text

 my $util = MySQL::Util->new( dsn  => $ENV{DBI_DSN}, 
                              user => $ENV{DBI_USER} );

 my $util = MySQL::Util->new( dsn  => $ENV{DBI_DSN}, 
                              user => $ENV{DBI_USER},
                              span => 1); 

 my $aref = $util->describe_table('mytable');
 print "table: mytable\n";
 foreach my $href (@$aref) {
 	print "\t", $href->{FIELD}, "\n";
 }

 my $href = $util->get_ak_constraints('mytable');
 my $href = $util->get_ak_indexes('mytable');
 my $href = $util->get_constraints('mytable');

 #
 # drop foreign keys example 1 
 # 
 
 my $fks_aref = $util->drop_fks();

 < do some work here - perhaps truncate tables >

 $util->apply_ddl($fks_aref);   # this will clear the cache for us.  see 
                                # clear_cache() for more info.

 # 
 #  drop foreign keys example 2 
 #
 
 my $fks_aref = $util->drop_fks();

 my $dbh = $util->clone_dbh;
 foreach my $stmt (@$fks_aref) {
     $dbh->do($stmt); 
 }

 $util->clear_cache;  # we modified the database ddl outside of the object so 
                      # we need to clear the object's internal cache.  see 
                      # clear_cache() for more info.

=cut 

#
# public variables
#

has 'dsn' => (
    is       => 'ro',
    isa      => 'Str',
    required => 1
);

has 'user' => (
    is       => 'ro',
    isa      => 'Str',
    required => 1
);

has 'pass' => (
    is       => 'ro',
    required => 0,
    default  => undef
);

has 'span' => (
	is => 'ro',
	isa   => 'Int',
	required => 0,
	default => 0
);

#
# private variables
#

has '_dbh' => (
    is       => 'ro',
    writer   => '_set_dbh',
    init_arg => undef,        # By setting the init_arg to undef, we make it
         # impossible to set this attribute when creating a new object.
);

has '_index_cache' => (
    is       => 'rw',
    isa      => 'HashRef[TableCache]',
    init_arg => undef,
    default  => sub { {} }
);

has '_constraint_cache' => (
    is       => 'rw',
    isa      => 'HashRef[TableCache]',
    init_arg => undef,
    default  => sub { {} }
);

has '_depth_cache' => (
	is 		 => 'rw',
	isa		 => 'HashRef',
	init_arg => undef,
	default  => sub { {} }
);

has '_describe_cache' => (
	is 		 => 'rw',
	isa		 => 'HashRef',
	init_arg => undef,
	default  => sub { {} }
);

has '_schema' => (
	is => 'rw',
	isa => 'Str',
	required => 0,
	init_arg => undef,
);

#
# this gets automatically invoked sub the constructor#__AFTER
#
sub BUILD {
    my $self = shift;

    my $dbh = DBI->connect(
        $self->dsn,
        $self->user,
        $self->pass,
        {
            RaiseError       => 1,
            FetchHashKeyName => 'NAME_uc'
        }
    );
	
	my $schema = $dbh->selectrow_arrayref("select schema()")->[0];
	if ($schema) {
		$self->_schema($schema);
	}

    $self->_set_dbh($dbh);
}

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

=head1 METHODS

All methods croak in the event of failure unless otherwise noted.

=over 

=item new( dsn  => $dsn, 
           user => $user, 
          [pass => $pass], 
          [span => $span]);

constructor
 * dsn  - standard DBI stuff
 * user - db username
 * pass - db password
 * span - follow references that span databases (default 0)

=cut


=item apply_ddl( [ ... ]) 

Runs arbitrary ddl commands passed in via an array ref.

The advantage of this is it allows you to make ddl changes to the db without
having to worry about the object's internal cache (see clear_cache()).

=cut

sub apply_ddl
{
	my $self = shift;
	my $stmts_aref = shift;

 	foreach my $stmt (@$stmts_aref) {
    	$self->_dbh->do($stmt);
 	}

	$self->clear_cache;	
}

=item describe_table($table);

Returns an arrayref of column info for a given table. 

The structure of the returned data is:

$arrayref->[ { col1 }, { col2 } ]

Hash elements for each column:

	DEFAULT
	EXTRA
	FIELD
	KEY
	NULL
	TYPE
           
See MySQL documentation for more info on "describe <table>".
 
=cut

sub describe_table
{
	my $self  = shift;
	my $table = shift;	

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my $cache = '_describe_cache';

    if ( defined( $self->$cache->{$table} ) ) {
        return $self->$cache->{$table}->data;
    }

    my $sql = qq{
    	describe $table
	};

    my $dbh = $self->_dbh;
    my $sth = $dbh->prepare($sql);
    $sth->execute;

    my @cols;
    while ( my $row = $sth->fetchrow_hashref ) {
        push( @cols, { %$row } );
    }

    $self->$cache->{$table} = TableCache->new( data => \@cols );
    return \@cols;
}


=item drop_fks([$table])

Drops foreign keys for a given table or the entire database if no table is 
provided.

Returns an array ref of alter table statements to rebuild the dropped foreign 
keys on success.  Returns an empty array ref if no foreign keys were found.

=cut

sub drop_fks
{
    my $self  = shift;
    my $table = shift;

	my @tables;
	if (!defined($table)) {
		my $tables_aref = $self->get_tables;
		return [] if !defined($tables_aref);

		@tables = @$tables_aref;	
	}
	else {
		push(@tables, $table);
	}

	my @ret;
	foreach my $table (@tables) {

		my $fqtn = $self->_schema . ".$table";
		my $fks_href = $self->get_fk_constraints($table);

		foreach my $fk (keys %$fks_href) {
	
			push(@ret, $self->_get_fk_ddl($table, $fk));
	
			my $sql = qq{
				alter table $table
				drop foreign key $fk
			};
			$self->_dbh->do($sql);
		
			$self->_constraint_cache->{$fqtn} = undef;
		}		
	}	

	return [ @ret ];
}

sub _get_fk_ddl
{
	my $self = shift;
	my $table = shift;
	my $fk = shift;

    my $sql = "show create table $table";
    my $sth = $self->_dbh->prepare($sql);
    $sth->execute;

    while(my @a = $sth->fetchrow_array) {

        foreach my $data (@a) {
            my @b = split(/\n/, $data);

            foreach my $item (@b) {
                if ($item =~ /CONSTRAINT `$fk` FOREIGN KEY/) {
					$item =~ s/^\s*//; # remove leading ws
					$item =~ s/\s*//;  # remove trailing ws
					$item =~ s/,$//;   # remove trailing comma

					return "alter table $table add $item";
				}
			}
		}
	}	
}

=item get_ak_constraints($table)

Returns a hashref of the alternate key constraints for a given table.  Returns
an empty hashref if none were found.  The primary key is excluded from the
returned data.  

The structure of the returned data is:

$hashref->{constraint_name}->[ { col1 }, { col2 } ]

See "get_constraints" for a list of the hash elements in each column.

=cut

sub get_ak_constraints {
    my $self  = shift;
    my $table = shift;

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my $href = {};
    my $cons = $self->get_constraints($table);

    foreach my $con ( keys(%$cons) ) {
        if ( $cons->{$con}->[0]->{CONSTRAINT_TYPE} eq 'UNIQUE' ) {
            $href->{$con} = $cons->{$con};
        }
    }

    return $href;
}

=item get_ak_indexes($table)

Returns a hashref of the alternate key indexes for a given table.  Returns
an empty hashref if none were found.

The structure of the returned data is:

$href->{index_name}->[ { col1 }, { col2 } ]

See get_indexes for a list of hash elements in each column.
	
=cut

sub get_ak_indexes {
    my $self  = shift;
    my $table = shift;

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my $href = {};
    my $indexes = $self->get_indexes($table);

    foreach my $index ( keys(%$indexes) ) {
        if ( $indexes->{$index}->[0]->{NON_UNIQUE} == 0 ) {
            $href->{$index} = $indexes->{$index};
        }
    }

    return $href;
}

=item get_constraints($table)

Returns a hashref of the constraints for a given table.  Returns
an empty hashref if none were found.

The structure of the returned data is:

$hashref->{constraint_name}->[ { col1 }, { col2 } ]

Hash elements for each column:

	CONSTRAINT_SCHEMA
	CONSTRAINT_TYPE
	COLUMN_NAME
	ORDINAL_POSITION
	POSITION_IN_UNIQUE_CONSTRAINT
	REFERENCED_COLUMN_NAME
	REFERENCED_TABLE_SCHEMA
	REFERENCED_TABLE_NAME
		
=cut

sub get_constraints {
    my $self  = shift;
    my $table = shift;

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}
	
	my ($schema, $table_no_schema) = split(/\./, $table);
    
	my $cache = '_constraint_cache';

    if ( defined( $self->$cache->{$table} ) ) {
        return $self->$cache->{$table}->data;
    }

	croak "table '$table' does not exist: " if !$self->table_exists($table);
	
    my $sql = qq{
		select kcu.constraint_name, tc.constraint_type, column_name, 
		  ordinal_position, position_in_unique_constraint, referenced_table_schema,
		  referenced_table_name, referenced_column_name, tc.constraint_schema
	    from information_schema.table_constraints tc, 
	      information_schema.key_column_usage kcu 
		where tc.table_name = '$table_no_schema'
		  and tc.table_name = kcu.table_name 
		  and tc.constraint_name = kcu.constraint_name 
		  and tc.constraint_schema = '$schema'
		  and kcu.constraint_schema = tc.constraint_schema 
	};
	
	if (!$self->span) {
 		$sql.= qq{
		  and (referenced_table_schema = '$schema' or referenced_table_schema is null)
		};
	}

	$sql.= qq{ order by constraint_name, ordinal_position };
	
	my $dbh = $self->_dbh;
    my $sth = $dbh->prepare($sql);
    $sth->execute;

    my $href = {};
    while ( my $row = $sth->fetchrow_hashref ) {
        my $name = $row->{CONSTRAINT_NAME};
        delete( $row->{CONSTRAINT_NAME} );

        if ( !defined( $href->{$name} ) ) { $href->{$name} = [] }

        push( @{ $href->{$name} }, {%$row} );
    }
    
	$self->$cache->{$table} = TableCache->new( data => $href );
    return $href;
}


=item get_depth($table)

Returns the table depth within the data model hierarchy.  The depth is 
zero based. 

For example:

=for text

 -----------       -----------
 | table A |------<| table B |
 -----------       -----------

=cut

=item 

Table A has a depth of 0 and table B has a depth of 1.  In other
words, table B is one level down in the model hierarchy.

If a table has multiple parents, the parent with the highest depth wins.

=cut

sub get_depth 
{
	my $self  = shift;
	my $table = shift;
	
	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}
	
	my $cache = '_depth_cache';
		
	if (defined($self->{$cache}->{$table})) 
		{ return $self->{$cache}->{$table}	; }
		
	my $dbh = $self->_dbh;
	
	my $fk_cons = $self->get_fk_constraints($table);	
	
	my $depth = 0;	
	
	foreach my $fk_name (keys (%$fk_cons)) {
		my $parent_table = 	
			$fk_cons->{$fk_name}->[0]->{REFERENCED_TABLE_SCHEMA} .
			'.' .  
			$fk_cons->{$fk_name}->[0]->{REFERENCED_TABLE_NAME};

		if ($parent_table eq $table)
			{ next }  # self referencing table
		
		my $parent_depth = $self->get_depth($parent_table);	
		if ($parent_depth >= $depth)
			{ $depth = $parent_depth + 1 }
	}

	$self->{$cache}->{$table} = $depth;
	
	return $depth;
}


=item get_fk_constraints([$table])

Returns the foreign keys for a table or the entire database.

Returns a hashref of the foreign key constraints on success.  Returns
an empty hashref if none were found.

The structure of the returned data is:

$hashref->{constraint_name}->[ { col1 }, { col2 } ]

See "get_constraints" for a list of the hash elements in each column.

=cut

sub get_fk_constraints {
    my $self  = shift;
    my $table = shift;

	if (defined($table) and $table !~ /\./) {
		$table = $self->_schema . ".$table";
	}
	
	my @tables;
	if (!defined($table)) {
		my $tables_aref = $self->get_tables;
		return {} if !defined($tables_aref);

		@tables = @$tables_aref;	
	}
	else {
		push(@tables, $table);
	}

	my $href = {};
	my @ret;
	foreach my $table (@tables) {
    	my $cons = $self->get_constraints($table);

    	foreach my $con ( keys(%$cons) ) {
        	if ( $cons->{$con}->[0]->{CONSTRAINT_TYPE} eq 'FOREIGN KEY' ) {
            	$href->{$con} = $cons->{$con};
        	}
		}
    }

    return $href;
}

=item get_fk_indexes($table)

Returns a hashref of the foreign key indexes for a given table.  Returns
an empty hashref if none were found.  In order to qualify as a fk index, 
it must have a corresponding fk constraint.  

The structure of the returned data is:

$hashref->{index_name}->[ { col1 }, { col2 } ]

See "get_indexes" for a list of the hash elements in each column.

=cut

sub get_fk_indexes {
    my $self  = shift;
    my $table = shift;

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my $href = {};
    my $cons    = $self->get_fk_constraints($table);
    my $indexes = $self->get_indexes($table);

    foreach my $con_name ( keys(%$cons) ) {
        my @con_cols = @{ $cons->{$con_name} };

        foreach my $index_name ( keys(%$indexes) ) {
            my @index_cols = @{ $indexes->{$index_name} };

            if ( scalar(@con_cols) == scalar(@index_cols) ) {

                my $match = 1;
                for ( my $i = 0 ; $i < scalar(@con_cols) ; $i++ ) {
                    if ( $index_cols[$i]->{COLUMN_NAME} ne
                        $con_cols[$i]->{COLUMN_NAME} )
                    {
                        $match = 0;
                        last;
                    }
                }

                if ($match) {
                    $href->{$index_name} = $indexes->{$index_name};
                    last;
                }
            }
        }
    }

    return $href;
}

sub _get_indexes_arrayref {
    my $self  = shift;
    my $table = shift;

    my $cache = '_index_cache';

    if ( defined( $self->$cache->{$table} ) ) {
        return $self->$cache->{$table}->data;
    }

    my $dbh = $self->_dbh;
    my $sth = $dbh->prepare("show indexes in $table");
    $sth->execute;

    my $aref = [];
    while ( my $href = $sth->fetchrow_hashref ) {
        push( @$aref, {%$href} );
    }

    $self->$cache->{$table} = TableCache->new( data => $aref );
    return $aref;
}

=item get_indexes($table)

Returns a hashref of the indexes for a given table.  Returns
an empty hashref if none were found.

The structure of the returned data is:

$href->{index_name}->[ { col1 }, { col2 } ]

Hash elements for each column:

	CARDINALITY
	COLLATION
	COLUMN_NAME
	COMMENT
	INDEX_TYPE
	KEY_NAME
	NON_UNIQUE
	NULL
	PACKED
	SEQ_IN_INDEX
	SUB_PART
	TABLE
	
=cut

sub get_indexes {
    my $self  = shift;
    my $table = shift;

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my %h = ();
    my $indexes = $self->_get_indexes_arrayref($table);

    foreach my $index (@$indexes) {
        my $key_name = $index->{KEY_NAME};
        my $seq      = $index->{SEQ_IN_INDEX};

        if ( !exists( $h{$key_name} ) ) { $h{$key_name} = [] }

        $h{$key_name}->[ $seq - 1 ] = $index;
    }

    return \%h;
}

=item get_max_depth()

Returns the max table depth for all tables in the database.

See "get_depth" for additional info.

=cut

sub get_max_depth
{
	my $self = shift;

	my $dbh = $self->_dbh;
	
	my $tables = $self->get_tables();	
	
	my $max = 0;
	foreach my $table (@$tables) {
		my $depth = $self->get_depth($table);
		if ($depth > $max)
			{ $max = $depth }
	}
	
	return $max;
}

=item get_other_constraints($table)

Returns a hashref of the constraints that are not pk, ak, or fk  
for a given table.  Returns an empty hashref if none were found.

The structure of the returned data is:

$hashref->{constraint_name}->[ { col1 }, { col2 } ]

See "get_constraints" for a list of the hash elements in each column.

=cut

sub get_other_constraints {
    my $self  = shift;
    my $table = shift;

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my $fk = $self->get_fk_constraints($table);
    my $ak = $self->get_ak_constraints($table);

    my $href = {};
    my $cons = $self->get_constraints($table);

    foreach my $con_name ( keys(%$cons) ) {
        my $type = $cons->{$con_name}->[0]->{CONSTRAINT_TYPE};

        next if $type eq 'PRIMARY KEY';
        next if $type eq 'FOREIGN KEY';
        next if $type eq 'UNIQUE';

        $href->{$con_name} = $cons->{$con_name};
    }

    return $href;
}

=item get_other_indexes($table)

Returns a hashref of the indexes that are not pk, ak, or fk  
for a given table.  Returns an empty hashref if none were found.

The structure of the returned data is:

$hashref->{index_name}->[ { col1 }, { col2 } ]

See "get_indexes" for a list of the hash elements in each column.

=cut

sub get_other_indexes {
    my $self  = shift;
    my $table = shift;

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my $ak = $self->get_ak_indexes($table);
    my $fk = $self->get_fk_indexes($table);

    my $href = {};
    my $indexes = $self->get_indexes($table);

    foreach my $name ( keys %$indexes ) {
        next if $name eq 'PRIMARY';
        next if defined( $ak->{$name} );
        next if defined( $fk->{$name} );

        $href->{$name} = $indexes->{$name};
    }

    return $href;
}

=item get_pk_constraint($table)

Returns an arrayref of the primary key constraint for a given table.  Returns
an empty arrayref if none were found.

The structure of the returned data is:

$aref->[ { col1 }, { col2 }, ... ]

See "get_constraints" for a list of hash elements in each column.

=cut

sub get_pk_constraint {
    my $self  = shift;
    my $table = shift;

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my $cons = $self->get_constraints($table);

    foreach my $con_name ( keys(%$cons) ) {
        if ( $cons->{$con_name}->[0]->{CONSTRAINT_TYPE} eq 'PRIMARY KEY' ) {
            return $cons->{$con_name};
        }
    }

    return [];
}

=item get_pk_index($table)

Returns an arrayref of the primary key index for a given table. Returns
an empty arrayref if none were found.

The structure of the returned data is:

$aref->[ { col1 }, { col2 }, ... ]

See "get_indexes" for a list of the hash elements in each column.

=cut

sub get_pk_index {
    my $self  = shift;
    my $table = shift;

#	if ($table !~ /\./) {
#		$table = $self->_schema . ".$table";
#	}

    my $href = $self->get_indexes($table);

    foreach my $name ( keys(%$href) ) {
        if ( $name eq 'PRIMARY' )    # mysql forces this naming convention
        {
            return $href->{$name};
        }
    }

    return [];
}

=item get_tables( )

Returns an arrayref of tables in the current database.  Returns undef
if no tables were found.

=cut

sub get_tables {
	my $self = shift;

    my $dbh = $self->_dbh;
    
    my $tables = undef;
    my $sth = $dbh->prepare("show tables");
    $sth->execute;
   
   	while(my ($table) = $sth->fetchrow_array) {
   		push(@$tables, $table);	
   	} 

   	return $tables;
}


=item table_exists($table)

Returns true if table exists.  Otherwise returns false.

=cut

sub table_exists
{
	my $self  = shift;
	my $table = shift;		

	if ($table !~ /\./) {
		$table = $self->_schema . ".$table";
	}

    my $dbh = $self->_dbh;

	my ($schema, $table_no_schema) = split(/\./, $table);
	if ($schema ne $self->_schema) {
		# quietly change the schema so "show tables like ..." works
		$dbh->do("use $schema");
	}

	my $sql = qq{show tables like '$table_no_schema'};
	my $sth = $dbh->prepare($sql);
	$sth->execute;

	my $cnt = 0;	
	while($sth->fetchrow_array) {
		$cnt++;	
	}	

	if ($schema ne $self->_schema) {
		# quietly change schema back
		$dbh->do("use " . $self->_schema);
	}
	
	return $cnt;
}


=item use_dbh($dbname)

Used for switching database context.  Returns true on success.

=cut

sub use_dbh {
    my $self   = shift;
    my $dbname = shift;

    $self->_dbh->do("use $dbname");
	$self->_schema($dbname);
	$self->clear_cache;

    return 1;
}

=back

=head1 ADDITIONAL METHODS

=over 

=item clear_cache()

Clears the object's internal cache.

If you modify the database ddl without going through the object, then you need 
to clear the internal cache so any future object calls don't return stale 
information.

=cut

sub clear_cache
{
	my $self = shift;
	
	$self->_index_cache({});
	$self->_constraint_cache({});
	$self->_depth_cache({});
	$self->_describe_cache({});
}

=item clone_dbh()

Returns a cloned copy of the internal database handle per the DBI::clone 
method.  Beware that the database context will be the same as the object's. 
For example, if you called "use_dbh" and switched context along the way, the 
returned dbh will also be in that same context.

=cut

sub clone_dbh {
	my $self = shift;

	my $dbh = $self->_dbh->clone;
	$dbh->do("use " . $self->_schema);
	return $dbh;
}

=back

=head1 AUTHOR 
John Gravatt, C<< <gravattj at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-mysql-util at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=MySQL-Util>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc MySQL::Util


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MySQL-Util>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/MySQL-Util>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/MySQL-Util>

=item * Search CPAN

L<http://search.cpan.org/dist/MySQL-Util/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2011 John Gravatt.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

__PACKAGE__->meta->make_immutable; # moose stuff

1;
