lib/SQL/Translator/Producer/ClassDBI.pm

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