view release on metacpan or  search on metacpan

lib/DBIx/DataModel/Schema/Generator.pm  view on Meta::CPAN

  my $arg1    = shift or croak "missing arg (dsn for DBI->connect(..))";
  my $dbh = ref $arg1 && $arg1->isa('DBI::db') ? $arg1 : do {
    my $user    = shift || "";
    my $passwd  = shift || "";
    my $options = shift || {RaiseError => 1};
    DBI->connect($arg1, $user, $passwd, $options)
      or croak "DBI->connect failed ($DBI::errstr)";
  };

  # get list of tables
  my %args;
  $args{catalog} = shift;
  $args{schema}  = shift;
  $args{type}    = shift || "TABLE";
  my $tables_sth = $dbh->table_info(@args{qw/catalog schema table type/});
  my $tables     = $tables_sth->fetchall_arrayref({});

 TABLE:
  foreach my $table (@$tables) {

    # get primary key info
    my @table_id = @{$table}{qw/TABLE_CAT TABLE_SCHEM TABLE_NAME/};
    my $pkey = join(" ", $dbh->primary_key(@table_id)) || "unknown_pk";

    my $table_info  = {
      classname => _table2class($table->{TABLE_NAME}),
      tablename => $table->{TABLE_NAME},
      pkey      => $pkey,
      remarks   => $table->{REMARKS},
    };

    # insert into list of tables
    push @{$self->{tables}}, $table_info;


    # get association info (in an eval because unimplemented by some drivers)
    my $fkey_sth = try {$dbh->foreign_key_info(@table_id,
                                                undef, undef, undef)}
      or next TABLE;

    while (my $fk_row = $fkey_sth->fetchrow_hashref) {

      # hack for unifying "ODBC" or "SQL/CLI" column names (see L<DBI>)
      $fk_row->{"UK_$_"} ||= $fk_row->{"PK$_"} for qw/TABLE_NAME COLUMN_NAME/;
      $fk_row->{"FK_$_"} ||= $fk_row->{"FK$_"} for qw/TABLE_NAME COLUMN_NAME/;

      my $del_rule = $fk_row->{DELETE_RULE};

      my @assoc = (
        { table      => _table2class($fk_row->{UK_TABLE_NAME}),
          col        => $fk_row->{UK_COLUMN_NAME},
          role       => _table2role($fk_row->{UK_TABLE_NAME}),
          mult_min   => 1, #0/1 (TODO: depend on is_nullable on other side)
          mult_max   => 1,
        },
        { table      => _table2class($fk_row->{FK_TABLE_NAME}),
          col        => $fk_row->{FK_COLUMN_NAME},
          role       => _table2role($fk_row->{FK_TABLE_NAME}, "s"),
          mult_min   => 0,
          mult_max   => '*',
          is_cascade => defined $del_rule && $del_rule == CASCADE,
        }
       );

      push @{$self->{assoc}}, \@assoc;
    }
  }
}


