File Coverage

blib/lib/MySQL/Util/Data/Create.pm
Criterion Covered Total %
statement 27 467 5.7
branch 0 146 0.0
condition 0 6 0.0
subroutine 9 36 25.0
pod 1 1 100.0
total 37 656 5.6


line stmt bran cond sub pod time code
1             package MySQL::Util::Data::Create;
2              
3 3     3   3526 use Moose::Role;
  3         10820  
  3         18  
4 3     3   17612 use Data::Dumper;
  3         7  
  3         180  
5 3     3   1621 use SQL::Beautify;
  3         11496  
  3         124  
6 3     3   1579 use Symbol::Util 'delete_sub';
  3         7911  
  3         25  
7 3     3   650 use Smart::Args;
  3         8  
  3         190  
8 3     3   23 use feature 'state';
  3         18  
  3         381  
9 3     3   1745 use List::MoreUtils 'uniq';
  3         38836  
  3         27  
10 3     3   3252 use Carp 'croak';
  3         9  
  3         179  
11 3     3   2251 use Config::General;
  3         60974  
  3         20508  
12              
13             =head1 NAME
14              
15             MySQL::Util::Data::Create - A Moose::Role for MySQL::Util. Do not call this
16             directly!
17              
18             =head1 VERSION
19              
20             Version 0.01
21              
22             =cut
23              
24             our $VERSION = '0.01';
25              
26             =head1 SYNOPSIS
27              
28             use MySQL::Util;
29              
30             my $util = MySQL::Util->new(...);
31            
32             $util->create_data(
33             table => 'sometable',
34             rows => 500,
35             defaults => {
36             my_id => 10,
37             enabled_flag => 1
38             });
39              
40             =head1 SUBROUTINES/METHODS
41              
42             =head2 create_data( %args )
43              
44             Creates X number of rows in the specified table. Columns are populated with
45             random data if it can't be derived through auto-increment, foreign-keys, or
46             enum. If defaults are provided they are used in favor over random values.
47              
48             =head3 Arguments:
49              
50             =over
51              
52             =item table
53              
54             name of table you want to create data in
55              
56             =item rows
57              
58             how many rows to create
59              
60             =item defaults (optional)
61              
62             A hashref that contains default data values for columns that may be
63             encountered. If a column default is specified for which no column
64             exists, it will be ignored. Each key is the column name and
65             each value is the default value you wish to use.
66              
67             =back
68              
69             =head3 Examples:
70              
71             $util->create_data(
72             table => 'mytable',
73             rows => 50,
74             defaults => {
75             id => 44,
76             age => 25
77             } );
78              
79             $util->create_data(
80             table => 'students',
81             rows => 1000
82             );
83            
84             =cut
85              
86             has _create_cache => (
87             is => 'rw',
88             isa => 'HashRef',
89             required => 0,
90             default => sub { {} },
91             );
92              
93             has _table_aliases => (
94             is => 'rw',
95             isa => 'HashRef',
96             required => 0,
97             default => sub { {} },
98             );
99              
100             has _last_table_alias_num => (
101             is => 'rw',
102             isa => 'Int',
103             required => 0,
104             default => 0
105             );
106              
107             sub _get_table_alias {
108 0     0     args
109              
110             # required
111             my $self => 'Object',
112             my $table => 'Str';
113              
114 0           $table = $self->_fq( table => $table, fq => 1 );
115              
116 0           my $href = $self->_table_aliases;
117              
118 0 0         if ( exists $href->{$table} ) {
119 0           return $href->{$table};
120             }
121              
122 0           my $new_num = $self->_last_table_alias_num + 1;
123 0           my $new_alias = "t$new_num";
124              
125 0           $href->{$table} = $new_alias;
126 0           $self->_table_aliases($href);
127 0           $self->_last_table_alias_num($new_num);
128              
129 0           return $new_alias;
130             }
131              
132             sub _create_factory_method {
133 0     0     args
134              
135             # required
136             my $self => 'Object',
137             my $table => 'Str',
138             my $col_data_href => 'HashRef';
139              
140 0           my $method = 'create_factory_data';
141              
142 0 0         if ( MySQL::Util->can($method) ) {
143 0           delete_sub "MySQL::Util::$method";
144             }
145              
146 0           my $col_rules = $self->_get_column_rules(
147             table => $table,
148             col_data_href => $col_data_href
149             );
150 0           $self->_verbose( "col_rules:\n" . Dumper($col_rules) );
151              
152 0           my $factory = DBIx::DataFactory->new( { dbh => $self->_dbh } );
153              
154             # what to do with $fm if anything?
155 0           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 0           return $method;
163             }
164              
165             sub _parse_fq_col {
166 0     0     args_pos
167              
168             # required
169             my $self => 'Object',
170             my $col => 'Str';
171              
172 0           my @a = split( /\./, $col );
173              
174 0 0         confess "unable to parse column name: $col" if @a > 3;
175              
176 0 0         if ( @a == 3 ) {
    0          
177 0           return @a;
178             }
179             elsif ( @a == 2 ) {
180 0           return ( undef, @a );
181             }
182              
183 0           return ( '', '', $a[0] );
184             }
185              
186             sub _apply_defaults {
187 0     0     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 0           my $defaults_href;
198              
199 0 0         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 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 0           foreach my $col ( keys %$defaults ) {
217             # command line overrides conf file values
218 0           my ( $dbname, $t, $c ) = $self->_parse_fq_col($col);
219 0 0         if ( $t eq $table ) {
220 0           $defaults_href->{$c} = $defaults->{$col};
221             }
222             else {
223 0           $defaults_href->{$col} = $defaults->{$col};
224             }
225             }
226              
227 0           return $defaults_href;
228             }
229              
230             sub create_data {
231 0     0 1   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 0           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 0 0         if ( $table =~ /^(\w+)\.(\w+)/ ) {
250 0 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 0           foreach my $col_name ( keys %$defaults_href ) {
257 0 0         if ( $defaults_href->{$col_name} =~ /^null$/i ) {
258 0           $defaults_href->{$col_name} = undef;
259             }
260             }
261              
262 0           my $method;
263              
264 0           for ( my $i = 0; $i < $rows; $i++ ) {
265 0           my %col_data = %$defaults_href;
266 0           $self->_verbose( "default data\n" . Dumper( \%col_data ) );
267              
268 0           $self->_get_pk_data( table => $table, col_data_href => \%col_data );
269 0           $self->_verbose( "after pk data\n" . Dumper( \%col_data ) );
270              
271 0           $self->_get_ak_data( table => $table, col_data_href => \%col_data );
272 0           $self->_verbose( "after ak data\n" . Dumper( \%col_data ) );
273              
274 0           $self->_get_fk_data( table => $table, col_data_href => \%col_data );
275 0           $self->_verbose( "after fk data\n" . Dumper( \%col_data ) );
276              
277 0           $self->_get_enum_data( table => $table, col_data_href => \%col_data );
278 0           $self->_verbose( "after enum data\n" . Dumper( \%col_data ) );
279              
280 0 0         if ( !defined($method) ) {
281 0           $method = $self->_create_factory_method(
282             table => $table,
283             col_data_href => \%col_data
284             );
285             }
286              
287 0           my $values = $self->$method(%col_data);
288 0 0         confess "got undef?" if !$values;
289             }
290              
291 0           return $rows;
292             }
293              
294             sub _get_table2alias_lookup {
295 0     0     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 0           $table = $self->_fq( table => $table, fq => $fq );
306              
307 0           my %tables;
308              
309 0           my $i = 1;
310 0           my $con_aref = $self->get_constraints($table)->{$constraint_name};
311              
312 0           foreach my $con_col_href (@$con_aref) {
313 0           my $col_name = $con_col_href->{COLUMN_NAME};
314 0           my $ref_table;
315              
316 0 0         if ( $self->is_fk_column( table => $table, column => $col_name ) ) {
317 0           my $fk_col_href = $self->_get_fk_column(
318             table => $table,
319             column => $col_name
320             );
321              
322             my %parm = (
323             table => $fk_col_href->{REFERENCED_TABLE_NAME},
324 0           fq => $fq
325             );
326              
327 0 0         if ($fq) {
328 0           $parm{schema} = $fk_col_href->{REFERENCED_TABLE_SCHEMA};
329             }
330              
331 0           $ref_table = $self->_fq( %parm, fq => $fq );
332             }
333             else {
334 0           $ref_table = $self->_fq( table => $table, fq => $fq );
335             }
336              
337 0 0         if ( !$tables{$ref_table} ) {
338 0           my $alias = 't' . $i;
339 0           $tables{$ref_table} = $alias;
340 0           $i++;
341             }
342             }
343              
344 0           return \%tables;
345             }
346              
347             sub _get_where_not_exists {
348 0     0     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 0           $table = $self->_fq( table => $table, fq => $fq );
360              
361 0           my $con_aref = $self->get_constraints($table)->{$constraint_name};
362 0           my @where;
363              
364 0           foreach my $con_href (@$con_aref) {
365              
366 0           my $schema = $con_href->{CONSTRAINT_SCHEMA};
367 0           my $col_name = $con_href->{COLUMN_NAME};
368              
369 0           my $ref_alias;
370             my $ref_col;
371              
372 0 0         if ( $self->is_fk_column( table => $table, column => $col_name ) ) {
373 0           my $con_fk_href = $self->_get_fk_column(
374             table => $table,
375             column => $col_name
376             );
377              
378 0           my $ref_schema = $con_fk_href->{REFERENCED_TABLE_SCHEMA};
379 0           my $ref_table = $con_fk_href->{REFERENCED_TABLE_NAME};
380 0           my $joined = join '.', ( $ref_schema, $ref_table );
381              
382 0           $ref_alias = $alias_href->{$joined};
383 0           $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 0           push @where, "x.$col_name = $ref_alias.$ref_col";
391             }
392              
393 0           my $where = join " and\n", @where;
394              
395 0 0         return qq{
396             select *
397             from $table x
398             where $where
399             } if $where;
400             }
401              
402             sub _get_where_clause {
403 0     0     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 0           my @where;
415              
416 0           foreach my $table ( keys %$alias_href ) {
417 0           my $desc_aref = $self->describe_table($table);
418              
419 0           foreach my $column_href (@$desc_aref) {
420 0           my $col_name = $column_href->{FIELD};
421              
422 0 0         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 0         if ($self->_column_exists(
428             table => $table,
429             column => $col_name
430             )
431             )
432             {
433 0 0         if ( !defined $val ) {
434 0 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 0           return join ' and ', @where;
456             }
457              
458             sub _is_table_empty {
459 0     0     args
460              
461             # required
462             my $self => 'Object',
463             my $table => 'Str',
464             my $col_data_href => 'HashRef';
465              
466 0           my $alias_href = { $table => 't1' };
467              
468 0           my $from = $self->_get_from_clause($alias_href);
469              
470 0           my $where = $self->_get_where_clause(
471             table => $table,
472             col_data_href => $col_data_href,
473             alias_href => $alias_href
474             );
475              
476 0           my $sql = qq{
477             select count(*)
478             from $from
479             };
480              
481 0 0         if ($where) {
482 0           $sql .= " where $where ";
483             }
484              
485 0           my $cnt = $self->_dbh->selectrow_arrayref($sql)->[0];
486              
487 0 0         if ( !$cnt ) {
488 0           return 1;
489             }
490              
491 0           return 0;
492             }
493              
494             sub _get_from_clause {
495 0     0     args_pos
496              
497             # required
498             my $self => 'Object',
499             my $alias_href => 'HashRef';
500              
501 0           my @tables;
502 0           foreach my $t ( keys %$alias_href ) {
503 0           push( @tables, "$t $alias_href->{$t}" );
504             }
505              
506 0           return join ', ', @tables;
507             }
508              
509             sub _get_func_cache {
510 0     0     args
511              
512             # required
513             my $self => 'Object';
514              
515 0           my $func = ( caller(1) )[3];
516              
517 0           my $c = $self->_create_cache;
518              
519 0 0         if ( !exists $c->{$func} ) {
520 0           $c->{$func} = {};
521 0           $self->_create_cache($c);
522             }
523              
524 0           return $c->{$func};
525             }
526              
527             sub _get_constraint_non_fk_columns {
528 0     0     args
529              
530             # required
531             my $self => 'Object',
532             my $table => 'Str',
533             my $constraint_name => 'Str';
534              
535 0           my $c = $self->_get_func_cache;
536              
537 0 0         if ( defined $c->{$table}->{$constraint_name} ) {
538 0           return @{ $c->{$table}->{$constraint_name} };
  0            
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 0           my @columns;
555              
556 0           my $con_aref
557             = $self->get_constraint( table => $table, name => $constraint_name );
558              
559 0           foreach my $col_href (@$con_aref) {
560              
561 0           my $col_name = $col_href->{COLUMN_NAME};
562              
563 0 0         if ( !$self->is_fk_column( table => $table, column => $col_name ) ) {
564 0           push( @columns, $col_name );
565             }
566             }
567              
568 0           $c->{$table}->{$constraint_name} = \@columns;
569 0           return @columns;
570             }
571              
572             sub _get_uniq_constraint_data_sql {
573 0     0     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 0           my $alias_href = $self->_get_table2alias_lookup(
585             table => $table,
586             constraint_name => $constraint_name,
587             fq => 1
588             );
589              
590 0           my $tables = $self->_get_from_clause($alias_href);
591              
592 0           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 0           my $where = $self->_get_where_not_exists(
600             table => $table,
601             constraint_name => $constraint_name,
602             alias_href => $alias_href
603             );
604              
605 0           my $extra_criteria = $self->_get_where_clause(
606             table => $table,
607             col_data_href => $col_data_href,
608             alias_href => $alias_href,
609             );
610 0 0         $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 0           my $sql = qq{
626             select distinct $cols
627             from $tables
628             where not exists ($where)
629             $extra_criteria
630             limit 1
631             };
632              
633 0           return $sql;
634             }
635              
636             sub _get_uniq_constraint_data {
637 0     0     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 0           $table = $self->_fq( table => $table, fq => $fq );
649              
650 0 0         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 0           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 0           $self->_verbose_sql($sql);
668              
669 0           my $href = $self->_dbh->selectrow_hashref($sql);
670 0 0         if ( !$href ) {
671 0 0         if ( $self->is_self_referencing( table => $table ) ) {
    0          
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 0           foreach my $col ( keys %$href ) {
691              
692 0 0         if ( !exists $col_data_href->{ lc $col } ) {
693              
694 0           $col_data_href->{ lc $col } = $href->{$col};
695             }
696             }
697             }
698             }
699             }
700              
701             sub _join_tables {
702 0     0     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 0           shift;
713 0           $self->_verbose( "enter:\n" . Dumper( \@_ ) );
714              
715 0           $child_table = $self->_fq( table => $child_table, fq => 1 );
716 0           my $child_alias = $self->_get_table_alias( table => $child_table );
717              
718 0           $parent_table = $self->_fq( table => $parent_table, fq => 1 );
719              
720 0           my $join_sql;
721 0           my $fks_href = $self->get_fk_constraints($child_table);
722              
723 0           foreach my $fk_name ( keys %$fks_href ) {
724 0           my $fk_aref = $fks_href->{$fk_name};
725 0           my $ref_table = $fk_aref->[0]->{REFERENCED_TABLE_NAME};
726 0           my $ref_schema = $fk_aref->[0]->{REFERENCED_TABLE_SCHEMA};
727 0           my $ref_fq = $self->_fq(
728             table => $ref_table,
729             schema => $ref_schema,
730             fq => 1
731             );
732              
733 0           $self->_verbose("ref_fq=$ref_fq\nparent_table=$parent_table");
734              
735 0 0         if ( $ref_fq eq $parent_table ) {
736 0           my $ref_alias = $self->_get_table_alias( table => $ref_fq );
737              
738 0           foreach my $col_href (@$fk_aref) {
739             $join_sql .= sprintf( "%s.%s = %s.%s\n",
740             $ref_alias, $col_href->{REFERENCED_COLUMN_NAME},
741 0           $child_alias, $col_href->{COLUMN_NAME} );
742             }
743             }
744             }
745              
746 0           $self->_verbose($join_sql);
747 0           return $join_sql;
748             }
749              
750             sub _build_select_clause {
751 0     0     args
752              
753             # required
754             my $self => 'Object',
755             my $table => 'Str',
756             my $fk_tree => 'HashRef';
757              
758             #
759             # debug stuff
760             #
761 0           shift;
762 0           $self->_verbose( "enter:\n" . Dumper( \@_ ) );
763              
764 0           $table = $self->_fq( table => $table, fq => 1 );
765              
766 0           my @select;
767              
768 0           my $fks_href = $self->get_fk_constraints($table);
769              
770 0           foreach my $fk_name ( keys %$fks_href ) {
771 0           my $fk_aref = $fks_href->{$fk_name};
772              
773             my $ref_table_fq = $self->_fq(
774             table => $fk_aref->[0]->{REFERENCED_TABLE_NAME},
775             schema => $fk_aref->[0]->{REFERENCED_TABLE_SCHEMA},
776 0           fq => 1
777             );
778              
779 0 0         if ( exists $fk_tree->{$ref_table_fq} ) {
780 0           my $ref_alias = $self->_get_table_alias( table => $ref_table_fq );
781              
782 0           foreach my $col_href (@$fk_aref) {
783              
784             push( @select,
785 0           "$ref_alias." . $col_href->{REFERENCED_COLUMN_NAME} );
786             }
787             }
788             }
789              
790 0           my $select = join ', ', @select;
791 0           $self->_verbose("return:\n$select");
792 0           return $select;
793             }
794              
795             sub _build_from_clause {
796 0     0     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 0           shift;
810 0           $self->_verbose( "enter:\n" . Dumper( \@_ ) );
811              
812 0           my %from;
813              
814 0 0         if ( !$depth ) {
815 0           foreach my $parent_table ( keys %$fk_tree ) {
816              
817 0 0         if ( scalar keys %{ $fk_tree->{$parent_table} } ) {
  0            
818              
819             my %tmp = $self->_build_from_clause(
820             table => $parent_table,
821 0           fk_tree => $fk_tree->{$parent_table},
822             depth => $depth + 1
823             );
824 0           foreach my $key ( keys %tmp ) {
825 0           push( @{ $from{$key} }, @{ $tmp{$key} } );
  0            
  0            
826             }
827             }
828             else {
829 0           my $alias = $self->_get_table_alias( table => $parent_table );
830 0           $from{"$parent_table $alias"} = [];
831             }
832             }
833             }
834             else {
835 0           foreach my $parent_table ( keys %$fk_tree ) {
836              
837 0           my $join = $self->_join_tables(
838             child_table => $table,
839             parent_table => $parent_table
840             );
841              
842 0           my $alias = $self->_get_table_alias( table => $table );
843 0 0         if ( !$from{"$table $alias"} ) {
844 0           $from{"$table $alias"} = [];
845             }
846              
847 0           $alias = $self->_get_table_alias( table => $parent_table );
848 0           push( @{ $from{"$parent_table $alias"} }, $join );
  0            
849              
850 0 0         if ( scalar keys %{ $fk_tree->{$parent_table} } ) {
  0            
851              
852             my %tmp = $self->_build_from_clause(
853             table => $parent_table,
854 0           fk_tree => $fk_tree->{$parent_table},
855             depth => $depth + 1
856             );
857 0           foreach my $key ( keys %tmp ) {
858 0           push( @{ $from{$key} }, @{ $tmp{$key} } );
  0            
  0            
859             }
860             }
861             }
862             }
863              
864 0           $self->_verbose( "return:\n" . Dumper( \%from ) );
865 0           return %from;
866             }
867              
868             sub _build_where_clause {
869 0     0     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 0           shift;
884 0           $self->_verbose( "enter:\n" . Dumper( \@_ ) );
885              
886 0           my @where;
887              
888 0 0         if ($depth) {
889 0           my $desc = $self->describe_table($table);
890 0           my $alias = $self->_get_table_alias( table => $table );
891              
892 0           foreach my $col_href (@$desc) {
893 0           my $col_name = lc $col_href->{FIELD};
894              
895 0 0         if ( exists $col_data_href->{$col_name} ) {
896 0           push( @where,
897             "$alias.$col_name = $col_data_href->{$col_name}" );
898              
899             # delete $col_data_href->{$col_name};
900             }
901             }
902             }
903              
904 0           foreach my $parent_table ( keys %$fk_tree ) {
905             push(
906             @where,
907             $self->_build_where_clause(
908             table => $parent_table,
909 0           fk_tree => $fk_tree->{$parent_table},
910             col_data_href => $col_data_href,
911             depth => $depth + 1
912             )
913             );
914             }
915              
916 0           $self->_verbose("@where");
917 0           return @where;
918             }
919              
920             sub _get_fk_data {
921 0     0     args my $self => 'Object',
922             my $table => 'Str',
923             my $col_data_href => 'HashRef';
924              
925 0           my $fk_tree = $self->_get_fk_tree(
926             table => $table,
927             remaining_data_href => {%$col_data_href},
928              
929             );
930 0           $self->_verbose( "fk_tree:\n " . Dumper($fk_tree) );
931              
932 0 0         if ( scalar keys %$fk_tree ) {
933              
934 0           my $select = $self->_build_select_clause(
935             table => $table,
936             fk_tree => $fk_tree
937             );
938 0           $self->_verbose($select);
939              
940 0           my %from = $self->_build_from_clause(
941             table => $table,
942             fk_tree => $fk_tree
943             );
944 0           my $alias = $self->_get_table_alias( table => $table );
945 0           my $from = '';
946              
947 0           my %depth_chart;
948              
949 0           foreach my $t ( keys %from ) {
950 0           my ( $tname, $talias ) = split( /\s+/, $t );
951 0           my $dep = $self->get_depth($tname);
952 0           $depth_chart{$dep}->{$t} = 1;
953             }
954              
955 0           my @from_tables;
956             my @no_join_tables;
957              
958 0           foreach my $depth ( sort { $b <=> $a } keys(%depth_chart) ) {
  0            
959              
960 0           my $ptr = $depth_chart{$depth};
961              
962 0           foreach my $t ( keys %$ptr ) {
963              
964             # foreach my $t ( keys %from ) {
965 0           my @a = @{ $from{$t} };
  0            
966 0           @a = uniq @a;
967 0 0         if ( !@a ) {
968 0           push( @no_join_tables, $t );
969             }
970             else {
971 0           $from .= "inner join $t on " . join( ' and ', @a );
972 0           $from .= "\n";
973             }
974              
975 0           push( @from_tables, $t );
976             }
977             }
978 0           my $tmp = $from;
979 0           $from = join( "\ninner join\n", @no_join_tables );
980 0 0         $from .= "\n$tmp" if $tmp;
981 0           $self->_verbose($from);
982              
983 0           my @where = $self->_build_where_clause(
984             table => $table,
985             fk_tree => $fk_tree,
986             col_data_href => {%$col_data_href}
987             );
988 0           my $where = join( ' and ', uniq @where );
989 0           $self->_verbose($where);
990              
991 0           my $sql = qq{
992             select
993             $select
994             from
995             $from
996             };
997 0 0         $sql .= qq{
998             where
999             $where
1000             } if $where;
1001 0           $sql .= q{
1002             limit 1
1003             };
1004 0           $self->_verbose_sql($sql);
1005              
1006 0           my $href = $self->_dbh->selectrow_hashref($sql);
1007 0 0         if ( !$href ) {
1008 0           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 0           foreach my $t ( sort uniq @from_tables ) {
1013 0           $msg .= "\t$t\n\n";
1014             }
1015              
1016 0           croak $msg;
1017             }
1018             else {
1019 0           foreach my $col ( keys %$href ) {
1020 0 0         if ( !exists $col_data_href->{ lc $col } ) {
1021 0 0         if ( !defined( $href->{$col} ) ) {
1022 0 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 0           $col_data_href->{ lc $col } = $href->{$col};
1034             }
1035             }
1036             }
1037             }
1038              
1039             $self->_convert_missing_fk_cols_to_undef(
1040 0           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             #
1049             sub _get_fk_tree {
1050 0     0     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 0           my $node = {};
1061              
1062             #
1063             # debug stuff
1064             #
1065 0           my @a = @_;
1066 0           shift @a;
1067 0           $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 0           my $hit;
1080              
1081 0 0         if ( $depth != 0 ) { # skip root table
1082              
1083 0           my $desc = $self->describe_table($table);
1084 0           foreach my $col_href (@$desc) {
1085              
1086 0           my $col_name = $col_href->{FIELD};
1087              
1088 0 0         if ( exists( $remaining_data_href->{$col_name} ) ) {
1089              
1090             # we have a hit
1091 0           delete $remaining_data_href->{$col_name};
1092 0           $self->_verbose("removed col $col_name");
1093 0           $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 0           my %seen;
1108              
1109 0           my $fks_href = $self->get_fk_constraints($table);
1110              
1111 0           foreach my $fk_name ( keys %$fks_href ) {
1112 0           $self->_verbose("fk=$fk_name");
1113              
1114 0           my $fk_aref = $fks_href->{$fk_name};
1115              
1116 0           my $col_href = shift @$fk_aref; # only need one column from fk
1117              
1118 0           my $ref_table = $col_href->{REFERENCED_TABLE_NAME};
1119 0           my $ref_schema = $col_href->{REFERENCED_TABLE_SCHEMA};
1120 0           my $ref_fq = $self->_fq(
1121             table => $ref_table,
1122             schema => $ref_schema,
1123             fq => 1
1124             );
1125              
1126 0 0         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 0           my $href = $self->_get_fk_tree(
1140             remaining_data_href => {%$remaining_data_href},
1141             table => $ref_fq,
1142             depth => $depth + 1
1143             );
1144 0 0 0       if ( $href or $depth == 0 ) {
1145 0           $hit++; # if a parent has a hit, we automatically do too
1146 0 0         if ( !$href ) {
1147 0           $href = {};
1148             }
1149              
1150 0           $node->{$ref_fq} = $href;
1151             }
1152             }
1153              
1154 0           $self->_verbose( Dumper($node) );
1155 0 0         if ($hit) {
1156 0           return $node;
1157             }
1158              
1159 0           return;
1160             }
1161              
1162             sub _convert_missing_fk_cols_to_undef {
1163 0     0     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 0           state $cnt++;
1174 0           shift @_;
1175 0           $self->_verbose( "enter\n\nargs:\n" . Dumper(@_), $cnt );
1176              
1177 0           foreach my $col ( $self->get_fk_column_names( table => $table ) ) {
1178 0 0         if ( !exists $col_data_href->{$col} ) {
1179 0 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              
1195             sub _get_ak_data {
1196 0     0     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 0           $table = $self->_fq( table => $table, fq => $fq );
1207              
1208 0 0         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              
1223             sub _get_pk_data {
1224 0     0     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 0           $table = $self->_fq( table => $table, fq => $fq );
1235              
1236 0 0 0       if ( $self->has_pk($table) and !$self->is_pk_auto_inc($table) ) {
1237              
1238 0           $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 0           return;
1246             }
1247              
1248             sub _get_column_rules {
1249 0     0     args
1250              
1251             # required
1252             my $self => 'Object',
1253             my $table => 'Str',
1254             my $col_data_href => 'HashRef';
1255              
1256 0           state $cnt++;
1257 0           shift @_;
1258 0           $self->_verbose( "enter($cnt)\nargs:\n\n" . Dumper(@_), $cnt );
1259              
1260 0           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 0           foreach my $col ( @{ $self->describe_table($table) } ) {
  0            
1285 0           $self->_verbose("col = $col");
1286              
1287 0           my $name = $col->{FIELD};
1288 0           my $type = $col->{TYPE};
1289 0           my $size;
1290              
1291 0 0         next if exists $col_data_href->{$name};
1292 0 0         next if $col->{EXTRA} =~ /auto/;
1293             next
1294 0 0         if $self->is_fk_column( table => $table, column => $col );
1295              
1296 0 0         if ( $type =~ /varchar\((\d+)\)/ ) {
    0          
    0          
    0          
    0          
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 0           $type = 'Int';
1306 0           $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 0           $rules{$name} = { type => $type, size => $size };
1319             }
1320              
1321 0           $self->_verbose( "leave", $cnt );
1322              
1323 0           return \%rules;
1324             }
1325              
1326             sub _get_enum_data {
1327 0     0     args
1328              
1329             # required
1330             my $self => 'Object',
1331             my $table => 'Str',
1332             my $col_data_href => 'HashRef';
1333              
1334 0           foreach my $col_href ( @{ $self->describe_table($table) } ) {
  0            
1335              
1336 0           my $col_name = $col_href->{FIELD};
1337              
1338 0 0         next if $col_href->{EXTRA} =~ /auto/;
1339 0 0         next if exists $col_data_href->{$col_name};
1340              
1341 0           my $name = $col_href->{FIELD};
1342 0           my $type = $col_href->{TYPE};
1343 0           my $size;
1344              
1345 0 0         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              
1356             sub _get_column2alias_lookup {
1357 0     0     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 0           $table = $self->_fq( table => $table, fq => $fq );
1369              
1370 0           my @cols;
1371             my %cols2alias;
1372              
1373 0           my $con_aref = $self->get_constraint(
1374             table => $table,
1375             name => $constraint_name
1376             );
1377              
1378 0           foreach my $con_col_href (@$con_aref) {
1379              
1380 0           my %parm;
1381 0           my $col_name = $con_col_href->{COLUMN_NAME};
1382              
1383 0 0         if ($self->is_fk_column(
1384             table => $table,
1385             column => $col_name
1386             )
1387             )
1388             {
1389 0           my $fk_col_href = $self->_get_fk_column(
1390             table => $table,
1391             column => $col_name
1392             );
1393              
1394 0 0         if ($fq) {
1395 0           $parm{schema} = $fk_col_href->{REFERENCED_TABLE_SCHEMA};
1396             }
1397              
1398 0           $parm{table} = $fk_col_href->{REFERENCED_TABLE_NAME};
1399             $col_name
1400 0           = $fk_col_href->{REFERENCED_COLUMN_NAME} . " as $col_name";
1401             }
1402             else {
1403 0 0         if ($fq) {
1404 0           $parm{schema} = $con_col_href->{CONSTRAINT_SCHEMA};
1405             }
1406              
1407 0           $parm{table} = $table;
1408             }
1409 0           my $ref_table = $self->_fq( %parm, fq => $fq );
1410              
1411 0           $cols2alias{$col_name} = $alias_href->{$ref_table};
1412             }
1413              
1414 0           return \%cols2alias;
1415             }
1416              
1417             sub _get_select_clause {
1418 0     0     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 0           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 0           my @cols;
1437              
1438 0           foreach my $col ( keys %$col2alias ) {
1439 0           push( @cols, sprintf "%s.%s", $col2alias->{$col}, $col );
1440             }
1441              
1442 0           return join ', ', @cols;
1443             }
1444              
1445             =head1 AUTHOR
1446              
1447             John Gravatt, C<< <john at gravatt.org> >>
1448              
1449             =head1 BUGS
1450              
1451             Please report any bugs or feature requests to C<bug-mysql-util-data-create at rt.cpan.org>, or through
1452             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
1453             automatically be notified of progress on your bug as I make changes.
1454              
1455              
1456              
1457              
1458             =head1 SUPPORT
1459              
1460             You can find documentation for this module with the perldoc command.
1461              
1462             perldoc MySQL::Util::Data::Create
1463              
1464              
1465             You can also look for information at:
1466              
1467             =over 4
1468              
1469             =item * RT: CPAN's request tracker (report bugs here)
1470              
1471             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MySQL-Util-Data-Create>
1472              
1473             =item * AnnoCPAN: Annotated CPAN documentation
1474              
1475             L<http://annocpan.org/dist/MySQL-Util-Data-Create>
1476              
1477             =item * CPAN Ratings
1478              
1479             L<http://cpanratings.perl.org/d/MySQL-Util-Data-Create>
1480              
1481             =item * Search CPAN
1482              
1483             L<http://search.cpan.org/dist/MySQL-Util-Data-Create/>
1484              
1485             =back
1486              
1487              
1488             =head1 ACKNOWLEDGEMENTS
1489              
1490              
1491             =head1 LICENSE AND COPYRIGHT
1492              
1493             Copyright 2013 John Gravatt.
1494              
1495             This program is free software; you can redistribute it and/or modify it
1496             under the terms of the the Artistic License (2.0). You may obtain a
1497             copy of the full license at:
1498              
1499             L<http://www.perlfoundation.org/artistic_license_2_0>
1500              
1501             Any use, modification, and distribution of the Standard or Modified
1502             Versions is governed by this Artistic License. By using, modifying or
1503             distributing the Package, you accept this license. Do not use, modify,
1504             or distribute the Package, if you do not accept this license.
1505              
1506             If your Modified Version has been derived from a Modified Version made
1507             by someone other than you, you are nevertheless required to ensure that
1508             your Modified Version complies with the requirements of this license.
1509              
1510             This license does not grant you the right to use any trademark, service
1511             mark, tradename, or logo of the Copyright Holder.
1512              
1513             This license includes the non-exclusive, worldwide, free-of-charge
1514             patent license to make, have made, use, offer to sell, sell, import and
1515             otherwise transfer the Package with respect to any patent claims
1516             licensable by the Copyright Holder that are necessarily infringed by the
1517             Package. If you institute patent litigation (including a cross-claim or
1518             counterclaim) against any party alleging that the Package constitutes
1519             direct or contributory patent infringement, then this Artistic License
1520             to you shall terminate on the date that such litigation is filed.
1521              
1522             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
1523             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
1524             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
1525             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
1526             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
1527             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
1528             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
1529             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1530              
1531              
1532             =cut
1533              
1534             1; # End of MySQL::Util::Data::Create
1535