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

# File Coverage

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

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

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

    =head1 VERSION

    Version 0.29

    =cut
23 |
24 |  |  |  |  | our $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 |
81 |  |  |  |  | has 'dsn' => (
82 |  |  |  |  | is => 'ro',
83 |  |  |  |  | isa => 'Str',
84 |  |  |  |  | required => 0
85 |  |  |  |  | );
86 |
87 |  |  |  |  | has 'user' => (
88 |  |  |  |  | is => 'ro',
89 |  |  |  |  | isa => 'Str',
90 |  |  |  |  | required => 0
91 |  |  |  |  | );
92 |
93 |  |  |  |  | has 'pass' => (
94 |  |  |  |  | is => 'ro',
95 |  |  |  |  | required => 0,
96 |  |  |  |  | default => undef
97 |  |  |  |  | );
98 |
99 |  |  |  |  | has 'span' => (
100 |  |  |  |  | is => 'ro',
101 |  |  |  |  | isa => 'Int',
102 |  |  |  |  | required => 0,
103 |  |  |  |  | default => 0
104 |  |  |  |  | );
105 |
106 |  |  |  |  | has 'dbh' => (
107 |  |  |  |  | is => 'rw',
108 |  |  |  |  | isa => 'Object',
109 |  |  |  |  | );
110 |
111 |  |  |  |  | #
112 |  |  |  |  | # private variables
113 |  |  |  |  | #
114 |
115 |  |  |  |  | has '_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 |
122 |  |  |  |  | has '_index_cache' => (
123 |  |  |  |  | is => 'rw',
124 |  |  |  |  | isa => 'HashRef[MySQL::Util::Data::Cache]',
125 |  |  |  |  | init_arg => undef,
126 |  |  |  |  | default => sub { {} }
127 |  |  |  |  | );
128 |
129 |  |  |  |  | has '_constraint_cache' => (
130 |  |  |  |  | is => 'rw',
131 |  |  |  |  | isa => 'HashRef[MySQL::Util::Data::Cache]',
132 |  |  |  |  | init_arg => undef,
133 |  |  |  |  | default => sub { {} }
134 |  |  |  |  | );
135 |
136 |  |  |  |  | has '_depth_cache' => (
137 |  |  |  |  | is => 'rw',
138 |  |  |  |  | isa => 'HashRef',
139 |  |  |  |  | init_arg => undef,
140 |  |  |  |  | default => sub { {} }
141 |  |  |  |  | );
142 |
143 |  |  |  |  | has '_describe_cache' => (
144 |  |  |  |  | is => 'rw',
145 |  |  |  |  | isa => 'HashRef',
146 |  |  |  |  | init_arg => undef,
147 |  |  |  |  | default => sub { {} }
148 |  |  |  |  | );
149 |
150 |  |  |  |  | has '_schema' => (
151 |  |  |  |  | is => 'rw',
152 |  |  |  |  | isa => 'Str',
153 |  |  |  |  | required => 0,
154 |  |  |  |  | init_arg => undef,
155 |  |  |  |  | );
156 |
157 |  |  |  |  | has _verbose_funcs => (
158 |  |  |  |  | is => 'rw',
159 |  |  |  |  | isa => 'HashRef',
160 |  |  |  |  | required => 0,
161 |  |  |  |  | default => sub { {} },
162 |  |  |  |  | );
163 |
164 |  |  |  |  | ##############################################################################
165 |
166 |  |  |  |  | sub BUILD {
167 | 7 |  |  | 7 | my $self = shift;
168 |
169 | 7 | 50 |  |  | 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 | 100 |  |  | 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 | 50 |  |  | 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 |
228 |  |  |  |  | sub _get_fk_column {
229 | 246 |  |  | 246 | my $self = shift;
230 | 246 |  |  |  | my %a = @_;
231 |
232 | 246 |  | 33 |  | my $table = $a{table} || confess "missing table arg";
233 | 246 |  | 33 |  | 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 | 100 |  |  | 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 |
250 |  |  |  |  | sub _get_indexes_arrayref {
251 | 10 |  |  | 10 | my $self = shift;
252 | 10 |  |  |  | my $table = shift;
253 |
254 | 10 |  |  |  | my $cache = '_index_cache';
255 |
256 | 10 | 100 |  |  | 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 |
273 |  |  |  |  | sub _fq {
274 | 9199 |  |  | 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 | 100 |  |  | if ($fq) {
285 | 9127 | 100 100 |  |  | 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 | 50 |  |  | if ( $table =~ /^(\w+)\.(\w+)$/ ) {
296 | 72 |  |  |  | my $curr = $self->_schema;
297 |
298 | 72 | 50 |  |  | 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 |
309 |  |  |  |  | sub _un_fq {
310 | 45 |  |  | 45 | args_pos
311 |
312 |  |  |  |  | # required
313 |  |  |  |  | my $self => 'Object',
314 |  |  |  |  | my $table => 'Str';
315 |
316 | 45 | 50 |  |  | if ( $table =~ /^(\w+)\.(\w+)$/ ) {
317 | 45 |  |  |  | return ( $1, $2 );
318 |  |  |  |  | }
319 |
320 | 0 |  |  |  | return ( $self->_schema, $table );
321 |  |  |  |  | }
322 |
323 |  |  |  |  | sub _get_fk_ddl {
324 | 5 |  |  | 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 | 100 |  |  | 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 |
350 |  |  |  |  | sub _column_exists {
351 | 259 |  |  | 259 | my $self = shift;
352 | 259 |  |  |  | my %a = @_;
353 |
354 | 259 | 50 |  |  | my $table = $a{table} or confess "missing table arg";
355 | 259 | 50 |  |  | 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 | 100 |  |  | if ( $col_href->{FIELD} eq $column ) {
362 | 259 |  |  |  | return 1;
363 |  |  |  |  | }
364 |  |  |  |  | }
365 |
366 | 0 |  |  |  | return 0;
367 |  |  |  |  | }
368 |
369 |  |  |  |  | sub _verbose {
370 | 6122 |  |  | 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 | 50 |  |  | if ( $self->_verbose_funcs->{$key} ) {
386 | 0 |  |  |  | print STDERR "[VERBOSE] $caller_func ($caller_line) ";
387 | 0 | 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 |
397 |  |  |  |  | sub _verbose_sql {
398 | 212 |  |  | 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 | 50 |  |  | if ( $self->_verbose_funcs->{$key} ) {
414 | 0 |  |  |  | print STDERR "[VERBOSE] $caller_func ($caller_line) ";
415 | 0 | 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 |
457 |  |  |  |  | sub apply_ddl {
458 | 1 |  |  | 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 |
488 |  |  |  |  | sub describe_column {
489 | 259 |  |  | 259 | args
490 |
491 |  |  |  |  | # required
492 |  |  |  |  | my $self => 'Object',
493 |  |  |  |  | my $table => 'Str',
494 |  |  |  |  | my $column => 'Str';
495 |
496 | 259 | 50 |  |  | 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 | 100 |  |  | 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 |
530 |  |  |  |  | sub describe_table {
531 | 1646 |  |  | 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 | 100 |  |  | 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 |
569 |  |  |  |  | sub drop_fks {
570 | 1 |  |  | 1 | my $self = shift;
571 | 1 |  |  |  | my $table = shift;
572 |
573 | 1 |  |  |  | my @tables;
574 | 1 | 50 |  |  | if ( !defined($table) ) {
575 | 1 |  |  |  | my $tables_aref = $self->get_tables;
576 | 1 | 50 |  |  | 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 |
621 |  |  |  |  | sub get_ak_constraints {
622 | 227 |  |  | 227 | my $self = shift;
623 | 227 | 100 |  |  | 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 | 100 |  |  | 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 |
652 |  |  |  |  | sub get_ak_indexs {
653 |
654 |  |  |  |  | # for backwards compatibility
655 | 1 |  |  | 1 | my $self = shift;
656 | 1 |  |  |  | return $self->get_ak_indexes(@_);
657 |  |  |  |  | }
658 |
659 |  |  |  |  | sub get_ak_indexes {
660 | 4 |  |  | 4 | args_pos my $self => 'Object',
661 |  |  |  |  | my $table => 'Str';
662 |
663 | 3 | 100 |  |  | 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 | 100 |  |  | 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 |
686 |  |  |  |  | sub get_ak_names {
687 | 2 |  |  | 2 | my $self = shift;
688 | 2 |  | 67 |  | my $table = shift || confess "missing table arg";
689 |
690 | 1 | 50 |  |  | 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 |
713 |  |  |  |  | sub get_constraint {
714 | 55 |  |  | 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 | 100 |  |  | if ( defined $table ) {
727 | 45 |  |  |  | ( $unfq_schema, $unfq_table ) = $self->_un_fq($table);
728 | 45 | 50 |  |  | if ($schema) {
729 | 0 | 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 | 100 |  |  | 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 | 100 |  |  | 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 | 50 |  |  | $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 | 50 |  |  | 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 | 100 |  |  | 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 | 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 | 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 |
828 |  |  |  |  | sub get_constraints {
829 | 3460 |  |  | 3460 | my $self = shift;
830 | 3460 |  | 33 |  | 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 | 100 |  |  | if ( defined( $self->$cache->{$table} ) ) {
839 | 3418 |  |  |  | return $self->$cache->{$table}->data;
840 |  |  |  |  | }
841 |
842 | 42 | 100 |  |  | 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 | 50 |  |  | 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 | 100 |  |  | 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 |
890 |  |  |  |  | sub get_dbname {
891 | 8 |  |  | 8 | my $self = shift;
892 | 8 | 100 |  |  | 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 |
918 |  |  |  |  | sub get_depth {
919 | 290 |  |  | 290 | my $self = shift;
920 | 290 | 100 |  |  | my $table = shift or confess "missing table arg";
921 |
922 | 289 | 100 |  |  | if ( $table !~ /\./ ) {
923 | 15 |  |  |  | $table = $self->_schema . ".$table";
924 |  |  |  |  | }
925 |
926 | 289 |  |  |  | my $cache = '_depth_cache';
927 |
928 | 289 | 100 |  |  | 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 | 50 |  |  | if ( $parent_table eq $table ) { next } # self referencing table
944 |
945 | 12 |  |  |  | my $parent_depth = $self->get_depth($parent_table);
946 | 12 9 | 100 |  |  | 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 |
962 |  |  |  |  | sub get_fk_column_names {
963 | 215 |  |  | 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 | 50 | 33 |  | 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 |
1007 |  |  |  |  | sub get_fk_constraints {
1008 | 2317 |  |  | 2317 | args_pos
1009 |
1010 |  |  |  |  | # required
1011 |  |  |  |  | my $self => 'Object',
1012 |
1013 |  |  |  |  | # optional
1014 |  |  |  |  | my $table => { isa => 'Str', optional => 1 };
1015 |
1016 | 2317 | 100 | 100 |  | if ( defined($table) and $table !~ /\./ ) {
1017 | 252 |  |  |  | $table = $self->_schema . ".$table";
1018 |  |  |  |  | }
1019 |
1020 | 2317 |  |  |  | my @tables;
1021 | 2317 | 100 |  |  | if ( !defined($table) ) {
1022 | 3 |  |  |  | my $tables_aref = $self->get_tables;
1023 | 3 | 50 |  |  | 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 | 100 |  |  | 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 |
1067 |  |  |  |  | sub get_fk_indexes {
1068 | 3 |  |  | 3 | args_pos my $self => 'Object',
1069 |  |  |  |  | my $table => 'Str';
1070 |
1071 | 2 | 100 |  |  | 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 | 50 |  |  | 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 | 100 |  |  | 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 | 100 |  |  | 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 |
1134 |  |  |  |  | sub get_indexes {
1135 | 12 |  |  | 12 | my $self = shift;
1136 | 12 | 100 |  |  | my $table = shift or confess "missing table arg";
1137 |
1138 | 10 | 100 |  |  | 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 | 100 |  |  | 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 |
1165 |  |  |  |  | sub get_max_depth {
1166 | 1 |  |  | 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 | 100 |  |  | 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 |
1194 |  |  |  |  | sub get_other_constraints {
1195 | 2 |  |  | 2 | args_pos my $self => 'Object',
1196 |  |  |  |  | my $table => 'Str';
1197 |
1198 | 1 | 50 |  |  | 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 | 100 |  |  | next if $type eq 'PRIMARY KEY';
1212 | 3 | 100 |  |  | next if $type eq 'FOREIGN KEY';
1213 | 2 | 50 |  |  | 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 |
1234 |  |  |  |  | sub get_other_indexes {
1235 | 2 |  |  | 2 | args_pos
1236 |
1237 |  |  |  |  | # required
1238 |  |  |  |  | my $self => 'Object',
1239 |  |  |  |  | my $table => 'Str';
1240 |
1241 | 1 | 50 |  |  | 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 | 100 |  |  | next if $name eq 'PRIMARY';
1253 | 4 | 100 |  |  | next if defined( $ak->{$name} );
1254 | 2 | 100 |  |  | 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 |
1275 |  |  |  |  | sub get_pk_constraint {
1276 | 765 |  |  | 765 | my $self = shift;
1277 | 765 |  |  |  | my $table = shift;
1278 |
1279 | 765 | 50 |  |  | 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 | 100 |  |  | 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 |
1307 |  |  |  |  | sub get_pk_index {
1308 | 2 |  |  | 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 | 100 |  |  | 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 |
1334 |  |  |  |  | sub get_pk_name {
1335 | 116 |  |  | 116 | my $self = shift;
1336 | 116 |  | 33 |  | my $table = shift || confess "missing table arg";
1337 |
1338 | 116 | 50 |  |  | 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 |
1352 |  |  |  |  | sub get_tables {
1353 | 9 |  |  | 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 |
1374 |  |  |  |  | sub has_ak {
1375 | 223 |  |  | 223 | my $self = shift;
1376 | 223 |  | 67 |  | 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 |
1389 |  |  |  |  | sub has_fks {
1390 | 5 |  |  | 5 | my $self = shift;
1391 | 5 |  | 67 |  | 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 |
1404 |  |  |  |  | sub has_pk {
1405 | 549 |  |  | 549 | my $self = shift;
1406 | 549 |  | 33 |  | 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 |
1420 |  |  |  |  | sub is_pk_auto_inc {
1421 | 216 |  |  | 216 | my $self = shift;
1422 | 216 |  | 33 |  | my $table = shift || confess "missing table arg";
1423 |
1424 | 216 | 50 |  |  | 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 | 100 |  |  | 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 |
1450 |  |  |  |  | sub is_column_nullable {
1451 | 3 |  |  | 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 | 100 |  |  | 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 |
1473 |  |  |  |  | sub is_fk_column {
1474 | 254 |  |  | 254 | my $self = shift;
1475 | 254 |  |  |  | my %a = @_;
1476 |
1477 | 254 |  | 33 |  | my $table = $a{table} || confess "missing table arg";
1478 | 254 |  | 33 |  | 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 | 100 |  |  | 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 |
1503 |  |  |  |  | sub is_self_referencing {
1504 | 554 |  |  | 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 | 100 | 67 |  | 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 | 50 |  |  | 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 |
1559 |  |  |  |  | sub table_exists {
1560 | 48 |  |  | 48 | my $self = shift;
1561 | 48 | 100 |  |  | my $table = shift or confess "missing table arg";
1562 |
1563 | 47 |  |  |  | my $fq_table = $table;
1564 | 47 | 100 |  |  | 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 | 100 |  |  | 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 | 100 |  |  | 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 |
1601 |  |  |  |  | sub use_db {
1602 | 4 |  |  | 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 |
1628 |  |  |  |  | sub clear_cache {
1629 | 5 |  |  | 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 |
1646 |  |  |  |  | sub clone_dbh {
1647 | 5 |  |  | 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 |
1722 |  |  |  |  | 1;