lib/SQL/Translator/Producer/ClassDBI.pm

   1 package SQL::Translator::Producer::ClassDBI;
   2
   3 use strict;
   4 use vars qw[ $VERSION $DEBUG ];
   5 $VERSION = '1.59';
   6 $DEBUG = 1 unless defined $DEBUG;
   7
   8 use SQL::Translator::Schema::Constants;
   9 use SQL::Translator::Utils qw(debug header_comment);
  10 use Data::Dumper;
  11
  12 my %CDBI_auto_pkgs = (
  13     MySQL      => 'mysql',
  14     PostgreSQL => 'Pg',
  15     Oracle     => 'Oracle',
  16 );
  17
  18 sub produce {
  19     my $t             = shift;
  20     local $DEBUG      = $t->debug;
  21     my $no_comments   = $t->no_comments;
  22     my $schema        = $t->schema;
  23     my $args          = $t->producer_args;
  24     my @create;
  25
  26     if ( my $fmt = $args->{'format_pkg_name'} ) {
  27         $t->format_package_name( $fmt );
  28     }
  29
  30     if ( my $fmt = $args->{'format_fk_name'} ) {
  31         $t->format_fk_name( $fmt );
  32     }
  33
  34     my $db_user       = $args->{'db_user'} || '';
  35     my $db_pass       = $args->{'db_password'} || '';
  36     my $main_pkg_name = $args->{'package_name'} ||
  37                         # $args->{'main_pkg_name'} || # keep this? undocumented
  38                         $t->format_package_name('DBI');
  39     my $header        = header_comment( __PACKAGE__, "# " );
  40     my $parser_type   = ( split /::/, $t->parser_type )[-1];
  41     my $from          = $CDBI_auto_pkgs{$parser_type} || '';
  42     my $dsn           = $args->{'dsn'} || sprintf( 'dbi:%s:_',
  43         $CDBI_auto_pkgs{ $parser_type }
  44         ? $CDBI_auto_pkgs{ $parser_type } : $parser_type
  45     );
  46     my $sep           = '# ' . '-' x 67;
  47
  48
  49     #
  50     # Identify "link tables" (have only PK and FK fields).
  51     #
  52     my %linkable;
  53     my %linktable;
  54     for my $table ( $schema->get_tables ) {
  55         debug("PKG: Table = ", $table->name, "\n");
  56         my $is_link = 1;
  57         for my $field ( $table->get_fields ) {
  58             unless ( $field->is_primary_key or $field->is_foreign_key ) {
  59                 $is_link = 0;
  60                 last;
  61             }
  62         }
  63
  64         next unless $is_link;
  65
  66         foreach my $left ( $table->get_fields ) {
  67             next unless $left->is_foreign_key;
  68             my $lfk = $left->foreign_key_reference or next;
  69             my $lr_table = $schema->get_table( $lfk->reference_table )
  70               or next;
  71             my $lr_field_name = ( $lfk->reference_fields )[0];
  72             my $lr_field      = $lr_table->get_field($lr_field_name);
  73             next unless $lr_field->is_primary_key;
  74
  75             foreach my $right ( $table->get_fields ) {
  76                 next if $left->name eq $right->name;
  77
  78                 my $rfk = $right->foreign_key_reference or next;
  79                 my $rr_table = $schema->get_table( $rfk->reference_table )
  80                   or next;
  81                 my $rr_field_name = ( $rfk->reference_fields )[0];
  82                 my $rr_field      = $rr_table->get_field($rr_field_name);
  83                 next unless $rr_field->is_primary_key;
  84
  85                 $linkable{ $lr_table->name }{ $rr_table->name } = $table;
  86                 $linkable{ $rr_table->name }{ $lr_table->name } = $table;
  87                 $linktable{ $table->name } = $table;
  88             }
  89         }
  90     }
  91
  92     #
  93     # Iterate over all tables
  94     #
  95     my ( %packages, $order );
  96     for my $table ( $schema->get_tables ) {
  97         my $table_name = $table->name or next;
  98
  99         my $table_pkg_name = join '::', $main_pkg_name, $t->format_package_name($table_name);
 100         $packages{ $table_pkg_name } = {
 101             order    => ++$order,
 102             pkg_name => $table_pkg_name,
 103             base     => $main_pkg_name,
 104             table    => $table_name,
 105         };
 106
 107         #
 108         # Primary key may have a differenct accessor method name
 109         #
 110 #        if ( my $constraint = $table->primary_key ) {
 111 #            my $field = ( $constraint->fields )[0];
 112 #            $packages{ $table_pkg_name }{'_columns_primary'} = $field;
 113 #
 114 #            if ( my $pk_xform = $t->format_pk_name ) {
 115 #                my $pk_name = $pk_xform->( $table_pkg_name, $field );
 116 #
 117 #                $packages{$table_pkg_name}{'pk_accessor'} =
 118 #                  "#\n# Primary key accessor\n#\n"
 119 #                  . "sub $pk_name {\n    shift->$field\n}\n\n";
 120 #            }
 121 #        }
 122
 123         my $is_data = 0;
 124         foreach my $field ( $table->get_fields ) {
 125             if ( !$field->is_foreign_key and !$field->is_primary_key ) {
 126                 push @{ $packages{$table_pkg_name}{'_columns_essential'} },
 127                   $field->name;
 128                 $is_data++;
 129             }
 130             elsif ( !$field->is_primary_key ) {
 131                 push @{ $packages{$table_pkg_name}{'_columns_others'} },
 132                   $field->name;
 133             }
 134         }
 135
 136         my %linked;
 137         if ($is_data) {
 138             foreach my $link ( keys %{ $linkable{$table_name} } ) {
 139                 my $linkmethodname;
 140
 141                 if ( my $fk_xform = $t->format_fk_name ) {
 142
 143                     # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
 144                     $linkmethodname = $fk_xform->(
 145                         $linkable{ $table_name }{ $link }->name,
 146                         ( $schema->get_table( $link )->primary_key->fields )[0]
 147                       )
 148                       . 's';
 149                 }
 150                 else {
 151                     # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
 152                     $linkmethodname =
 153                       $linkable{ $table_name }{ $link }->name . '_'
 154                       . ( $schema->get_table( $link )->primary_key->fields )[0]
 155                       . 's';
 156                 }
 157
 158                 my @rk_fields = ();
 159                 my @lk_fields = ();
 160                 foreach my $field ( $linkable{$table_name}{$link}->get_fields )
 161                 {
 162                     next unless $field->is_foreign_key;
 163
 164                     next unless (
 165                         $field->foreign_key_reference->reference_table eq
 166                            $table_name
 167                         ||
 168                         $field->foreign_key_reference->reference_table eq $link
 169                     );
 170
 171                     push @lk_fields,
 172                       ( $field->foreign_key_reference->reference_fields )[0]
 173                       if $field->foreign_key_reference->reference_table eq
 174                       $link;
 175
 176                     push @rk_fields, $field->name
 177                       if $field->foreign_key_reference->reference_table eq
 178                       $table_name;
 179                 }
 180
 181                 #
 182                 # If one possible traversal via link table.
 183                 #
 184                 if ( scalar(@rk_fields) == 1 and scalar(@lk_fields) == 1 ) {
 185                     foreach my $rk_field (@rk_fields) {
 186                         push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
 187                           "sub "
 188                           . $linkmethodname
 189                           . " { my \$self = shift; "
 190                           . "return map \$_->"
 191                           . ( $schema->get_table($link)->primary_key->fields )
 192                           [0]
 193                           . ", \$self->"
 194                           . $linkable{$table_name}{$link}->name . "_"
 195                           . $rk_field
 196                           . " }\n\n";
 197                     }
 198
 199                     #
 200                     # Else there is more than one way to traverse it.
 201                     # ack!  Let's treat these types of link tables as
 202                     # a many-to-one (easier)
 203                     #
 204                     # NOTE: we need to rethink the link method name,
 205                     # as the cardinality has shifted on us.
 206                     #
 207                 }
 208                 elsif ( scalar(@rk_fields) == 1 ) {
 209                     foreach my $rk_field (@rk_fields) {
 210                         #
 211                         # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
 212                         #
 213                         push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
 214                           "sub "
 215                           . $linkable{$table_name}{$link}->name
 216                           . "s { my \$self = shift; return \$self->"
 217                           . $linkable{$table_name}{$link}->name . "_"
 218                           . $rk_field
 219                           . "(\@_) }\n\n";
 220                     }
 221                 }
 222                 elsif ( scalar(@lk_fields) == 1 ) {
 223                     #
 224                     # These will be taken care of on the other end...
 225                     #
 226                 }
 227                 else {
 228                     #
 229                     # Many many many.  Need multiple iterations here,
 230                     # data structure revision to handle N FK sources.
 231                     # This code has not been tested and likely doesn't
 232                     # work here.
 233                     #
 234                     foreach my $rk_field (@rk_fields) {
 235                         # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
 236                         push @{ $packages{$table_pkg_name}{'has_many'}{$link} },
 237                           "sub "
 238                           . $linkable{$table_name}{$link}->name . "_"
 239                           . $rk_field
 240                           . "s { my \$self = shift; return \$self->"
 241                           . $linkable{$table_name}{$link}->name . "_"
 242                           . $rk_field
 243                           . "(\@_) }\n\n";
 244                     }
 245                 }
 246             }
 247         }
 248
 249         #
 250         # Use foreign keys to set up "has_a/has_many" relationships.
 251         #
 252         foreach my $field ( $table->get_fields ) {
 253             if ( $field->is_foreign_key ) {
 254                 my $table_name = $table->name;
 255                 my $field_name = $field->name;
 256 #                my $fk_method  = $t->format_fk_name( $table_name, $field_name );
 257                 my $fk_method  = join('::', $table_pkg_name,
 258                     $t->format_fk_name( $table_name, $field_name )
 259                 );
 260                 my $fk         = $field->foreign_key_reference;
 261                 my $ref_table  = $fk->reference_table;
 262                 my $ref_pkg    = $t->format_package_name($ref_table);
 263                 my $ref_field  = ( $fk->reference_fields )[0];
 264 #                my $fk_method  = join('::',
 265 #                    $table_pkg_name, $t->format_fk_name( $ref_table )
 266 #                );
 267
 268                 push @{ $packages{$table_pkg_name}{'has_a'} },
 269                   "$table_pkg_name->has_a(\n"
 270                   . "    $field_name => '$ref_pkg'\n);\n\n"
 271                   . "sub $fk_method {\n"
 272                   . "    return shift->$field_name\n}\n\n"
 273                 ;
 274
 275                 # if there weren't M-M relationships via the has_many
 276                 # being set up here, create nice pluralized method alias
 277                 # rather for user as alt. to ugly tablename_fieldname name
 278                 #
 279 #                if ( !$packages{$ref_pkg}{'has_many'}{$table_name} ) {
 280 #                    #
 281 #                    # ADD CALLBACK FOR PLURALIZATION MANGLING HERE
 282 #                    #
 283 #                    push @{ $packages{$ref_pkg}{'has_many'}{$table_name} },
 284 #                        "sub ${table_name}s {\n    " .
 285 #                        "return shift->$table_name\_$field_name\n}\n\n";
 286 #                    # else ugly
 287 #                }
 288 #                else {
 289 #                }
 290
 291                 push @{ $packages{$ref_pkg}{'has_many'}{$table_name} },
 292                   "$ref_pkg->has_many(\n    '${table_name}_${field_name}', "
 293                   . "'$table_pkg_name' => '$field_name'\n);\n\n";
 294
 295             }
 296         }
 297     }
 298
 299     #
 300     # Now build up text of package.
 301     #
 302     my $base_pkg = sprintf( 'Class::DBI%s', $from ? "::$from" : '' );
 303     push @create, join ( "\n",
 304         "package $main_pkg_name;\n",
 305         $header,
 306         "use strict;",
 307         "use base '$base_pkg';\n",
 308         "$main_pkg_name->set_db('Main', '$dsn', '$db_user', '$db_pass');\n\n",
 309     );
 310
 311     for my $pkg_name (
 312         sort { $packages{ $a }{'order'} <=> $packages{ $b }{'order'} }
 313         keys %packages
 314     ) {
 315         my $pkg = $packages{$pkg_name} or next;
 316         next unless $pkg->{'pkg_name'};
 317
 318         push @create, join ( "\n",
 319             $sep,
 320             "package " . $pkg->{'pkg_name'} . ";",
 321             "use base '" . $pkg->{'base'} . "';",
 322             "use Class::DBI::Pager;\n\n",
 323         );
 324
 325                 if ( $from ) {
 326                     push @create, join('',
 327                         $pkg->{'pkg_name'},
 328                         "->set_up_table('",
 329                         $pkg->{'table'},
 330                         "');\n\n"
 331                     );
 332                 }
 333                 else {
 334                     my $table       = $schema->get_table( $pkg->{'table'} );
 335                     my @field_names = map { $_->name } $table->get_fields;
 336
 337                     push @create, join("\n",
 338                         $pkg_name."->table('".$pkg->{'table'}."');\n",
 339                         $pkg_name."->columns(All => qw/".
 340                         join(' ', @field_names)."/);\n\n",
 341                     );
 342                 }
 343
 344         push @create, "\n";
 345
 346         if ( my $pk = $pkg->{'pk_accessor'} ) {
 347             push @create, $pk;
 348         }
 349
 350         if ( my @has_a = @{ $pkg->{'has_a'} || [] } ) {
 351             push @create, $_ for @has_a;
 352         }
 353
 354         foreach my $has_many_key ( keys %{ $pkg->{'has_many'} } ) {
 355             if ( my @has_many = @{ $pkg->{'has_many'}{$has_many_key} || [] } ) {
 356                 push @create, $_ for @has_many;
 357             }
 358         }
 359     }
 360
 361     push @create, "1;\n";
 362
 363     return wantarray
 364         ? @create
 365         : join('', @create);
 366 }
 367
 368 1;
 369
 370 =pod
 371
 372 =head1 NAME
 373
 374 SQL::Translator::Producer::ClassDBI - create Class::DBI classes from schema
 375
 376 =head1 SYNOPSIS
 377
 378 Use this producer as you would any other from SQL::Translator.  See
 379 L<SQL::Translator> for details.
 380
 381 This package uses SQL::Translator's formatting methods
 382 format_package_name(), format_pk_name(), format_fk_name(), and
 383 format_table_name() as it creates classes, one per table in the schema
 384 provided.  An additional base class is also created for database connectivity
 385 configuration.  See L<Class::DBI> for details on how this works.
 386
 387 =head1 AUTHORS
 388
 389 Allen Day E<lt>allenday@ucla.eduE<gt>,
 390 Ying Zhang E<lt>zyolive@yahoo.comE<gt>,
 391 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.