File Coverage

File:blib/lib/MySQL/Util/Data/Create.pm
Coverage:82.4%

linestmtbrancondsubcode
1package MySQL::Util::Data::Create;
2
3
3
3
3
use Moose::Role;
4
3
3
3
use Data::Dumper;
5
3
3
3
use SQL::Beautify;
6
3
3
3
use Symbol::Util 'delete_sub';
7
3
3
3
use Smart::Args;
8
3
3
3
use feature 'state';
9
3
3
3
use List::MoreUtils 'uniq';
10
3
3
3
use Carp 'croak';
11
3
3
3
use Config::General;
12
13 - 22
=head1 NAME

MySQL::Util::Data::Create - A Moose::Role for MySQL::Util.  Do not call this
                            directly!

=head1 VERSION

Version 0.01

=cut
23
24our $VERSION = '0.01';
25
26 - 84
=head1 SYNOPSIS

use MySQL::Util;

my $util = MySQL::Util->new(...);
    
$util->create_data(
            table    => 'sometable',
            rows     => 500,
            defaults => {
                my_id        => 10,
                enabled_flag => 1
        });

=head1 SUBROUTINES/METHODS

=head2 create_data( %args )

Creates X number of rows in the specified table.  Columns are populated with
random data if it can't be derived through auto-increment, foreign-keys, or
enum.  If defaults are provided they are used in favor over random values.

=head3 Arguments:

=over

=item table

name of table you want to create data in

=item rows

how many rows to create

=item defaults (optional)

A hashref that contains default data values for columns that may be
encountered.  If a column default is specified for which no column
exists, it will be ignored.  Each key is the column name and
each value is the default value you wish to use.

=back

=head3 Examples:

    $util->create_data(
        table     => 'mytable',
        rows => 50,
        defaults  => {
                        id => 44,
                        age => 25
                    } );

    $util->create_data(
        table     => 'students',
        rows => 1000
    );
    
