File Coverage

File:blib/lib/MySQL/Util.pm
Coverage:86.0%

linestmtbrancondsubcode
1package MySQL::Util;
2
3
3
3
use Moose;
3
3
3
3
use namespace::autoclean;
4
3
3
3
use DBI;
5
3
3
3
use Carp;
6
3
3
3
use DBIx::DataFactory;
7
3
3
3
use Data::Dumper;
8$Data::Dumper::Sortkeys = 1;
9
3
3
3
use MySQL::Util::Data::Cache;
10
3
3
3
use Smart::Args;
11
12with 'MySQL::Util::Data::Create';
13
14 - 22
=head1 NAME

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

=head1 VERSION

Version 0.29

=cut
23
24our $VERSION = '0.34';
25
26 - 75
=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 $util = MySQL::Util->new( dbh => $dbh );
                              
 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 
76
77#
78# public variables
79#
80
81has 'dsn' => (
82        is       => 'ro',
83        isa      => 'Str',
84        required => 0
85);
86
87has 'user' => (
88        is       => 'ro',
89        isa      => 'Str',
90        required => 0
91);
92
93has 'pass' => (
94        is       => 'ro',
95        required => 0,
96        default  => undef
97);
98
99has 'span' => (
100        is       => 'ro',
101        isa      => 'Int',
102        required => 0,
103        default  => 0
104);
105
106has 'dbh' => (
107        is  => 'rw',
108        isa => 'Object',
109);
110
111#
112# private variables
113#
114
115has '_dbh' => (
116        is       => 'ro',
117        writer   => '_set_dbh',
118        init_arg => undef,        # By setting the init_arg to undef, we make it
119             # impossible to set this attribute when creating a new object.
120);
121
122has '_index_cache' => (
123        is       => 'rw',
124        isa      => 'HashRef[MySQL::Util::Data::Cache]',
125        init_arg => undef,
126        default  => sub { {} }
127);
128
129has '_constraint_cache' => (
130        is       => 'rw',
131        isa      => 'HashRef[MySQL::Util::Data::Cache]',
132        init_arg => undef,
133        default  => sub { {} }
134);
135
136has '_depth_cache' => (
137        is       => 'rw',
138        isa      => 'HashRef',
139        init_arg => undef,
140        default  => sub { {} }
141);
142
143has '_describe_cache' => (
144        is       => 'rw',
145        isa      => 'HashRef',
146        init_arg => undef,
147        default  => sub { {} }
148);
149
150has '_schema' => (
151        is       => 'rw',
152        isa      => 'Str',
153        required => 0,
154        init_arg => undef,
155);
156
157has _verbose_funcs => (
158        is       => 'rw',
159        isa      => 'HashRef',
160        required => 0,
161        default  => sub { {} },
162);
163
164##############################################################################
165
166sub BUILD {
167
7
        my $self = shift;
168
169
7
        if ( defined $ENV{VERBOSE_FUNCS} ) {
170
0
                my $vf = $self->_verbose_funcs;
171
172
0
                foreach my $func ( split /[,|:]/, $ENV{VERBOSE_FUNCS} ) {
173
0
                        $vf->{$func} = 1;
174                }
175
176
0
                $self->_verbose_funcs($vf);
177        }
178
179
7
        my $dbh = $self->dbh;
180
181
7
        if ( !$dbh ) {
182
183
4
                $dbh = DBI->connect(
184                        $self->dsn,
185                        $self->user,
186                        $self->pass,
187                        {
188                                RaiseError       => 1,
189                                FetchHashKeyName => 'NAME_uc',
190                                AutoCommit       => 0,           # dbd::mysql workaround
191                                PrintError       => 0
192                        }
193                );
194
195
2
                $dbh->{AutoCommit} = 1;                  # dbd::mysql workarounda
196        }
197        else {
198
3
                $dbh->{FetchHashKeyName} = 'NAME_uc';
199        }
200
201
5
        my $schema = $dbh->selectrow_arrayref("select schema()")->[0];
202
5
        if ($schema) {
203
5
                $self->_schema($schema);
204        }
205
206
5
        $self->_set_dbh($dbh);
207}
208
209#################################################################
210#################### PRIVATE METHODS ############################
211#################################################################
212
213#sub _get_ak_constraint_arrayref {
214#       args
215#                my $self => 'Object',
216#                my $table => 'Str',
217#                my $name => 'Str';
218#
219#    my $href = $self->get_ak_constraints($table);
220#
221#       if (defined $href->{$name}) {
222#               return $href->{$name};
223#       }
224#
225#       confess "can't find ak constraint: $name";
226#}
227
228sub _get_fk_column {
229
246
        my $self = shift;
230
246
        my %a    = @_;
231
232
246
        my $table  = $a{table}  || confess "missing table arg";
233
246
        my $column = $a{column} || confess "missing column arg";
234
235
246
        my $fks_href = $self->get_fk_constraints($table);
236
237
246
        foreach my $fk_name ( keys %$fks_href ) {
238
239
369
369
                foreach my $fk_href ( @{ $fks_href->{$fk_name} } ) {
240
241
369
                        if ( $fk_href->{COLUMN_NAME} eq $column ) {
242
246
                                return $fk_href;
243                        }
244                }
245        }
246
247
0
        confess "couldn't find where $table.$column is part of an fk?";
248}
249
250sub _get_indexes_arrayref {
251
10
        my $self  = shift;
252
10
        my $table = shift;
253
254
10
        my $cache = '_index_cache';
255
256
10
        if ( defined( $self->$cache->{$table} ) ) {
257
5
                return $self->$cache->{$table}->data;
258        }
259
260
5
        my $dbh = $self->_dbh;
261
5
        my $sth = $dbh->prepare("show indexes in $table");
262
5
        $sth->execute;
263
264
4
        my $aref = [];
265
4
        while ( my $href = $sth->fetchrow_hashref ) {
266
11
                push( @$aref, {%$href} );
267        }
268
269
4
        $self->$cache->{$table} = MySQL::Util::Data::Cache->new( data => $aref );
270
4
        return $aref;
271}
272
273sub _fq {
274
9199
        args
275
276          # required
277          my $self  => 'Object',
278          my $table => 'Str',
279
280          # optional
281          my $fq     => { isa => 'Int',       optional => 1, default => 1 },
282          my $schema => { isa => 'Str|Undef', optional => 1 };
283
284
9199
        if ($fq) {
285
9127
                if ( $table =~ /\w\.\w/ ) {
286
6791
                        return $table;
287                }
288                elsif ($schema) {
289
1076
                        return "$schema.$table";
290                }
291
292
1260
                return $self->_schema . ".$table";
293        }
294
295
72
        if ( $table =~ /^(\w+)\.(\w+)$/ ) {
296
72
                my $curr = $self->_schema;
297
298
72
                confess "can't remove schema name from table name $table because we "
299                  . "are not in the same db context (incoming fq table = $table, "
300                  . "current schema = $curr"
301                  if $curr ne $1;
302
303
72
                return $2;
304        }
305
306
0
        return $table;
307}
308
309sub _un_fq {
310
45
        args_pos
311
312          # required
313          my $self  => 'Object',
314          my $table => 'Str';
315
316
45
        if ( $table =~ /^(\w+)\.(\w+)$/ ) {
317
45
                return ( $1, $2 );
318        }
319
320
0
        return ( $self->_schema, $table );
321}
322
323sub _get_fk_ddl {
324
5
        my $self  = shift;
325
5
        my $table = shift;
326
5
        my $fk    = shift;
327
328
5
        my $sql = "show create table $table";
329
5
        my $sth = $self->_dbh->prepare($sql);
330
5
        $sth->execute;
331
332
5
        while ( my @a = $sth->fetchrow_array ) {
333
334
5
                foreach my $data (@a) {
335
10
                        my @b = split( /\n/, $data );
336
337
10
                        foreach my $item (@b) {
338
41
                                if ( $item =~ /CONSTRAINT `$fk` FOREIGN KEY/ ) {
339
5
                                        $item =~ s/^\s*//;    # remove leading ws
340
5
                                        $item =~ s/\s*//;     # remove trailing ws
341
5
                                        $item =~ s/,$//;      # remove trailing comma
342
343
5
                                        return "alter table $table add $item";
344                                }
345                        }
346                }
347        }
348}
349
350sub _column_exists {
351
259
        my $self = shift;
352
259
        my %a    = @_;
353
354
259
        my $table  = $a{table}  or confess "missing table arg";
355
259
        my $column = $a{column} or confess "missing column arg";
356
357
259
        my $desc_aref = $self->describe_table($table);
358
359
259
        foreach my $col_href (@$desc_aref) {
360
361
302
                if ( $col_href->{FIELD} eq $column ) {
362
259
                        return 1;
363                }
364        }
365
366
0
        return 0;
367}
368
369sub _verbose {
370
6122
        args_pos
371
372          # required
373          my $self => 'Object',
374          my $msg  => 'Str',
375
376          # optional
377          my $func_counter => { isa => 'Str', default => 0, optional => 1 };
378
379
6122
        my $caller_func = ( caller(1) )[3];
380
6122
        my $caller_line = ( caller(0) )[2];
381
382
6122
        my @caller_func = split( /\::/, $caller_func );
383
6122
        my $key = pop @caller_func;
384
385
6122
        if ( $self->_verbose_funcs->{$key} ) {
386
0
                print STDERR "[VERBOSE] $caller_func ($caller_line) ";
387
0
                print STDERR "[cnt=$func_counter]" if $func_counter;
388
0
                print STDERR "\n";
389
390
0
                chomp $msg;
391
0
                foreach my $nl ( split /\n/, $msg ) {
392
0
                        print STDERR "\t$nl\n";
393                }
394        }
395}
396
397sub _verbose_sql {
398
212
        args_pos
399
400          # required
401          my $self => 'Object',
402          my $sql  => 'Str',
403
404          # optional
405          my $func_counter => { isa => 'Int', default => 0, optional => 1 };
406
407
212
        my $caller_func = ( caller(1) )[3];
408
212
        my $caller_line = ( caller(0) )[2];
409
410
212
        my @caller_func = split( /\::/, $caller_func );
411
212
        my $key = pop @caller_func;
412
413
212
        if ( $self->_verbose_funcs->{$key} ) {
414
0
                print STDERR "[VERBOSE] $caller_func ($caller_line) ";
415
0
                print STDERR "[cnt=$func_counter]" if $func_counter;
416
0
                print STDERR "\n";
417
418
0
                $sql = SQL::Beautify->new( query => $sql )->beautify;
419
0
                foreach my $l ( split /\n/, $sql ) {
420
0
                        print STDERR "\t$l\n";
421                }
422        }
423}
424
425#################################################################
426##################### PUBLIC METHODS ############################
427#################################################################
428
429 - 446
=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
447
448 - 455
=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
456
457sub apply_ddl {
458
1
        args_pos
459
460          # required
461          my $self       => 'Object',
462          my $stmts_aref => 'ArrayRef';
463
464
1
        foreach my $stmt (@$stmts_aref) {
465
5
                $self->_dbh->do($stmt);
466        }
467
468
1
        $self->clear_cache;
469}
470
471 - 486
=item describe_column(table => $table, column => $column)