sub parse_DBIx_Class {
  my $self = shift;

  my $dbic_schema = shift or croak "missing arg (DBIC schema name)";

  # load the DBIx::Class schema
  eval {Module::Load::load $dbic_schema; 1} or croak $@;

  # global hash to hold assoc. info (because we must collect info from
  # both tables to get both directions of the association)
  my %associations;

  # foreach  DBIC table class ("moniker" : short class name)
  foreach my $moniker ($dbic_schema->sources) {
    my $source = $dbic_schema->source($moniker); # full DBIC class

    # table info
    my $table_info  = {
      classname => $moniker,
      tablename => $source->from,
      pkey      => join(" ", $source->primary_columns),
    };

    # inflated columns
    foreach my $col ($source->columns) {
      my $column_info  = $source->column_info($col);
      my $inflate_info = $column_info->{_inflate_info} 
        or next;

      # don't care about inflators for related objects
      next if $source->relationship_info($col);

      my $data_type = $column_info->{data_type};
      push @{$self->{column_types}{$data_type}{$moniker}}, $col;
    }

    # insert into list of tables
    push @{$self->{tables}}, $table_info;

    # association info 
    foreach my $relname ($source->relationships) {
      my $relinfo   = $source->relationship_info($relname);

      # extract join keys from $relinfo->{cond} (which 
      # is of shape {"foreign.k1" => "self.k2"})
      my ($fk, $pk) = map /\.(.*)/, %{$relinfo->{cond}};

      # moniker of the other side of the relationship
      my $relmoniker = $source->related_source($relname)->source_name;

      # info structure

lib/DBIx/DataModel/Schema/Generator.pm  view on Meta::CPAN

  # start emitting code
  my $code = <<__END_OF_CODE__;
use strict;
use warnings;
use DBIx::DataModel;

DBIx::DataModel  # no semicolon (intentional)

#---------------------------------------------------------------------#
#                         SCHEMA DECLARATION                          #
#---------------------------------------------------------------------#
->Schema('$self->{-schema}')

#---------------------------------------------------------------------#
#                         TABLE DECLARATIONS                          #
#---------------------------------------------------------------------#
__END_OF_CODE__

  my $colsizes = "%-$l{classname}s %-$l{tablename}s %-$l{pkey}s";
  my $format   = "->Table(qw/$colsizes/)\n";

  $code .= sprintf("#          $colsizes\n", qw/Class Table PK/)
        .  sprintf("#          $colsizes\n", qw/===== ===== ==/);

  foreach my $table (@{$self->{tables}}) {
    if ($table->{remarks}) {
      $table->{remarks} =~ s/^/# /gm;
      $code .= "\n$table->{remarks}\n";
    }
    $code .= sprintf $format, @{$table}{qw/classname tablename pkey/};
  }


  $colsizes = "%-$l{classname}s %-$l{role}s  %-$l{mult}s %-$l{col}s";
  $format   = "  [qw/$colsizes/]";

  $code .= <<__END_OF_CODE__;

#---------------------------------------------------------------------#
#                      ASSOCIATION DECLARATIONS                       #
#---------------------------------------------------------------------#
__END_OF_CODE__

  $code .= sprintf("#     $colsizes\n", qw/Class Role Mult Join/)
        .  sprintf("#     $colsizes",   qw/===== ==== ==== ====/);

  foreach my $a (@{$self->{assoc}}) {

    # for prettier output, make sure that multiplicity "1" is first
    @$a = reverse @$a if $a->[1]{mult_max} eq "1"
                      && $a->[0]{mult_max} eq "*";

    # complete association info
    for my $i (0, 1) {
      $a->[$i]{role} ||= "---";
      my $mult       = "$a->[$i]{mult_min}..$a->[$i]{mult_max}";
      $a->[$i]{mult} = {"0..*" => "*", "1..1" => "1"}->{$mult} || $mult;
    }

    # association or composition
    my $relationship = $a->[1]{is_cascade} ? 'Composition' : 'Association';

    $code .= "\n->$relationship(\n"
          .  sprintf($format, @{$a->[0]}{qw/table role mult col/})
          .  ",\n"
          .  sprintf($format, @{$a->[1]}{qw/table role mult col/})
          .  ")\n";
  }
  $code .= "\n;\n";

  # column types
  $code .= <<__END_OF_CODE__;

#---------------------------------------------------------------------#
#                             COLUMN TYPES                            #
#---------------------------------------------------------------------#
# $self->{-schema}->ColumnType(ColType_Example =>
#   fromDB => sub {...},
#   toDB   => sub {...});

# $self->{-schema}::SomeTable->ColumnType(ColType_Example =>
#   qw/column1 column2 .../);

__END_OF_CODE__

  while (my ($type, $targets) = each %{$self->{column_types} || {}}) {
    $code .= <<__END_OF_CODE__;
# $type
$self->{-schema}->ColumnType($type =>
  fromDB => sub {},   # SKELETON .. PLEASE FILL IN
  toDB   => sub {});
__END_OF_CODE__

    while (my ($table, $cols) = each %$targets) {
      $code .= sprintf("%s::%s->ColumnType($type => qw/%s/);\n",
                       $self->{-schema}, $table, join(" ", @$cols));
    }
    $code .= "\n";
  }

  # end of module
  $code .= "\n\n1;\n";

  return $code;
}

#----------------------------------------------------------------------
# utility methods/functions
#----------------------------------------------------------------------

# generate a Perl classname from a database table name
sub _table2class{
  my ($tablename) = @_;

  my $classname = join '', map ucfirst, split /[\W_]+/, lc $tablename;
}

# singular / plural inflection. Start with simple-minded defaults,
# and try to more sophisticated use Lingua::Inflect if module is installed
my $to_S  = sub {(my $r = $_[0]) =~ s/s$//i; $r};
my $to_PL = sub {$_[0] . "s"};