=cut
85
86has _create_cache => (
87    is       => 'rw',
88    isa      => 'HashRef',
89    required => 0,
90    default  => sub { {} },
91);
92
93has _table_aliases => (
94    is       => 'rw',
95    isa      => 'HashRef',
96    required => 0,
97    default  => sub { {} },
98);
99
100has _last_table_alias_num => (
101    is       => 'rw',
102    isa      => 'Int',
103    required => 0,
104    default  => 0
105);
106
107sub _get_table_alias {
108
1007
    args
109
110        # required
111        my $self  => 'Object',
112        my $table => 'Str';
113
114
1007
    $table = $self->_fq( table => $table, fq => 1 );
115
116
1007
    my $href = $self->_table_aliases;
117
118
1007
    if ( exists $href->{$table} ) {
119
1002
        return $href->{$table};
120    }
121
122
5
    my $new_num   = $self->_last_table_alias_num + 1;
123
5
    my $new_alias = "t$new_num";
124
125
5
    $href->{$table} = $new_alias;
126
5
    $self->_table_aliases($href);
127
5
    $self->_last_table_alias_num($new_num);
128
129
5
    return $new_alias;
130}
131
132sub _create_factory_method {
133
6
    args
134
135        # required
136        my $self          => 'Object',
137        my $table         => 'Str',
138        my $col_data_href => 'HashRef';
139
140
6
    my $method = 'create_factory_data';
141
142
6
    if ( MySQL::Util->can($method) ) {
143
5
        delete_sub "MySQL::Util::$method";
144    }
145
146
6
    my $col_rules = $self->_get_column_rules(
147        table         => $table,
148        col_data_href => $col_data_href
149    );
150
6
    $self->_verbose( "col_rules:\n" . Dumper($col_rules) );
151
152
6
    my $factory = DBIx::DataFactory->new( { dbh => $self->_dbh } );
153
154    # what to do with $fm if anything?
155
6
    my $fm = $factory->create_factory_method(
156        method                => $method,
157        table                 => $table,
158        install_package       => 'MySQL::Util',
159        auto_inserted_columns => $col_rules
160    );
161
162
6
    return $method;
163}
164
165sub _parse_fq_col {
166
1
    args_pos
167
168        # required
169        my $self => 'Object',
170        my $col  => 'Str';
171
172
1
    my @a = split( /\./, $col );
173
174
1
    confess "unable to parse column name: $col" if @a > 3;
175
176
1
    if ( @a == 3 ) {
177
0
        return @a;
178    }
179    elsif ( @a == 2 ) {
180
0
        return ( undef, @a );
181    }
182
183
1
    return ( '', '', $a[0] );
184}
185
186sub _apply_defaults {
187
8
    args
188
189        # required
190        my $self  => 'Object',
191        my $table => 'Str',
192
193        # optional
194        my $defaults => { isa => 'HashRef', default => {}, optional => 1 },
195        my $conf     => { isa => 'Str|Undef', optional => 1};
196
197
8
    my $defaults_href;
198
199
8
    if ($conf) {
200
0
        my $config = new Config::General($conf);
201
0
        my %config = $config->getall;
202
203
0
        foreach my $col ( keys %config ) {
204
0
            my $val = $config{$col};
205
206
0
            my ( $dbname, $t, $c ) = $self->_parse_fq_col($col);
207
0
            if ( $t eq $table ) {
208
0
                $defaults_href->{$c} = $val;
209            }
210            else {
211
0
                $defaults_href->{$col} = $val;
212            }
213        }
214    }
215
216
8
    foreach my $col ( keys %$defaults ) {
217        # command line overrides conf file values
218
1
        my ( $dbname, $t, $c ) = $self->_parse_fq_col($col);
219
1
        if ( $t eq $table ) {
220
0
            $defaults_href->{$c} = $defaults->{$col};
221        }
222        else {
223
1
            $defaults_href->{$col} = $defaults->{$col};
224        }
225    }
226
227
8
    return $defaults_href;
228}
229
230sub create_data {
231
9
    args
232
233        # required
234        my $self  => 'Object',
235        my $table => 'Str',
236        my $rows  => 'Int',
237
238        # optional
239        my $defaults => { isa => 'HashRef', default  => {}, optional => 1 },
240        my $conf     => { isa => 'Str',     optional => 1 };
241
242
8
    my $defaults_href = $self->_apply_defaults(
243        table    => $table,
244        defaults => $defaults,
245        conf     => $conf
246    );
247
248    # table MUST be in the current schema
249
8
    if ( $table =~ /^(\w+)\.(\w+)/ ) {
250
0
        if ( $1 ne $self->_schema ) {
251
0
            confess "table $table is not in the current schema";
252        }
253    }
254
255    # convert null to undef
256
8
    foreach my $col_name ( keys %$defaults_href ) {
257
1
        if ( $defaults_href->{$col_name} =~ /^null$/i ) {
258
0
            $defaults_href->{$col_name} = undef;
259        }
260    }
261
262
8
    my $method;
263
264
8
    for ( my $i = 0; $i < $rows; $i++ ) {
265
217
        my %col_data = %$defaults_href;
266
217
        $self->_verbose( "default data\n" . Dumper( \%col_data ) );
267
268
217
        $self->_get_pk_data( table => $table, col_data_href => \%col_data );
269
216
        $self->_verbose( "after pk data\n" . Dumper( \%col_data ) );
270
271
216
        $self->_get_ak_data( table => $table, col_data_href => \%col_data );
272
216
        $self->_verbose( "after ak data\n" . Dumper( \%col_data ) );
273
274
216
        $self->_get_fk_data( table => $table, col_data_href => \%col_data );
275
215
        $self->_verbose( "after fk data\n" . Dumper( \%col_data ) );
276
277
215
        $self->_get_enum_data( table => $table, col_data_href => \%col_data );
278
215
        $self->_verbose( "after enum data\n" . Dumper( \%col_data ) );
279
280
215
        if ( !defined($method) ) {
281
6
            $method = $self->_create_factory_method(
282                table         => $table,
283                col_data_href => \%col_data
284            );
285        }
286
287
215
        my $values = $self->$method(%col_data);
288
215
        confess "got undef?" if !$values;
289    }
290
291
6
    return $rows;
292}
293
294sub _get_table2alias_lookup {
295
41
    args
296
297        # required
298        my $self            => 'Object',
299        my $table           => 'Str',
300        my $constraint_name => 'Str',
301
302        # optional
303        my $fq => { isa => 'Bool', optional => 1, default => 1 };
304
305
41
    $table = $self->_fq( table => $table, fq => $fq );
306
307
41
    my %tables;
308
309
41
    my $i        = 1;
310
41
    my $con_aref = $self->get_constraints($table)->{$constraint_name};
311
312
41
    foreach my $con_col_href (@$con_aref) {
313
82
        my $col_name = $con_col_href->{COLUMN_NAME};
314
82
        my $ref_table;
315
316
82
        if ( $self->is_fk_column( table => $table, column => $col_name ) ) {
317
82
            my $fk_col_href = $self->_get_fk_column(
318                table  => $table,
319                column => $col_name
320            );
321
322
82
            my %parm = (
323                table => $fk_col_href->{REFERENCED_TABLE_NAME},
324                fq    => $fq
325            );
326
327
82
            if ($fq) {
328
82
                $parm{schema} = $fk_col_href->{REFERENCED_TABLE_SCHEMA};
329            }
330
331
82
            $ref_table = $self->_fq( %parm, fq => $fq );
332        }
333        else {
334
0
            $ref_table = $self->_fq( table => $table, fq => $fq );
335        }
336
337
82
        if ( !$tables{$ref_table} ) {
338
82
            my $alias = 't' . $i;
339
82
            $tables{$ref_table} = $alias;
340
82
            $i++;
341        }
342    }
343
344
41
    return \%tables;
345}
346
347sub _get_where_not_exists {
348
41
    args
349
350        # required
351        my $self            => 'Object',
352        my $table           => 'Str',
353        my $constraint_name => 'Str',
354        my $alias_href      => 'HashRef',
355
356        # optional
357        my $fq => { isa => 'Bool', optional => 1, default => 1 };
358
359
41
    $table = $self->_fq( table => $table, fq => $fq );
360
361
41
    my $con_aref = $self->get_constraints($table)->{$constraint_name};
362
41
    my @where;
363
364
41
    foreach my $con_href (@$con_aref) {
365
366
82
        my $schema   = $con_href->{CONSTRAINT_SCHEMA};
367
82
        my $col_name = $con_href->{COLUMN_NAME};
368
369
82
        my $ref_alias;
370
82
        my $ref_col;
371
372
82
        if ( $self->is_fk_column( table => $table, column => $col_name ) ) {
373
82
            my $con_fk_href = $self->_get_fk_column(
374                table  => $table,
375                column => $col_name
376            );
377
378
82
            my $ref_schema = $con_fk_href->{REFERENCED_TABLE_SCHEMA};
379
82
            my $ref_table  = $con_fk_href->{REFERENCED_TABLE_NAME};
380
82
            my $joined     = join '.', ( $ref_schema, $ref_table );
381
382
82
            $ref_alias = $alias_href->{$joined};
383
82
            $ref_col   = $con_fk_href->{REFERENCED_COLUMN_NAME};
384        }
385        else {
386
0
            $ref_alias = $alias_href->{$table};
387
0
            $ref_col   = $col_name;
388        }
389
390
82
        push @where, "x.$col_name = $ref_alias.$ref_col";
391    }
392
393
41
    my $where = join " and\n", @where;
394
395
41
    return qq{
396        select *
397        from $table x
398        where $where
399        } if $where;
400}
401
402sub _get_where_clause {
403
42
    args
404
405        # required
406        my $self          => 'Object',
407        my $table         => 'Str',
408        my $col_data_href => 'HashRef',
409        my $alias_href    => 'HashRef';
410
411    #
412    # apply any known data to columns for tables in the from clause
413    #
414
42
    my @where;
415
416
42
    foreach my $table ( keys %$alias_href ) {
417
83
        my $desc_aref = $self->describe_table($table);
418
419
83
        foreach my $column_href (@$desc_aref) {
420
125
            my $col_name = $column_href->{FIELD};
421
422
125
            if ( exists $col_data_href->{$col_name} ) {
423
424
0
                my $table_alias = $alias_href->{$table};
425
0
                my $val         = $col_data_href->{$col_name};
426
427
0
                if ($self->_column_exists(
428                        table  => $table,
429                        column => $col_name
430                    )
431                    )
432                {
433
0
                    if ( !defined $val ) {
434
0
                        if ($self->is_column_nullable(
435                                table  => $table,
436                                column => $col_name
437                            )
438                            )
439                        {
440
0
                            push( @where, "$table_alias.$col_name is NULL" );
441                        }
442                        else {
443
0
                            confess
444                                "tried to set a non-nullable column to null ($table.$col_name)";
445                        }
446                    }
447                    else {
448
0
                        push( @where, "$table_alias.$col_name = $val" );
449                    }
450                }
451            }
452        }
453    }
454
455
42
    return join ' and ', @where;
456}
457
458sub _is_table_empty {
459
1
    args
460
461        # required
462        my $self          => 'Object',
463        my $table         => 'Str',
464        my $col_data_href => 'HashRef';
465
466
1
    my $alias_href = { $table => 't1' };
467
468
1
    my $from = $self->_get_from_clause($alias_href);
469
470
1
    my $where = $self->_get_where_clause(
471        table         => $table,
472        col_data_href => $col_data_href,
473        alias_href    => $alias_href
474    );
475
476
1
    my $sql = qq{
477        select count(*)
478        from $from
479        };
480
481
1
    if ($where) {
482
0
        $sql .= " where $where ";
483    }
484
485
1
    my $cnt = $self->_dbh->selectrow_arrayref($sql)->[0];
486
487
1
    if ( !$cnt ) {
488
1
        return 1;
489    }
490
491
0
    return 0;
492}
493
494sub _get_from_clause {
495
42
    args_pos
496
497        # required
498        my $self       => 'Object',
499        my $alias_href => 'HashRef';
500
501
42
    my @tables;
502
42
    foreach my $t ( keys %$alias_href ) {
503
83
        push( @tables, "$t $alias_href->{$t}" );
504    }
505
506
42
    return join ', ', @tables;
507}
508
509sub _get_func_cache {
510
116
    args
511
512        # required
513        my $self => 'Object';
514
515
116
    my $func = ( caller(1) )[3];
516
517
116
    my $c = $self->_create_cache;
518
519
116
    if ( !exists $c->{$func} ) {
520
1
        $c->{$func} = {};
521
1
        $self->_create_cache($c);
522    }
523
524
116
    return $c->{$func};
525}
526
527sub _get_constraint_non_fk_columns {
528
116
    args
529
530        # required
531        my $self            => 'Object',
532        my $table           => 'Str',
533        my $constraint_name => 'Str';
534
535
116
    my $c = $self->_get_func_cache;
536
537
116
    if ( defined $c->{$table}->{$constraint_name} ) {
538
112
112
        return @{ $c->{$table}->{$constraint_name} };
539    }
540
541    # $hashref->{constraint_name}->[ { col1 }, { col2 } ]
542    #
543    #Hash elements for each column:
544    #
545    #    CONSTRAINT_SCHEMA
546    #    CONSTRAINT_TYPE
547    #    COLUMN_NAME
548    #    ORDINAL_POSITION
549    #    POSITION_IN_UNIQUE_CONSTRAINT
550    #    REFERENCED_COLUMN_NAME
551    #    REFERENCED_TABLE_SCHEMA
552    #    REFERENCED_TABLE_NAME
553
554
4
    my @columns;
555
556
4
    my $con_aref
557        = $self->get_constraint( table => $table, name => $constraint_name );
558
559
4
    foreach my $col_href (@$con_aref) {
560
561
5
        my $col_name = $col_href->{COLUMN_NAME};
562
563
5
        if ( !$self->is_fk_column( table => $table, column => $col_name ) ) {
564
3
            push( @columns, $col_name );
565        }
566    }
567
568
4
    $c->{$table}->{$constraint_name} = \@columns;
569
4
    return @columns;
570}
571
572sub _get_uniq_constraint_data_sql {
573
41
    args
574
575        # required
576        my $self            => 'Object',
577        my $table           => 'Str',
578        my $col_data_href   => 'HashRef',
579        my $constraint_name => 'Str',
580
581        #optional
582        my $fq => { isa => 'Bool', optional => 1, default => 1 };
583
584
41
    my $alias_href = $self->_get_table2alias_lookup(
585        table           => $table,
586        constraint_name => $constraint_name,
587        fq              => 1
588    );
589
590
41
    my $tables = $self->_get_from_clause($alias_href);
591
592
41
    my $cols = $self->_get_select_clause(
593        table           => $table,
594        constraint_name => $constraint_name,
595        alias_href      => $alias_href,
596        fq              => $fq
597    );
598
599
41
    my $where = $self->_get_where_not_exists(
600        table           => $table,
601        constraint_name => $constraint_name,
602        alias_href      => $alias_href
603    );
604
605
41
    my $extra_criteria = $self->_get_where_clause(
606        table         => $table,
607        col_data_href => $col_data_href,
608        alias_href    => $alias_href,
609    );
610
41
    $extra_criteria = " and $extra_criteria " if $extra_criteria;
611
612    # TODO: implement this for randomness:
613    #
614    #SELECT name
615    #  FROM random AS r1 JOIN
616    #       (SELECT (RAND() *
617    #                     (SELECT MAX(id)
618    #                        FROM random)) AS id)
619    #        AS r2
620    # WHERE r1.id >= r2.id
621    # ORDER BY r1.id ASC
622    # LIMIT 1
623    #
624
625
41
    my $sql = qq{
626            select distinct $cols
627            from $tables
628            where not exists ($where)
629                $extra_criteria
630            limit 1
631        };
632
633
41
    return $sql;
634}
635
636sub _get_uniq_constraint_data {
637
116
    args
638
639        #required
640        my $self            => 'Object',
641        my $table           => 'Str',
642        my $col_data_href   => 'HashRef',
643        my $constraint_name => 'Str',
644
645        #optional
646        my $fq => { isa => 'Bool', optional => 1, default => 1 };
647
648
116
    $table = $self->_fq( table => $table, fq => $fq );
649
650
116
    if (!$self->_get_constraint_non_fk_columns(
651            table           => $table,
652            constraint_name => $constraint_name
653        )
654        )
655    {
656
657        #
658        # the data for each column, in the uniq constraint, has to come from
659        # a reference table
660        #
661
41
        my $sql = $self->_get_uniq_constraint_data_sql(
662            table           => $table,
663            col_data_href   => $col_data_href,
664            constraint_name => $constraint_name,
665            fq              => $fq
666        );
667
41
        $self->_verbose_sql($sql);
668
669
41
        my $href = $self->_dbh->selectrow_hashref($sql);
670
41
        if ( !$href ) {
671
1
            if ( $self->is_self_referencing( table => $table ) ) {
672
0
                confess "self referencing tables not implemented";
673            }
674            elsif (
675                $self->_is_table_empty(
676                    table         => $table,
677                    col_data_href => $col_data_href
678                )
679                )
680            {
681
682                # let it go through
683            }
684            else {
685
0
                confess "not enough data in parent table(s) to create a "
686                    . "new row due to constraint $constraint_name";
687            }
688        }
689        else {
690
40
            foreach my $col ( keys %$href ) {
691
692
80
                if ( !exists $col_data_href->{ lc $col } ) {
693
694
80
                    $col_data_href->{ lc $col } = $href->{$col};
695                }
696            }
697        }
698    }
699}
700
701sub _join_tables {
702
50
    args
703
704        # required
705        my $self         => 'Object',
706        my $child_table  => 'Str',
707        my $parent_table => 'Str';
708
709    #
710    # debug stuff
711    #
712
50
    shift;
713
50
    $self->_verbose( "enter:\n" . Dumper( \@_ ) );
714
715
50
    $child_table = $self->_fq( table => $child_table, fq => 1 );
716
50
    my $child_alias = $self->_get_table_alias( table => $child_table );
717
718
50
    $parent_table = $self->_fq( table => $parent_table, fq => 1 );
719
720
50
    my $join_sql;
721
50
    my $fks_href = $self->get_fk_constraints($child_table);
722
723
50
    foreach my $fk_name ( keys %$fks_href ) {
724
100
        my $fk_aref    = $fks_href->{$fk_name};
725
100
        my $ref_table  = $fk_aref->[0]->{REFERENCED_TABLE_NAME};
726
100
        my $ref_schema = $fk_aref->[0]->{REFERENCED_TABLE_SCHEMA};
727
100
        my $ref_fq     = $self->_fq(
728            table  => $ref_table,
729            schema => $ref_schema,
730            fq     => 1
731        );
732
733
100
        $self->_verbose("ref_fq=$ref_fq\nparent_table=$parent_table");
734
735
100
        if ( $ref_fq eq $parent_table ) {
736
50
            my $ref_alias = $self->_get_table_alias( table => $ref_fq );
737
738
50
            foreach my $col_href (@$fk_aref) {
739
50
                $join_sql .= sprintf( "%s.%s = %s.%s\n",
740                    $ref_alias,   $col_href->{REFERENCED_COLUMN_NAME},
741                    $child_alias, $col_href->{COLUMN_NAME} );
742            }
743        }
744    }
745
746
50
    $self->_verbose($join_sql);
747
50
    return $join_sql;
748}
749
750sub _build_select_clause {
751
171
    args
752
753        # required
754        my $self    => 'Object',
755        my $table   => 'Str',
756        my $fk_tree => 'HashRef';
757
758    #
759    # debug stuff
760    #
761
171
    shift;
762
171
    $self->_verbose( "enter:\n" . Dumper( \@_ ) );
763
764
171
    $table = $self->_fq( table => $table, fq => 1 );
765
766
171
    my @select;
767
768
171
    my $fks_href = $self->get_fk_constraints($table);
769
770
171
    foreach my $fk_name ( keys %$fks_href ) {
771
212
        my $fk_aref = $fks_href->{$fk_name};
772
773
212
        my $ref_table_fq = $self->_fq(
774            table  => $fk_aref->[0]->{REFERENCED_TABLE_NAME},
775            schema => $fk_aref->[0]->{REFERENCED_TABLE_SCHEMA},
776            fq     => 1
777        );
778
779
212
        if ( exists $fk_tree->{$ref_table_fq} ) {
780
212
            my $ref_alias = $self->_get_table_alias( table => $ref_table_fq );
781
782
212
            foreach my $col_href (@$fk_aref) {
783
784
212
                push( @select,
785                    "$ref_alias." . $col_href->{REFERENCED_COLUMN_NAME} );
786            }
787        }
788    }
789
790
171
    my $select = join ', ', @select;
791
171
    $self->_verbose("return:\n$select");
792
171
    return $select;
793}
794
795sub _build_from_clause {
796
221
    args
797
798        # required
799        my $self    => 'Object',
800        my $table   => 'Str',
801        my $fk_tree => 'HashRef',
802
803        # optional
804        my $depth => { isa => 'Int', optional => 1, default => 0 };
805
806    #
807    # debug stuff
808    #
809
221
    shift;
810
221
    $self->_verbose( "enter:\n" . Dumper( \@_ ) );
811
812
221
    my %from;
813
814
221
    if ( !$depth ) {
815
171
        foreach my $parent_table ( keys %$fk_tree ) {
816
817
212
212
            if ( scalar keys %{ $fk_tree->{$parent_table} } ) {
818
819
50
                my %tmp = $self->_build_from_clause(
820                    table   => $parent_table,
821                    fk_tree => $fk_tree->{$parent_table},
822                    depth   => $depth + 1
823                );
824
50
                foreach my $key ( keys %tmp ) {
825
100
100
100
                    push( @{ $from{$key} }, @{ $tmp{$key} } );
826                }
827            }
828            else {
829
162
                my $alias = $self->_get_table_alias( table => $parent_table );
830
162
                $from{"$parent_table $alias"} = [];
831            }
832        }
833    }
834    else {
835
50
        foreach my $parent_table ( keys %$fk_tree ) {
836
837
50
            my $join = $self->_join_tables(
838                child_table  => $table,
839                parent_table => $parent_table
840            );
841
842
50
            my $alias = $self->_get_table_alias( table => $table );
843
50
            if ( !$from{"$table $alias"} ) {
844
50
                $from{"$table $alias"} = [];
845            }
846
847
50
            $alias = $self->_get_table_alias( table => $parent_table );
848
50
50
            push( @{ $from{"$parent_table $alias"} }, $join );
849
850
50
50
            if ( scalar keys %{ $fk_tree->{$parent_table} } ) {
851
852
0
                my %tmp = $self->_build_from_clause(
853                    table   => $parent_table,
854                    fk_tree => $fk_tree->{$parent_table},
855                    depth   => $depth + 1
856                );
857
0
                foreach my $key ( keys %tmp ) {
858
0
0
0
                    push( @{ $from{$key} }, @{ $tmp{$key} } );
859                }
860            }
861        }
862    }
863
864
221
    $self->_verbose( "return:\n" . Dumper( \%from ) );
865
221
    return %from;
866}
867
868sub _build_where_clause {
869
433
    args
870
871        # required
872        my $self          => 'Object',
873        my $table         => 'Str',
874        my $fk_tree       => 'HashRef',
875        my $col_data_href => 'HashRef',
876
877        # optional
878        my $depth => { isa => 'Int', optional => 1, default => 0 };
879
880    #
881    # debug stuff
882    #
883
433
    shift;
884
433
    $self->_verbose( "enter:\n" . Dumper( \@_ ) );
885
886
433
    my @where;
887
888
433
    if ($depth) {
889
262
        my $desc = $self->describe_table($table);
890
262
        my $alias = $self->_get_table_alias( table => $table );
891
892
262
        foreach my $col_href (@$desc) {
893
453
            my $col_name = lc $col_href->{FIELD};
894
895
453
            if ( exists $col_data_href->{$col_name} ) {
896
130
                push( @where,
897                    "$alias.$col_name = $col_data_href->{$col_name}" );
898
899                #            delete $col_data_href->{$col_name};
900            }
901        }
902    }
903
904
433
    foreach my $parent_table ( keys %$fk_tree ) {
905
262
        push(
906            @where,
907            $self->_build_where_clause(
908                table         => $parent_table,
909                fk_tree       => $fk_tree->{$parent_table},
910                col_data_href => $col_data_href,
911                depth         => $depth + 1
912            )
913        );
914    }
915
916
433
    $self->_verbose("@where");
917
433
    return @where;
918}
919
920sub _get_fk_data {
921
216
    args my $self         => 'Object',
922        my $table         => 'Str',
923        my $col_data_href => 'HashRef';
924
925
216
    my $fk_tree = $self->_get_fk_tree(
926        table               => $table,
927        remaining_data_href => {%$col_data_href},
928
929    );
930
216
    $self->_verbose( "fk_tree:\n " . Dumper($fk_tree) );
931
932
216
    if ( scalar keys %$fk_tree ) {
933
934
171
        my $select = $self->_build_select_clause(
935            table   => $table,
936            fk_tree => $fk_tree
937        );
938
171
        $self->_verbose($select);
939
940
171
        my %from = $self->_build_from_clause(
941            table   => $table,
942            fk_tree => $fk_tree
943        );
944
171
        my $alias = $self->_get_table_alias( table => $table );
945
171
        my $from = '';
946
947
171
        my %depth_chart;
948
949
171
        foreach my $t ( keys %from ) {
950
262
            my ( $tname, $talias ) = split( /\s+/, $t );
951
262
            my $dep = $self->get_depth($tname);
952
262
            $depth_chart{$dep}->{$t} = 1;
953        }
954
955
171
        my @from_tables;
956
171
        my @no_join_tables;
957
958
171
91
        foreach my $depth ( sort { $b <=> $a } keys(%depth_chart) ) {
959
960
262
            my $ptr = $depth_chart{$depth};
961
962
262
            foreach my $t ( keys %$ptr ) {
963
964                #    foreach my $t ( keys %from ) {
965
262
262
                my @a = @{ $from{$t} };
966
262
                @a = uniq @a;
967
262
                if ( !@a ) {
968
212
                    push( @no_join_tables, $t );
969                }
970                else {
971
50
                    $from .= "inner join $t on " . join( ' and ', @a );
972
50
                    $from .= "\n";
973                }
974
975
262
                push( @from_tables, $t );
976            }
977        }
978
171
        my $tmp = $from;
979
171
        $from = join( "\ninner join\n", @no_join_tables );
980
171
        $from .= "\n$tmp" if $tmp;
981
171
        $self->_verbose($from);
982
983
171
        my @where = $self->_build_where_clause(
984            table         => $table,
985            fk_tree       => $fk_tree,
986            col_data_href => {%$col_data_href}
987        );
988
171
        my $where = join( ' and ', uniq @where );
989
171
        $self->_verbose($where);
990
991
171
        my $sql = qq{
992            select
993                $select
994            from
995                $from
996                };
997
171
        $sql .= qq{
998            where
999                $where
1000                } if $where;
1001
171
        $sql .= q{
1002            limit 1
1003        };
1004
171
        $self->_verbose_sql($sql);
1005
1006
171
        my $href = $self->_dbh->selectrow_hashref($sql);
1007
171
        if ( !$href ) {
1008
1
            my $msg
1009                = "not enough data in one (or more) parent table(s) to create "
1010                . "a new row in table $table\n\nparent tables:\n";
1011
1012
1
            foreach my $t ( sort uniq @from_tables ) {
1013
0
                $msg .= "\t$t\n\n";
1014            }
1015
1016
0
            croak $msg;
1017        }
1018        else {
1019
170
            foreach my $col ( keys %$href ) {
1020
210
                if ( !exists $col_data_href->{ lc $col } ) {
1021
130
                    if ( !defined( $href->{$col} ) ) {
1022
0
                        if (!$self->is_column_nullable(
1023                                table  => $table,
1024                                column => $col
1025                            )
1026                            )
1027                        {
1028
0
                            confess
1029                                "tried to set a non-nullable column to null ($table.$col)";
1030                        }
1031                    }
1032
1033
130
                    $col_data_href->{ lc $col } = $href->{$col};
1034                }
1035            }
1036        }
1037    }
1038
1039    $self->_convert_missing_fk_cols_to_undef(
1040
215
        table         => $table,
1041        col_data_href => $col_data_href
1042    );
1043}
1044
1045#
1046# find foreign key _tables_ that we are missing data for return in a
1047# hierarchical structure
1048#
1049sub _get_fk_tree {
1050
769
    args
1051
1052        # required
1053        my $self                => 'Object',
1054        my $remaining_data_href => 'HashRef',
1055        my $table               => 'Str',
1056
1057        # optional
1058        my $depth => { isa => 'Int', optional => 1, default => 0 };
1059
1060
769
    my $node = {};
1061
1062    #
1063    # debug stuff
1064    #
1065
769
    my @a = @_;
1066
769
    shift @a;
1067
769
    $self->_verbose( Dumper( \@a ) );
1068
1069#
1070# all data qualifications satisfied
1071#
1072#    return
1073#        if
1074#        keys %$remaining_data_href == 0;  # no reason to continue up the chain
1075
1076    #
1077    # does this table have any columns for which we have data left?
1078    #
1079
769
    my $hit;
1080
1081
769
    if ( $depth != 0 ) {    # skip root table
1082
1083
553
        my $desc = $self->describe_table($table);
1084
553
        foreach my $col_href (@$desc) {
1085
1086
794
            my $col_name = $col_href->{FIELD};
1087
1088
794
            if ( exists( $remaining_data_href->{$col_name} ) ) {
1089
1090                # we have a hit
1091
130
                delete $remaining_data_href->{$col_name};
1092
130
                $self->_verbose("removed col $col_name");
1093
130
                $hit++;
1094            }
1095
1096            #     if ( keys %$remaining_data_href == 0 ) {
1097            #         return $node;
1098            #     }
1099        }
1100    }
1101
1102    #
1103    # if we get here we are still in search of columns to match with
1104    # remaining_data_href.  through recursion, keep walking the foreign keys
1105    # up the hierarchy.
1106    #
1107
769
    my %seen;
1108
1109
769
    my $fks_href = $self->get_fk_constraints($table);
1110
1111
769
    foreach my $fk_name ( keys %$fks_href ) {
1112
553
        $self->_verbose("fk=$fk_name");
1113
1114
553
        my $fk_aref = $fks_href->{$fk_name};
1115
1116
553
        my $col_href = shift @$fk_aref;    # only need one column from fk
1117
1118
553
        my $ref_table  = $col_href->{REFERENCED_TABLE_NAME};
1119
553
        my $ref_schema = $col_href->{REFERENCED_TABLE_SCHEMA};
1120
553
        my $ref_fq     = $self->_fq(
1121            table  => $ref_table,
1122            schema => $ref_schema,
1123            fq     => 1
1124        );
1125
1126
553
        if ($self->is_self_referencing(
1127                table => $ref_fq,
1128                name  => $fk_name
1129            )
1130            )
1131        {
1132
0
            $self->_verbose("$fk_name is self referencing");
1133
0
            next;
1134        }
1135
1136        #  next if $seen{$ref_fq};
1137        #  $seen{$ref_fq} = 1;
1138
1139
553
        my $href = $self->_get_fk_tree(
1140            remaining_data_href => {%$remaining_data_href},
1141            table               => $ref_fq,
1142            depth               => $depth + 1
1143        );
1144
553
        if ( $href or $depth == 0 ) {
1145
262
            $hit++;    # if a parent has a hit, we automatically do too
1146
262
            if ( !$href ) {
1147
82
                $href = {};
1148            }
1149
1150
262
            $node->{$ref_fq} = $href;
1151        }
1152    }
1153
1154
769
    $self->_verbose( Dumper($node) );
1155
769
    if ($hit) {
1156
351
        return $node;
1157    }
1158
1159
418
    return;
1160}
1161
1162sub _convert_missing_fk_cols_to_undef {
1163
215
    args
1164
1165        # required
1166        my $self          => 'Object',
1167        my $table         => 'Str',
1168        my $col_data_href => 'HashRef';
1169
1170    #
1171    # debugging stuff
1172    #
1173
215
    state $cnt++;
1174
215
    shift @_;
1175
215
    $self->_verbose( "enter\n\nargs:\n" . Dumper(@_), $cnt );
1176
1177
215
    foreach my $col ( $self->get_fk_column_names( table => $table ) ) {
1178
210
        if ( !exists $col_data_href->{$col} ) {
1179
0
            if (!$self->is_column_nullable(
1180                    table  => $table,
1181                    column => $col
1182                )
1183                )
1184            {
1185
0
                confess
1186                    "tried to set a non-nullable column to null ($table.$col)\n\n"
1187                    . Dumper($col_data_href);
1188            }
1189
1190
0
            $col_data_href->{$col} = undef;
1191        }
1192    }
1193}
1194
1195sub _get_ak_data {
1196
216
    args
1197
1198        # required
1199        my $self          => 'Object',
1200        my $table         => 'Str',
1201        my $col_data_href => 'HashRef',
1202
1203        #optional
1204        my $fq => { isa => 'Bool', optional => 1, default => 1 };
1205
1206
216
    $table = $self->_fq( table => $table, fq => $fq );
1207
1208
216
    if ( $self->has_ak($table) ) {
1209
1210
0
        my $aks_href = $self->get_ak_constraints($table);
1211
1212
0
        foreach my $ak_name ( keys %$aks_href ) {
1213
1214
0
            $self->_get_uniq_constraint_data(
1215                table           => $table,
1216                col_data_href   => $col_data_href,
1217                constraint_name => $ak_name
1218            );
1219        }
1220    }
1221}
1222
1223sub _get_pk_data {
1224
217
    args
1225
1226        # required
1227        my $self          => 'Object',
1228        my $table         => 'Str',
1229        my $col_data_href => 'HashRef',
1230
1231        # optional
1232        my $fq => { isa => 'Bool', optional => 1, default => 1 };
1233
1234
217
    $table = $self->_fq( table => $table, fq => $fq );
1235
1236
217
    if ( $self->has_pk($table) and !$self->is_pk_auto_inc($table) ) {
1237
1238
116
        $self->_get_uniq_constraint_data(
1239            table           => $table,
1240            col_data_href   => $col_data_href,
1241            constraint_name => $self->get_pk_name($table)
1242        );
1243    }
1244
1245
216
    return;
1246}
1247
1248sub _get_column_rules {
1249
6
    args
1250
1251        # required
1252        my $self          => 'Object',
1253        my $table         => 'Str',
1254        my $col_data_href => 'HashRef';
1255
1256
6
    state $cnt++;
1257
6
    shift @_;
1258
6
    $self->_verbose( "enter($cnt)\nargs:\n\n" . Dumper(@_), $cnt );
1259
1260
6
    my %rules;
1261
1262    #    $arrayref->[ { col1 }, { col2 } ]
1263    #
1264    #Hash elements for each column:
1265    #
1266    #   DEFAULT
1267    #   EXTRA
1268    #   FIELD
1269    #   KEY
1270    #   NULL
1271    #   TYPE
1272    #mysql> DESCRIBE pet;
1273    #+---------+-------------+------+-----+---------+-------+
1274    #| Field   | Type        | Null | Key | Default | Extra |
1275    #+---------+-------------+------+-----+---------+-------+
1276    #| name    | varchar(20) | YES  |     | NULL    |       |
1277    #| owner   | varchar(20) | YES  |     | NULL    |       |
1278    #| species | varchar(20) | YES  |     | NULL    |       |
1279    #| sex     | char(1)     | YES  |     | NULL    |       |
1280    #| birth   | date        | YES  |     | NULL    |       |
1281    #| death   | date        | YES  |     | NULL    |       |
1282    #+---------+-------------+------+-----+---------+-------+
1283
1284
6
6
    foreach my $col ( @{ $self->describe_table($table) } ) {
1285
10
        $self->_verbose("col = $col");
1286
1287
10
        my $name = $col->{FIELD};
1288
10
        my $type = $col->{TYPE};
1289
10
        my $size;
1290
1291
10
        next if exists $col_data_href->{$name};
1292
5
        next if $col->{EXTRA} =~ /auto/;
1293        next
1294
3
            if $self->is_fk_column( table => $table, column => $col );
1295
1296
3
        if ( $type =~ /varchar\((\d+)\)/ ) {
1297
0
            $type = 'Str';
1298
0
            $size = int( $1 / 2 );
1299        }
1300        elsif ( $type =~ /char\((\d+)\)/ ) {
1301
0
            $type = 'Str';
1302
0
            $size = $1;
1303        }
1304        elsif ( $type =~ /int\((\d+)\)/ ) {
1305
3
            $type = 'Int';
1306
3
            $size = int( $1 / 2 );
1307        }
1308        elsif ( $type =~ /date/ ) {
1309
0
            next;
1310        }
1311        elsif ( $type =~ /^enum\((.+)\)$/ ) {
1312
0
            next;
1313        }
1314        else {
1315
0
            confess " unhandled column type : $type ";
1316        }
1317
1318
3
        $rules{$name} = { type => $type, size => $size };
1319    }
1320
1321
6
    $self->_verbose( "leave", $cnt );
1322
1323
6
    return \%rules;
1324}
1325
1326sub _get_enum_data {
1327
215
    args
1328
1329        # required
1330        my $self          => 'Object',
1331        my $table         => 'Str',
1332        my $col_data_href => 'HashRef';
1333
1334
215
215
    foreach my $col_href ( @{ $self->describe_table($table) } ) {
1335
1336
385
        my $col_name = $col_href->{FIELD};
1337
1338
385
        next if $col_href->{EXTRA} =~ /auto/;
1339
285
        next if exists $col_data_href->{$col_name};
1340
1341
75
        my $name = $col_href->{FIELD};
1342
75
        my $type = $col_href->{TYPE};
1343
75
        my $size;
1344
1345
75
        if ( $type =~ /^enum\((.+)\)$/ ) {
1346
0
            my @a = split /,/, $type;
1347
0
            my $i = int( rand( scalar @a ) );
1348
0
            $a[$i] =~ /'(\w+)'/;
1349
0
            my $val = $1;
1350
1351
0
            $col_data_href->{$col_name} = $val;
1352        }
1353    }
1354}
1355
1356sub _get_column2alias_lookup {
1357
41
    args
1358
1359        # required
1360        my $self            => 'Object',
1361        my $table           => 'Str',
1362        my $constraint_name => 'Str',
1363        my $alias_href      => 'HashRef',
1364
1365        # optional
1366        my $fq => { isa => 'Bool', optional => 1, default => 1 };
1367
1368
41
    $table = $self->_fq( table => $table, fq => $fq );
1369
1370
41
    my @cols;
1371
41
    my %cols2alias;
1372
1373
41
    my $con_aref = $self->get_constraint(
1374        table => $table,
1375        name  => $constraint_name
1376    );
1377
1378
41
    foreach my $con_col_href (@$con_aref) {
1379
1380
82
        my %parm;
1381
82
        my $col_name = $con_col_href->{COLUMN_NAME};
1382
1383
82
        if ($self->is_fk_column(
1384                table  => $table,
1385                column => $col_name
1386            )
1387            )
1388        {
1389
82
            my $fk_col_href = $self->_get_fk_column(
1390                table  => $table,
1391                column => $col_name
1392            );
1393
1394
82
            if ($fq) {
1395
82
                $parm{schema} = $fk_col_href->{REFERENCED_TABLE_SCHEMA};
1396            }
1397
1398
82
            $parm{table} = $fk_col_href->{REFERENCED_TABLE_NAME};
1399
82
            $col_name
1400                = $fk_col_href->{REFERENCED_COLUMN_NAME} . " as $col_name";
1401        }
1402        else {
1403
0
            if ($fq) {
1404
0
                $parm{schema} = $con_col_href->{CONSTRAINT_SCHEMA};
1405            }
1406
1407
0
            $parm{table} = $table;
1408        }
1409
82
        my $ref_table = $self->_fq( %parm, fq => $fq );
1410
1411
82
        $cols2alias{$col_name} = $alias_href->{$ref_table};
1412    }
1413
1414
41
    return \%cols2alias;
1415}
1416
1417sub _get_select_clause {
1418
41
    args
1419
1420        # required
1421        my $self            => 'Object',
1422        my $table           => 'Str',
1423        my $constraint_name => 'Str',
1424        my $alias_href      => 'HashRef',
1425
1426        # optional
1427        my $fq => { isa => 'Bool', optional => 1, default => 1 };
1428
1429
41
    my $col2alias = $self->_get_column2alias_lookup(
1430        table           => $table,
1431        constraint_name => $constraint_name,
1432        alias_href      => $alias_href,
1433        fq              => $fq
1434    );
1435
1436
41
    my @cols;
1437
1438
41
    foreach my $col ( keys %$col2alias ) {
1439
82
        push( @cols, sprintf "%s.%s", $col2alias->{$col}, $col );
1440    }
1441
1442
41
    return join ', ', @cols;
1443}
1444
1445 - 1532
=head1 AUTHOR