Returns a hashref for the requested column.

Hash elements for each column:

    DEFAULT
    EXTRA
    FIELD
    KEY
    NULL
    TYPE
           
See MySQL documentation for more info on "describe <table>".
 
=cut
487
488sub describe_column {
489
259
        args
490
491          # required
492          my $self   => 'Object',
493          my $table  => 'Str',
494          my $column => 'Str';
495
496
259
        if ( !$self->_column_exists( table => $table, column => $column ) ) {
497
0
                confess "column $column does not exist in table $table";
498        }
499
500
259
        my $col_aref = $self->describe_table($table);
501
502
259
        foreach my $col_href (@$col_aref) {
503
302
                if ( $col_href->{FIELD} =~ /^$column$/i ) {
504
259
                        return $col_href;
505                }
506        }
507}
508
509 - 528
=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
529
530sub describe_table {
531
1646
        my $self  = shift;
532
1646
        my $table = shift;
533
534
1646
        $table = $self->_fq( table => $table, fq => 1 );
535
536
1646
        my $cache = '_describe_cache';
537
538
1646
        if ( defined( $self->$cache->{$table} ) ) {
539
1631
                return $self->$cache->{$table}->data;
540        }
541
542
15
        my $sql = qq{
543        describe $table
544    };
545
546
15
        my $dbh = $self->_dbh;
547
15
        my $sth = $dbh->prepare($sql);
548
15
        $sth->execute;
549
550
15
        my @cols;
551
15
        while ( my $row = $sth->fetchrow_hashref ) {
552
29
                push( @cols, {%$row} );
553        }
554
555
15
        $self->$cache->{$table} = MySQL::Util::Data::Cache->new( data => \@cols );
556
15
        return \@cols;
557}
558
559 - 567
=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
568
569sub drop_fks {
570
1
        my $self  = shift;
571
1
        my $table = shift;
572
573
1
        my @tables;
574
1
        if ( !defined($table) ) {
575
1
                my $tables_aref = $self->get_tables;
576
1
                return [] if !defined($tables_aref);
577
578
1
                @tables = @$tables_aref;
579        }
580        else {
581
0
                push( @tables, $table );
582        }
583
584
1
        my @ret;
585
1
        foreach my $table (@tables) {
586
587
9
                my $fqtn     = $self->_schema . ".$table";
588
9
                my $fks_href = $self->get_fk_constraints($table);
589
590
9
                foreach my $fk ( keys %$fks_href ) {
591
592
5
                        push( @ret, $self->_get_fk_ddl( $table, $fk ) );
593
594
5
                        my $sql = qq{
595                alter table $table
596                drop foreign key $fk
597            };
598
5
                        $self->_dbh->do($sql);
599
600
5
                        $self->_constraint_cache->{$fqtn} = undef;
601                }
602        }
603
604
1
        return [@ret];
605}
606
607 - 619
=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
620
621sub get_ak_constraints {
622
227
        my $self = shift;
623
227
        my $table = shift or confess "missing table arg";
624
625
226
        $table = $self->_fq( table => $table, fq => 1 );
626
627
226
        my $cons = $self->get_constraints($table);
628
629
224
        my $ret;
630
224
        foreach my $con_name ( keys(%$cons) ) {
631
451
                if ( $cons->{$con_name}->[0]->{CONSTRAINT_TYPE} eq 'UNIQUE' ) {
632
11
                        $ret->{$con_name} = $cons->{$con_name};
633                }
634        }
635
636
224
        return $ret;
637}
638
639 - 650
=item get_ak_indexes($table)

