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 =cut
  20
  21 use strict;
  22 use vars qw[ $VERSION $DEBUG $WARN ];
  23 $VERSION = '0.1';
  24 $DEBUG   = 0 unless defined $DEBUG;
  25
  26 use SQL::Translator::Schema::Constants;
  27 use SQL::Translator::Utils qw(header_comment);
  28 use Data::Dumper ();
  29
  30 ## Skip all column type translation, as we want to use whatever the parser got.
  31
  32 ## Translate parsers -> PK::Auto::Foo, however
  33
  34 my %parser2PK = (
  35                  MySQL       => 'PK::Auto::MySQL',
  36                  PostgreSQL  => 'PK::Auto::Pg',
  37                  DB2         => 'PK::Auto::DB2',
  38                  Oracle      => 'PK::Auto::Oracle',
  39                  );
  40
  41 sub produce
  42 {
  43     my ($translator) = @_;
  44     $DEBUG             = $translator->debug;
  45     $WARN              = $translator->show_warnings;
  46     my $no_comments    = $translator->no_comments;
  47     my $add_drop_table = $translator->add_drop_table;
  48     my $schema         = $translator->schema;
  49     my $output         = '';
  50
  51     # Steal the XML producers "prefix" arg for our namespace?
  52     my $dbixschema     = $translator->producer_args()->{prefix} ||
  53         $schema->name || 'My::Schema';
  54     my $pkclass = $parser2PK{$translator->parser_type} || '';
  55
  56     my %tt_vars = ();
  57     $tt_vars{dbixschema} = $dbixschema;
  58     $tt_vars{pkclass} = $pkclass;
  59
  60     my $schemaoutput .= << "DATA";
  61
  62 package ${dbixschema};
  63 use base 'DBIx::Class::Schema';
  64 use strict;
  65 use warnings;
  66 DATA
  67
  68     my %tableoutput = ();
  69     my %tableextras = ();
  70     foreach my $table ($schema->get_tables)
  71     {
  72         my $tname = $table->name;
  73         my $output .= qq{
  74
  75 package ${dbixschema}::${tname};
  76 use base 'DBIx::Class';
  77 use strict;
  78 use warnings;
  79
  80 __PACKAGE__->load_components(qw/${pkclass} Core/);
  81 __PACKAGE__->table('${tname}');
  82
  83 };
  84
  85         my @fields = map
  86         { { $_->name  => {
  87             name              => $_->name,
  88             is_auto_increment => $_->is_auto_increment,
  89             is_foreign_key    => $_->is_foreign_key,
  90             is_nullable       => $_->is_nullable,
  91             default_value     => $_->default_value,
  92             data_type         => $_->data_type,
  93             size              => $_->size,
  94         } }
  95          } ($table->get_fields);
  96
  97         $output .= "\n__PACKAGE__->add_columns(";
  98         foreach my $f (@fields)
  99         {
 100             local $Data::Dumper::Terse = 1;
 101             $output .= "\n    '" . (keys %$f)[0] . "' => " ;
 102             my $colinfo =
 103                 Data::Dumper->Dump([values %$f],
 104                                    [''] # keys   %$f]
 105                                    );
 106             chomp($colinfo);
 107             $output .= $colinfo . ",";
 108         }
 109         $output .= "\n);\n";
 110
 111         my $pk = $table->primary_key;
 112         if($pk)
 113         {
 114             my @pk = map { $_->name } ($pk->fields);
 115             $output .= "__PACKAGE__->set_primary_key(";
 116             $output .= "'" . join("', '", @pk) . "');\n";
 117         }
 118
 119         foreach my $cont ($table->get_constraints)
 120         {
 121 #            print Data::Dumper::Dumper($cont->type);
 122             if($cont->type =~ /foreign key/i)
 123             {
 124 #                 $output .= "\n__PACKAGE__->belongs_to('" .
 125 #                     $cont->fields->[0]->name . "', '" .
 126 #                     "${dbixschema}::" . $cont->reference_table . "');\n";
 127
 128                 $tableextras{$table->name} .= "\n__PACKAGE__->belongs_to('" .
 129                     $cont->fields->[0]->name . "', '" .
 130                     "${dbixschema}::" . $cont->reference_table . "');\n";
 131
 132                 my $other = "\n__PACKAGE__->has_many('" .
 133                     "get_" . $table->name. "', '" .
 134                     "${dbixschema}::" . $table->name. "', '" .
 135                     $cont->fields->[0]->name . "');";
 136                 $tableextras{$cont->reference_table} .= $other;
 137             }
 138         }
 139
 140         $tableoutput{$table->name} .= $output;
 141     }
 142
 143     foreach my $to (keys %tableoutput)
 144     {
 145         $output .= $tableoutput{$to};
 146         $schemaoutput .= "\n__PACKAGE__->register_class('${to}', '${dbixschema}::${to}');\n";
 147     }
 148
 149     foreach my $te (keys %tableextras)
 150     {
 151         $output .= "\npackage ${dbixschema}::$te;\n";
 152         $output .= $tableextras{$te} . "\n";
 153 #        $tableoutput{$te} .= $tableextras{$te} . "\n";
 154     }
 155
 156 #    print "$output\n";
 157     return "${output}\n\n${schemaoutput}\n1;\n";
 158 }