lib/SQL/Translator/Producer/DBIx/Class/File.pm

   1 package SQL::Translator::Producer::DBIx::Class::File;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Producer::DBIx::Class::File - DBIx::Class file producer
   6
   7 =head1 SYNOPSIS
   8
   9   use SQL::Translator;
  10
  11   my $t = SQL::Translator->new( parser => '...',
  12                                 producer => 'DBIx::Class::File' );
  13   print $translator->translate( $file );
  14
  15 =head1 DESCRIPTION
  16
  17 Creates a DBIx::Class::Schema for use with DBIx::Class
  18
  19 =head1 FURTHER QUESTIONS?
  20
  21 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
  22
  23 =head1 COPYRIGHT AND LICENSE
  24
  25 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
  26 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
  27 redistribute it and/or modify it under the same terms as the
  28 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
  29
  30 =cut
  31
  32 use strict;
  33 our ($VERSION, $DEBUG, $WARN);
  34 $VERSION = '0.1';
  35 $DEBUG   = 0 unless defined $DEBUG;
  36
  37 use SQL::Translator::Schema::Constants;
  38 use SQL::Translator::Utils qw(header_comment);
  39 use DBIx::Class::_Util 'dump_value';
  40
  41 ## Skip all column type translation, as we want to use whatever the parser got.
  42
  43 ## Translate parsers -> PK::Auto::Foo, however
  44
  45 my %parser2PK = (
  46                  MySQL       => 'PK::Auto::MySQL',
  47                  PostgreSQL  => 'PK::Auto::Pg',
  48                  DB2         => 'PK::Auto::DB2',
  49                  Oracle      => 'PK::Auto::Oracle',
  50                  );
  51
  52 sub produce
  53 {
  54     my ($translator) = @_;
  55     $DEBUG             = $translator->debug;
  56     $WARN              = $translator->show_warnings;
  57     my $no_comments    = $translator->no_comments;
  58     my $add_drop_table = $translator->add_drop_table;
  59     my $schema         = $translator->schema;
  60     my $output         = '';
  61
  62     # Steal the XML producers "prefix" arg for our namespace?
  63     my $dbixschema     = $translator->producer_args()->{prefix} ||
  64         $schema->name || 'My::Schema';
  65     my $pkclass = $parser2PK{$translator->parser_type} || '';
  66
  67     my %tt_vars = ();
  68     $tt_vars{dbixschema} = $dbixschema;
  69     $tt_vars{pkclass} = $pkclass;
  70
  71     my $schemaoutput .= << "DATA";
  72
  73 package ${dbixschema};
  74 use base 'DBIx::Class::Schema';
  75 use strict;
  76 use warnings;
  77 DATA
  78
  79     my %tableoutput = ();
  80     my %tableextras = ();
  81     foreach my $table ($schema->get_tables)
  82     {
  83         my $tname = $table->name;
  84         my $output .= qq{
  85
  86 package ${dbixschema}::${tname};
  87 use base 'DBIx::Class';
  88 use strict;
  89 use warnings;
  90
  91 __PACKAGE__->load_components(qw/${pkclass} Core/);
  92 __PACKAGE__->table('${tname}');
  93
  94 };
  95
  96         my @fields = map
  97         { { $_->name  => {
  98             name              => $_->name,
  99             is_auto_increment => $_->is_auto_increment,
 100             is_foreign_key    => $_->is_foreign_key,
 101             is_nullable       => $_->is_nullable,
 102             default_value     => $_->default_value,
 103             data_type         => $_->data_type,
 104             size              => $_->size,
 105         } }
 106          } ($table->get_fields);
 107
 108         $output .= "\n__PACKAGE__->add_columns(";
 109         foreach my $f (@fields)
 110         {
 111             $output .= "\n    '" . (keys %$f)[0] . "' => " ;
 112             ( my $colinfo = dump_value( (values %$f)[0] ) ) =~ s/^/    /mg;
 113             $colinfo =~ s/^\s*|\s*$//g;
 114             $output .= $colinfo . ",";
 115         }
 116         $output .= "\n);\n";
 117
 118         my $pk = $table->primary_key;
 119         if($pk)
 120         {
 121             my @pk = map { $_->name } ($pk->fields);
 122             $output .= "__PACKAGE__->set_primary_key(";
 123             $output .= "'" . join("', '", @pk) . "');\n";
 124         }
 125
 126         foreach my $cont ($table->get_constraints)
 127         {
 128             if($cont->type =~ /foreign key/i)
 129             {
 130 #                 $output .= "\n__PACKAGE__->belongs_to('" .
 131 #                     $cont->fields->[0]->name . "', '" .
 132 #                     "${dbixschema}::" . $cont->reference_table . "');\n";
 133
 134                 $tableextras{$table->name} .= "\n__PACKAGE__->belongs_to('" .
 135                     $cont->fields->[0]->name . "', '" .
 136                     "${dbixschema}::" . $cont->reference_table . "');\n";
 137
 138                 my $other = "\n__PACKAGE__->has_many('" .
 139                     "get_" . $table->name. "', '" .
 140                     "${dbixschema}::" . $table->name. "', '" .
 141                     $cont->fields->[0]->name . "');";
 142                 $tableextras{$cont->reference_table} .= $other;
 143             }
 144         }
 145
 146         $tableoutput{$table->name} .= $output;
 147     }
 148
 149     foreach my $to (keys %tableoutput)
 150     {
 151         $output .= $tableoutput{$to};
 152         $schemaoutput .= "\n__PACKAGE__->register_class('${to}', '${dbixschema}::${to}');\n";
 153     }
 154
 155     foreach my $te (keys %tableextras)
 156     {
 157         $output .= "\npackage ${dbixschema}::$te;\n";
 158         $output .= $tableextras{$te} . "\n";
 159 #        $tableoutput{$te} .= $tableextras{$te} . "\n";
 160     }
 161
 162 #    print "$output\n";
 163     return "${output}\n\n${schemaoutput}\n1;\n";
 164 }