Returns a hashref of the alternate key indexes for a given table.  Returns
an empty hashref if one was not 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
651
652sub get_ak_indexs {
653
654        # for backwards compatibility
655
1
        my $self = shift;
656
1
        return $self->get_ak_indexes(@_);
657}
658
659sub get_ak_indexes {
660
4
        args_pos my $self => 'Object',
661          my $table       => 'Str';
662
663
3
        if ( $table !~ /\./ ) {
664
2
                $table = $self->_schema . ".$table";
665        }
666
667
3
        my $href    = {};
668
3
        my $indexes = $self->get_indexes($table);
669
670
3
        foreach my $index ( keys(%$indexes) ) {
671
15
                if ( $indexes->{$index}->[0]->{NON_UNIQUE} == 0 ) {
672
9
                        $href->{$index} = $indexes->{$index};
673                }
674        }
675
676
3
        return $href;
677}
678
679 - 684
=item get_ak_names($table)

Returns an arrayref of alternate key constraints.  Returns undef if none
were found.

=cut
685
686sub get_ak_names {
687
2
        my $self = shift;
688
2
        my $table = shift || confess "missing table arg";
689
690
1
        if ( $self->has_ak($table) ) {
691
1
                my $href = $self->get_ak_constraints($table);
692
1
                return ( keys %$href );
693        }
694
695
0
        return;
696}
697
698 - 711
=item get_constraint(table => $table, name => $constraint_name)

