lib/SQL/Translator/Producer/ClassDBI.pm

   1 package SQL::Translator::Producer::ClassDBI;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: ClassDBI.pm,v 1.6 2003-04-25 23:08:01 allenday Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Ying Zhang <zyolive@yahoo.com>,
   7 #                    Allen Day <allenday@ucla.edu>,
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License as
  11 # published by the Free Software Foundation; version 2.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  21 # 02111-1307  USA
  22 # -------------------------------------------------------------------
  23
  24 use strict;
  25 use vars qw[ $VERSION $DEBUG ];
  26 $VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
  27 $DEBUG   = 1 unless defined $DEBUG;
  28
  29 use SQL::Translator::Utils qw(header_comment);
  30 use Data::Dumper;
  31
  32 sub produce {
  33   my ($translator, $data) = @_;
  34   $DEBUG                  = $translator->debug;
  35   my $no_comments         = $translator->no_comments;
  36
  37   my $create;
  38   $create .= header_comment(__PACKAGE__, "## ") unless ($no_comments);
  39
  40   $create .= "package " . $translator->format_package_name('DBI'). ";\n\n";
  41
  42   $create .= "my \$USER = \'\';\n";
  43   $create .= "my \$PASS = \'\';\n\n";
  44
  45   my $from = _from($translator->parser_type());
  46
  47   $create .= "use base \'Class::DBI::" .$from. "\';\n\n";
  48
  49   $create .= $translator->format_package_name('DBI'). "->set_db(\'Main', \'dbi:" .$from. ":_\', \$USER,\$PASS,);\n\n";
  50   $create .= "1;\n\n\n";
  51
  52   for my $table (keys %{$data}) {
  53         my $table_data = $data->{$table};
  54         my @fields =  keys %{$table_data->{'fields'}};
  55
  56
  57         $create .= "##\n## Package: " .$translator->format_package_name($table). "\n##\n" unless $no_comments;
  58         $create .= "package ". $translator->format_package_name($table). ";\n";
  59
  60         $create .= "use base \'Chado::DBI\';\n";
  61         $create .= "use mixin \'Class::DBI::Join\';\n";
  62         $create .= "use Class::DBI::Pager;\n\n";
  63
  64         $create .= $translator->format_package_name($table). "->set_up_table('$table');\n\n";
  65
  66         #
  67         # Primary key?
  68         #
  69         my @constraints;
  70
  71         for my $constraint ( @{ $table_data->{'constraints'} } ) {
  72           #my $name       = $constraint->{'name'} || '';
  73           my $type       = $constraint->{'type'};
  74           my $fields     = $constraint->{'fields'};
  75           my $ref_table  = $constraint->{'reference_table'};
  76           my $ref_fields = $constraint->{'reference_fields'};
  77
  78           if ( $type eq 'primary_key') {
  79                 $create .= "sub " .$translator->format_pk_name($translator->format_package_name($table), $fields[0]). "{ shift->$fields[0] }\n\n";
  80           }
  81
  82         }
  83
  84         #
  85         # Foreign key?
  86         #
  87         for (my $i = 0; $i < scalar(@fields); $i++) {
  88           my $field = $fields[$i];
  89           my $field_data = $table_data->{'fields'}->{$field}->{'constraints'};
  90           my $type = $field_data->[1]->{'type'} || '';
  91           my $ref_table = $field_data->[1]->{'reference_table'};
  92           my $ref_fields = $field_data->[1]->{'reference_fields'};
  93
  94 #there is a bug here.  the method name is being created based on the field name in the foreign table.  if this
  95 #differs from the field name in the local table (maybe called "x_fk" here, but "x" there), the method "x" will
  96 #be created, and WILL NOT WORK.  this can be resolved, but i don't know the tabledata structure well enough to
  97 #easily fix it... ken?  darren?
  98           if ($type eq 'foreign_key') {
  99                 $create .= $translator->format_package_name($table). "->hasa(" .$translator->format_package_name($ref_table). " => \'@$ref_fields\');\n";
 100                 $create .= "sub " .$translator->format_fk_name($ref_table, @$ref_fields). "{ return shift->@$ref_fields }\n\n";
 101           }
 102         }
 103
 104         $create .= "1;\n\n\n";
 105   }
 106
 107   return $create;
 108 }
 109
 110
 111 sub _from {
 112   my $from = shift;
 113   my @temp = split(/::/, $from);
 114   $from = $temp[$#temp];
 115
 116   if ( $from eq 'MySQL') {
 117         $from = lc($from);
 118   } elsif ( $from eq 'PostgreSQL') {
 119         $from = 'Pg';
 120   } elsif ( $from eq 'Oracle') {
 121         $from = 'Oracle';
 122   } else {
 123         die "__PACKAGE__ can't handle vendor $from";
 124   }
 125
 126   return $from;
 127 }
 128
 129 1;
 130
 131 __END__
 132
 133 =head1 NAME
 134
 135 SQL::Translator::Producer::ClassDBI - Translate SQL schemata into Class::DBI classes
 136
 137 =head1 SYNOPSIS
 138
 139 Use this producer as you would any other from SQL::Translator.  See
 140 L<SQL::Translator> for details.
 141
 142 This package utilizes SQL::Translator's formatting methods
 143 format_package_name(), format_pk_name(), format_fk_name(), and
 144 format_table_name() as it creates classes, one per table in the schema
 145 provided.  An additional base class is also created for database connectivity
 146 configuration.  See L<Class::DBI> for details on how this works.
 147
 148 =head1 AUTHOR
 149
 150 Ying Zhang <zyolive@yahoo.com>, Allen Day <allenday@ucla.edu>