John Gravatt, C<< <john at gravatt.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-mysql-util-data-create at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=MySQL-Util-Data-Create>.  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::Data::Create


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

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

=item * AnnoCPAN: Annotated CPAN documentation

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

=item * CPAN Ratings

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

=item * Search CPAN

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

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2013 John Gravatt.

This program is free software; you can redistribute it and/or modify it
under the terms of the the Artistic License (2.0). You may obtain a
copy of the full license at:

L<http://www.perlfoundation.org/artistic_license_2_0>

Any use, modification, and distribution of the Standard or Modified
Versions is governed by this Artistic License. By using, modifying or
distributing the Package, you accept this license. Do not use, modify,
or distribute the Package, if you do not accept this license.

If your Modified Version has been derived from a Modified Version made
by someone other than you, you are nevertheless required to ensure that
your Modified Version complies with the requirements of this license.

This license does not grant you the right to use any trademark, service
mark, tradename, or logo of the Copyright Holder.

This license includes the non-exclusive, worldwide, free-of-charge
patent license to make, have made, use, offer to sell, sell, import and
otherwise transfer the Package with respect to any patent claims
licensable by the Copyright Holder that are necessarily infringed by the
Package. If you institute patent litigation (including a cross-claim or
counterclaim) against any party alleging that the Package constitutes
direct or contributory patent infringement, then this Artistic License
to you shall terminate on the date that such litigation is filed.

Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


=cut
1533
15341;    # End of MySQL::Util::Data::Create
1535