Returns an arrayref for the requested constraints on a given table.  Throws
an error if the constraint is not found.

The structure of the returned data is:

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

Hash elements for each column:

    see get_constraints()

=cut
712
713sub get_constraint {
714
55
        args
715
716          # required
717          my $self => 'Object',
718          my $name => 'Str',
719
720          # optional
721          my $schema => { isa => 'Str', optional => 1 },
722          my $table  => { isa => 'Str', optional => 1 };
723
724
55
        my ( $unfq_schema, $unfq_table, $fq_table );
725
726
55
        if ( defined $table ) {
727
45
                ( $unfq_schema, $unfq_table ) = $self->_un_fq($table);
728
45
                if ($schema) {
729
0
                        if ( $unfq_schema ne $schema ) {
730
0
                                confess "schema arg $schema does not match table $table";
731                        }
732                }
733
734
45
                $fq_table = $self->_fq(
735                        table  => $unfq_table,
736                        fq     => 1,
737                        schema => $unfq_schema
738                );
739        }
740
741
55
        if ( defined $fq_table ) {
742
45
                my $cons_href = $self->get_constraints($fq_table);
743
744
45
                foreach my $cons_name ( keys %$cons_href ) {
745
46
                        if ( $cons_name eq $name ) {
746
45
                                return $cons_href->{$cons_name};
747                        }
748                }
749
750
0
                confess "failed to find constraint $name for table $fq_table";
751        }
752
753
10
        $schema = $self->_schema if !$schema;
754
755        #
756        # search cache for the constraint name across tables
757        #
758
10
        my $cache = '_constraint_cache';
759
760
10
10
        foreach my $t ( keys %{ $self->$cache } ) {
761
762
18
                if ( defined( $self->$cache->{$t} ) ) {
763
18
                        my $data_href = $self->$cache->{$t}->data;
764
765
18
                        foreach my $cons_name ( keys %$data_href ) {
766
30
                                if ( $cons_name eq $name ) {
767
768
10
                                        return $data_href->{$cons_name};
769                                }
770                        }
771                }
772        }
773
774
0
        my $sql = qq{
775        select distinct tc.table_name
776        from information_schema.table_constraints tc
777        where  tc.constraint_schema = '$schema'
778    };
779
780
0
        if ( !$self->span ) {
781
0
                $sql .= qq{
782          and (referenced_table_schema = '$schema' or referenced_table_schema is null)
783        };
784        }
785
786
0
        my $dbh = $self->_dbh;
787
0
        my $sth = $dbh->prepare($sql);
788
0
        $sth->execute;
789
790
0
        while ( my ($t) = $sth->fetchrow_array ) {
791
0
                my $cons_href = $self->get_constraints( table => $t );
792
793
0
                foreach my $cons_name ( keys %$cons_href ) {
794
0
                        if ( $cons_name eq $name ) {
795
0
                                $sth->finish;
796
0
                                return $cons_href->{$cons_name};
797                        }
798                }
799        }
800
801
0
        confess "failed to find constraint name $name";
802}
803
804 - 826
=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_NAME
    TABLE_NAME
    CONSTRAINT_SCHEMA
    CONSTRAINT_TYPE
    COLUMN_NAME
    ORDINAL_POSITION
    POSITION_IN_UNIQUE_CONSTRAINT
    REFERENCED_COLUMN_NAME
    REFERENCED_TABLE_SCHEMA
    REFERENCED_TABLE_NAME
        
=cut
827
828sub get_constraints {
829
3460
        my $self = shift;
830
3460
        my $table = shift || confess "missing table arg";
831
832
3460
        $table = $self->_fq( table => $table, fq => 1 );
833
834
3460
        my ( $schema, $table_no_schema ) = split( /\./, $table );
835
836
3460
        my $cache = '_constraint_cache';
837
838
3460
        if ( defined( $self->$cache->{$table} ) ) {
839
3418
                return $self->$cache->{$table}->data;
840        }
841
842
42
        confess "table '$table' does not exist: " if !$self->table_exists($table);
843
844
36
        my $sql = qq{
845        select kcu.constraint_name, tc.constraint_type, column_name,
846          ordinal_position, position_in_unique_constraint, referenced_table_schema,
847          referenced_table_name, referenced_column_name, tc.constraint_schema
848        from information_schema.table_constraints tc,
849          information_schema.key_column_usage kcu
850        where tc.table_name = '$table_no_schema'
851          and tc.table_name = kcu.table_name
852          and tc.constraint_name = kcu.constraint_name
853          and tc.constraint_schema = '$schema'
854          and kcu.constraint_schema = tc.constraint_schema
855    };
856
857
36
        if ( !$self->span ) {
858
36
                $sql .= qq{
859          and (referenced_table_schema = '$schema' or referenced_table_schema is null)
860        };
861        }
862
863
36
        $sql .= qq{ order by constraint_name, ordinal_position };
864
865
36
        my $dbh = $self->_dbh;
866
36
        my $sth = $dbh->prepare($sql);
867
36
        $sth->execute;
868
869
36
        my $href = {};
870
36
        while ( my $row = $sth->fetchrow_hashref ) {
871
872
72
                my $name = $row->{CONSTRAINT_NAME};
873
72
63
                if ( !defined( $href->{$name} ) ) { $href->{$name} = [] }
874
875
72
                $row->{TABLE_NAME} = $self->_fq( table => $table, fq => 0 );
876
877
72
72
                push( @{ $href->{$name} }, {%$row} );
878        }
879
880
36
        $self->$cache->{$table} = MySQL::Util::Data::Cache->new( data => $href );
881
36
        return $href;
882}
883
884 - 888
=item get_dbname()

Returns the name of the current schema/database.

=cut
889
890sub get_dbname {
891
8
        my $self = shift;
892
8
        confess "get_dbname does not take any parameters" if @_;
893
894
7
        return $self->_schema;
895}
896
897 - 916
=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 |
 -----------       -----------


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
917
918sub get_depth {
919
290
        my $self = shift;
920
290
        my $table = shift or confess "missing table arg";
921
922
289
        if ( $table !~ /\./ ) {
923
15
                $table = $self->_schema . ".$table";
924        }
925
926
289
        my $cache = '_depth_cache';
927
928
289
        if ( defined( $self->{$cache}->{$table} ) ) {
929
270
                return $self->{$cache}->{$table};
930        }
931
932
19
        my $dbh = $self->_dbh;
933
934
19
        my $fk_cons = $self->get_fk_constraints($table);
935
936
18
        my $depth = 0;
937
938
18
        foreach my $fk_name ( keys(%$fk_cons) ) {
939
12
                my $parent_table =
940                    $fk_cons->{$fk_name}->[0]->{REFERENCED_TABLE_SCHEMA} . '.'
941                  . $fk_cons->{$fk_name}->[0]->{REFERENCED_TABLE_NAME};
942
943
12
0
                if ( $parent_table eq $table ) { next }    # self referencing table
944
945
12
                my $parent_depth = $self->get_depth($parent_table);
946
12
9
                if ( $parent_depth >= $depth ) { $depth = $parent_depth + 1 }
947        }
948
949
18
        $self->{$cache}->{$table} = $depth;
950
951
18
        return $depth;
952}
953
954 - 960
=item get_fk_column_names(table => $table, [name => $constraint_name])

If name is specified, returns an array of columns that participate in the
foreign key constraint.  If name is not specified, returns an array of columns
that participate an any foreign key constraint on the table.

=cut
961
962sub get_fk_column_names {
963
215
        args
964
965          # required
966          my $self  => 'Object',
967          my $table => 'Str',
968
969          # optional
970          my $name => { isa => 'Str', optional => 1 };
971
972
215
        $table = $self->_fq( table => $table, fq => 1 );
973
974
215
        my @columns;
975
976
215
        my $fks_href = $self->get_fk_constraints($table);
977
978
215
        foreach my $fk_name ( keys %$fks_href ) {
979
980
210
                next if ( $name and $name ne $fk_name );
981
982
210
210
                foreach my $fk_href ( @{ $fks_href->{$fk_name} } ) {
983
984
210
                        my $col = $fk_href->{COLUMN_NAME};
985
210
                        push( @columns, $col );
986                }
987        }
988
989
215
        return @columns;
990}
991
992 - 1005
=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
1006
1007sub get_fk_constraints {
1008
2317
        args_pos
1009
1010          # required
1011          my $self => 'Object',
1012
1013          # optional
1014          my $table => { isa => 'Str', optional => 1 };
1015
1016
2317
        if ( defined($table) and $table !~ /\./ ) {
1017
252
                $table = $self->_schema . ".$table";
1018        }
1019
1020
2317
        my @tables;
1021
2317
        if ( !defined($table) ) {
1022
3
                my $tables_aref = $self->get_tables;
1023
3
                return {} if !defined($tables_aref);
1024
1025
3
                @tables = @$tables_aref;
1026        }
1027        else {
1028
2314
                push( @tables, $table );
1029        }
1030
1031
2317
        my $href = {};
1032
1033
2317
        foreach my $table (@tables) {
1034
1035
2341
                my $cons_href = $self->get_constraints($table);
1036
2338
                foreach my $cons_name ( keys(%$cons_href) ) {
1037
1038
4811
                        my $cons_aref = $cons_href->{$cons_name};
1039
4811
                        foreach my $col_href (@$cons_aref) {
1040
1041
5695
                                my $type = $col_href->{CONSTRAINT_TYPE};
1042
1043
5695
                                if ( $type eq 'FOREIGN KEY' ) {
1044
2453
                                        $href->{$cons_name} = [@$cons_aref];
1045                                }
1046                        }
1047                }
1048        }
1049
1050
2314
        return $href;
1051}
1052
1053 - 1065
=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
1066
1067sub get_fk_indexes {
1068
3
        args_pos my $self => 'Object',
1069          my $table       => 'Str';
1070
1071
2
        if ( $table !~ /\./ ) {
1072
1
                $table = $self->_schema . ".$table";
1073        }
1074
1075
2
        my $href    = {};
1076
2
        my $cons    = $self->get_fk_constraints($table);
1077
2
        my $indexes = $self->get_indexes($table);
1078
1079
2
        foreach my $con_name ( keys(%$cons) ) {
1080
2
2
                my @con_cols = @{ $cons->{$con_name} };
1081
1082
2
                foreach my $index_name ( keys(%$indexes) ) {
1083
6
6
                        my @index_cols = @{ $indexes->{$index_name} };
1084
1085
6
                        if ( scalar(@con_cols) == scalar(@index_cols) ) {
1086
1087
6
                                my $match = 1;
1088
6
                                for ( my $i = 0 ; $i < scalar(@con_cols) ; $i++ ) {
1089
6
                                        if ( $index_cols[$i]->{COLUMN_NAME} ne
1090                                                $con_cols[$i]->{COLUMN_NAME} )
1091                                        {
1092
4
                                                $match = 0;
1093
4
                                                last;
1094                                        }
1095                                }
1096
1097
6
                                if ($match) {
1098
2
                                        $href->{$index_name} = $indexes->{$index_name};
1099
2
                                        last;
1100                                }
1101                        }
1102                }
1103        }
1104
1105
2
        return $href;
1106}
1107
1108 - 1132
=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
1133
1134sub get_indexes {
1135
12
        my $self = shift;
1136
12
        my $table = shift or confess "missing table arg";
1137
1138
10
        if ( $table !~ /\./ ) {
1139
4
                $table = $self->_schema . ".$table";
1140        }
1141
1142
10
        my %h       = ();
1143
10
        my $indexes = $self->_get_indexes_arrayref($table);
1144
1145
9
        foreach my $index (@$indexes) {
1146
41
                my $key_name = $index->{KEY_NAME};
1147
41
                my $seq      = $index->{SEQ_IN_INDEX};
1148
1149
41
34
                if ( !exists( $h{$key_name} ) ) { $h{$key_name} = [] }
1150
1151
41
                $h{$key_name}->[ $seq - 1 ] = $index;
1152        }
1153
1154
9
        return \%h;
1155}
1156
1157 - 1163
=item get_max_depth()

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

See "get_depth" for additional info.

=cut
1164
1165sub get_max_depth {
1166
1
        my $self = shift;
1167
1168
1
        my $dbh = $self->_dbh;
1169
1170
1
        my $tables = $self->get_tables();
1171
1172
1
        my $max = 0;
1173
1
        foreach my $table (@$tables) {
1174
9
                my $depth = $self->get_depth($table);
1175
9
3
                if ( $depth > $max ) { $max = $depth }
1176        }
1177
1178
1
        return $max;
1179}
1180
1181 - 1192
=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
1193
1194sub get_other_constraints {
1195
2
        args_pos my $self => 'Object',
1196          my $table       => 'Str';
1197
1198
1
        if ( $table !~ /\./ ) {
1199
1
                $table = $self->_schema . ".$table";
1200        }
1201
1202
1
        my $fk = $self->get_fk_constraints($table);
1203
1
        my $ak = $self->get_ak_constraints($table);
1204
1205
1
        my $href = {};
1206
1
        my $cons = $self->get_constraints($table);
1207
1208
1
        foreach my $con_name ( keys(%$cons) ) {
1209
4
                my $type = $cons->{$con_name}->[0]->{CONSTRAINT_TYPE};
1210
1211
4
                next if $type eq 'PRIMARY KEY';
1212
3
                next if $type eq 'FOREIGN KEY';
1213
2
                next if $type eq 'UNIQUE';
1214
1215
0
                $href->{$con_name} = $cons->{$con_name};
1216        }
1217
1218
1
        return $href;
1219}
1220
1221 - 1232
=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
1233
1234sub get_other_indexes {
1235
2
        args_pos
1236
1237          # required
1238          my $self  => 'Object',
1239          my $table => 'Str';
1240
1241
1
        if ( $table !~ /\./ ) {
1242
1
                $table = $self->_schema . ".$table";
1243        }
1244
1245
1
        my $ak = $self->get_ak_indexes($table);
1246
1
        my $fk = $self->get_fk_indexes($table);
1247
1248
1
        my $href    = {};
1249
1
        my $indexes = $self->get_indexes($table);
1250
1251
1
        foreach my $name ( keys %$indexes ) {
1252
5
                next if $name eq 'PRIMARY';
1253
4
                next if defined( $ak->{$name} );
1254
2
                next if defined( $fk->{$name} );
1255
1256
1
                $href->{$name} = $indexes->{$name};
1257        }
1258
1259
1
        return $href;
1260}
1261
1262 - 1273
=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
1274
1275sub get_pk_constraint {
1276
765
        my $self  = shift;
1277
765
        my $table = shift;
1278
1279
765
        if ( $table !~ /\./ ) {
1280
0
                $table = $self->_schema . ".$table";
1281        }
1282
1283
765
        my $cons = $self->get_constraints($table);
1284
1285
764
        foreach my $con_name ( keys(%$cons) ) {
1286
884
                if ( $cons->{$con_name}->[0]->{CONSTRAINT_TYPE} eq 'PRIMARY KEY' ) {
1287
764
                        return $cons->{$con_name};
1288                }
1289        }
1290
1291
0
        return [];
1292}
1293
1294 - 1305
=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
1306
1307sub get_pk_index {
1308
2
        my $self  = shift;
1309
2
        my $table = shift;
1310
1311        #       if ($table !~ /\./) {
1312        #               $table = $self->_schema . ".$table";
1313        #       }
1314
1315
2
        my $href = $self->get_indexes($table);
1316
1317
1
        foreach my $name ( keys(%$href) ) {
1318
2
                if ( $name eq 'PRIMARY' )    # mysql forces this naming convention
1319                {
1320
1
                        return $href->{$name};
1321                }
1322        }
1323
1324
0
        return [];
1325}
1326
1327 - 1332
=item get_pk_name($table)

Returns the primary key constraint name for a given table.  Returns undef
if one does not exist.

=cut
1333
1334sub get_pk_name {
1335
116
        my $self = shift;
1336
116
        my $table = shift || confess "missing table arg";
1337
1338
116
        if ( $self->has_pk($table) ) {
1339
116
                return 'PRIMARY';    # mysql default
1340        }
1341
1342
0
        return;
1343}
1344
1345 - 1350
=item get_tables( )

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

=cut
1351
1352sub get_tables {
1353
9
        my $self = shift;
1354
1355
9
        my $dbh = $self->_dbh;
1356
1357
9
        my $tables = undef;
1358
9
        my $sth = $dbh->prepare("show full tables where Table_Type = 'BASE TABLE'");
1359
9
        $sth->execute;
1360
1361
9
        while ( my ($table) = $sth->fetchrow_array ) {
1362
81
                push( @$tables, $table );
1363        }
1364
1365
9
        return $tables;
1366}
1367
1368 - 1372
=item has_ak($table)

Returns true if the table has an alternate key or false if not.

=cut
1373
1374sub has_ak {
1375
223
        my $self = shift;
1376
223
        my $table = shift || confess "missing table arg";
1377
1378
222
        my $aks_href = $self->get_ak_constraints($table);
1379
1380
221
        return scalar keys %$aks_href;
1381}
1382
1383 - 1387
=item has_fks($table)
    
Returns true if the table has foreign keys or false if not. 
    
=cut
1388
1389sub has_fks {
1390
5
        my $self = shift;
1391
5
        my $table = shift || confess "missing table arg";
1392
1393
4
        my $fks_href = $self->get_fk_constraints($table);
1394
1395
3
        return scalar keys %$fks_href;
1396}
1397
1398 - 1402
=item has_pk($table)

Returns true if the table has a primary key or false if it does not.

=cut
1403
1404sub has_pk {
1405
549
        my $self = shift;
1406
549
        my $table = shift || confess "missing table arg";
1407
1408
549
        my $pk_aref = $self->get_pk_constraint($table);
1409
1410
548
        return scalar @$pk_aref;
1411}
1412
1413 - 1418
=item is_pk_auto_inc($table)

Returns true if the primary key is using the auto-increment feature or false
if it does not.

=cut
1419
1420sub is_pk_auto_inc {
1421
216
        my $self = shift;
1422
216
        my $table = shift || confess "missing table arg";
1423
1424
216
        if ( $self->has_pk($table) ) {
1425
216
                my $pk_aref = $self->get_pk_constraint($table);
1426
1427
216
                foreach my $col_href (@$pk_aref) {
1428
1429
257
                        my $col_name      = $col_href->{COLUMN_NAME};
1430
257
                        my $col_desc_href = $self->describe_column(
1431                                table  => $table,
1432                                column => $col_name
1433                        );
1434
1435
257
                        if ( $col_desc_href->{EXTRA} =~ /auto/ ) {
1436
100
                                return 1;
1437                        }
1438                }
1439        }
1440
1441
116
        return 0;
1442}
1443
1444 - 1448
=item is_column_nullable(table => $table, column => $column)

Returns true if column is nullable or false if it is not.

=cut
1449
1450sub is_column_nullable {
1451
3
        args
1452
1453          # required
1454          my $self   => 'Object',
1455          my $table  => 'Str',
1456          my $column => 'Str';
1457
1458
2
        my $desc = $self->describe_column( table => $table, column => $column );
1459
1460
2
        if ( $desc->{NULL} eq 'YES' ) {
1461
1
                return 1;
1462        }
1463
1464
1
        return 0;
1465}
1466
1467 - 1471
=item is_fk_column(table => $table, column => $column)

Returns true if column participates in a foreign key or false if it does not.

=cut
1472
1473sub is_fk_column {
1474
254
        my $self = shift;
1475
254
        my %a    = @_;
1476
1477
254
        my $table  = $a{table}  || confess "missing table arg";
1478
254
        my $column = $a{column} || confess "missing column arg";
1479
1480
254
        my $fks_href = $self->get_fk_constraints($table);
1481
1482
254
        foreach my $fk_name ( keys %$fks_href ) {
1483
1484
374
374
                foreach my $fk_href ( @{ $fks_href->{$fk_name} } ) {
1485
1486
374
                        if ( $fk_href->{COLUMN_NAME} eq $column ) {
1487
248
                                return 1;
1488                        }
1489                }
1490        }
1491
1492
6
        return 0;
1493}
1494
1495 - 1501
=item is_self_referencing($table, [$name => $constraint_name])

Returns true if the specified table has a self-referencing foreign key or
false if it does not.  If a constraint name is passed, it will only check
the constraint provided.

=cut
1502
1503sub is_self_referencing {
1504
554
        args
1505
1506          # required
1507          my $self  => 'Object',
1508          my $table => 'Str',
1509
1510          # optional
1511          my $name => { isa => 'Str', optional => 1 };
1512
1513
554
        my $fq_table = $self->_fq( table => $table, fq => 1 );
1514
1515
554
        my $fks_href = $self->get_fk_constraints($table);
1516
1517
554
        foreach my $con_name (%$fks_href) {
1518
686
                next if $name and $name ne $con_name;
1519
1520                #$hashref->{constraint_name}->[ { col1 }, { col2 } ]
1521                #
1522                #Hash elements for each column:
1523                #
1524                #    CONSTRAINT_SCHEMA
1525                #    CONSTRAINT_TYPE
1526                #    COLUMN_NAME
1527                #    ORDINAL_POSITION
1528                #    POSITION_IN_UNIQUE_CONSTRAINT
1529                #    REFERENCED_COLUMN_NAME
1530                #    REFERENCED_TABLE_SCHEMA
1531                #    REFERENCED_TABLE_NAME
1532
1533
4
4
                foreach my $pos_href ( @{ $fks_href->{$con_name} } ) {
1534
1535
2
                        my $ref_table  = $pos_href->{REFERENCED_TABLE_NAME};
1536
2
                        my $ref_schema = $pos_href->{REFERENCED_TABLE_SCHEMA};
1537
1538
2
                        my $ref_fq_table = $self->_fq(
1539                                table  => $ref_table,
1540                                fq     => 1,
1541                                schema => $ref_schema
1542                        );
1543
1544
2
                        if ( $ref_fq_table eq $fq_table ) {
1545
0
                                return 1;
1546                        }
1547                }
1548        }
1549
1550
554
        return 0;
1551}
1552
1553 - 1557
=item table_exists($table)

Returns true if table exists.  Otherwise returns false.

=cut
1558
1559sub table_exists {
1560
48
        my $self = shift;
1561
48
        my $table = shift or confess "missing table arg";
1562
1563
47
        my $fq_table = $table;
1564
47
        if ( $table !~ /\./ ) {
1565
2
                $fq_table = $self->_schema . ".$table";
1566        }
1567
1568
47
        my $dbh = $self->_dbh;
1569
1570
47
        my ( $schema, $nofq_table ) = split( /\./, $fq_table );
1571
47
        if ( $schema ne $self->_schema ) {
1572
1573                # quietly change the schema so "show tables like ..." works
1574
2
                $dbh->do("use $schema");
1575        }
1576
1577
47
        my $sql = qq{show tables like '$nofq_table'};
1578
47
        my $sth = $dbh->prepare($sql);
1579
47
        $sth->execute;
1580
1581
47
        my $cnt = 0;
1582
47
        while ( $sth->fetchrow_array ) {
1583
39
                $cnt++;
1584        }
1585
1586
47
        if ( $schema ne $self->_schema ) {
1587
1588                # quietly change schema back
1589
2
                $dbh->do( "use " . $self->_schema );
1590        }
1591
1592
47
        return $cnt;
1593}
1594
1595 - 1599
=item use_db($dbname)

Used for switching database context.  Returns true on success.

=cut
1600
1601sub use_db {
1602
4
        my $self   = shift;
1603
4
        my $dbname = shift;
1604
1605
4
        $self->_dbh->do("use $dbname");
1606
4
        $self->_schema($dbname);
1607
4
        $self->clear_cache;
1608
1609
4
        return 1;
1610}
1611
1612=back
1613
1614 - 1626
=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
1627
1628sub clear_cache {
1629
5
        my $self = shift;
1630
1631
5
        $self->_index_cache(      {} );
1632
5
        $self->_constraint_cache( {} );
1633
5
        $self->_depth_cache(      {} );
1634
5
        $self->_describe_cache(   {} );
1635}
1636
1637 - 1644
=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_db" and switched context along the way, the 
returned dbh will also be in that same context.

=cut
1645
1646sub clone_dbh {
1647
5
        my $self = shift;
1648
1649
5
        my $dbh =
1650          $self->_dbh->clone( { AutoCommit => 0 } );    # workaround dbd:mysql bug
1651
5
        $dbh->{AutoCommit} = 1;                         # workaround dbd:mysql bug
1652
5
        $dbh->do( "use " . $self->_schema );
1653
1654
5
        return $dbh;
1655}
1656
1657=back
1658
1659 - 1703
=head1 SEE ALSO

MySQL::Util::Data::Create

=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

=cut
1704
1705#=head1 ACKNOWLEDGEMENTS
1706
1707 - 1718
=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
1719
1720__PACKAGE__->meta->make_immutable;    # moose stuff
1721
17221;