File Coverage

blib/lib/DBIx/DataModel/Schema/Generator.pm

Criterion	Covered	Total	%
statement	122	197	61.9
branch	15	50	30.0
condition	14	47	29.7
subroutine	17	23	73.9
pod	9	9	100.0
total	177	326	54.2

#----------------------------------------------------------------------
package DBIx::DataModel::Schema::Generator;
#----------------------------------------------------------------------

# see POD doc at end of file
# version : see DBIx::DataModel

use strict;
use warnings;
no warnings 'uninitialized';
use DBIx::DataModel::Carp;
use List::Util   qw/max/;
use Exporter     qw/import/;
use DBI;
use Try::Tiny;
use Module::Load ();


our @EXPORT = qw/fromDBIxClass fromDBI/;


use constant CASCADE => 0; # see L

#----------------------------------------------------------------------
# front methods
#----------------------------------------------------------------------

sub new {
  my ($class, @args) = @_;
  my $self =  bless {@args}, $class;
  $self->{-schema} ||= "My::Schema";
  $self->{tables}  ||= [];
  $self->{assoc}   ||= [];
  return $self;
}


sub fromDBI {
  # may be called as ordinary sub or as method
  my $self = ref $_[0] eq __PACKAGE__ ? shift : __PACKAGE__->new(@ARGV);

  $self->parse_DBI(@_);
  print $self->perl_code;
}


sub fromDBIxClass {
  # may be called as ordinary sub or as method
  my $self = ref $_[0] eq __PACKAGE__ ? shift : __PACKAGE__->new(@ARGV);

  $self->parse_DBIx_Class(@_);
  print $self->perl_code;
}

# other name for this method
*fromDBIC = \&fromDBIxClass;



# support for SQL::Translator::Producer
sub produce {
  my $tr = shift;

  my $self = __PACKAGE__->new(%{$tr->{producer_args} || {}});
  $self->parse_SQL_Translator($tr);
  return $self->perl_code;
}


sub load {
  my $self = shift;
  eval $self->perl_code;
}


#----------------------------------------------------------------------
# build internal data from external sources
#----------------------------------------------------------------------

sub parse_DBI {
  my $self = shift;

  # dbh connection
  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)
      $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
      my %info = (
        table    => $relmoniker,
        col      => $fk,
        role     => $relname,

        # compute multiplicities
        mult_min => $relinfo->{attrs}{join_type} eq 'LEFT' ? 0   : 1,
        mult_max => $relinfo->{attrs}{accessor} eq 'multi' ? "*" : 1,
      );

      # store assoc info into global hash; since both sides of the assoc must
      # ultimately be joined, we compute a unique key from alphabetic ordering
      my ($key, $index) = ($moniker cmp $relmoniker || $fk cmp $pk) < 0
                        ? ("$moniker/$relmoniker/$fk/$pk", 0)
                        : ("$relmoniker/$moniker/$pk/$fk", 1);
      $associations{$key}[$index] = \%info;

      # info on other side of the association
      my $other_index = 1 - $index;
      my $other_assoc = $associations{$key}[1 - $index] ||= {};
      $other_assoc->{table} ||= $moniker;
      $other_assoc->{col}   ||= $pk;
      defined $other_assoc->{mult_min} or $other_assoc->{mult_min} = 1;
      defined $other_assoc->{mult_max} or $other_assoc->{mult_max} = 1;
    }
  }

  $self->{assoc} = [values %associations];
}


sub parse_SQL_Translator {
  my ($self, $tr) = @_;

  my $schema = $tr->schema;
  foreach my $table ($schema->get_tables) {
    my $tablename = $table->name;
    my $classname = _table2class($tablename);
    my $pk        = $table->primary_key;
    my @pkey      = $pk ? ($pk->field_names) : qw/unknown_pk/;

    my $table_info  = {
      classname => $classname,
      tablename => $tablename,
      pkey      => join(" ", @pkey),
      remarks   => join("\n", $table->comments),
    };
    push @{$self->{tables}}, $table_info;

    my @foreign_keys
      = grep {$_->type eq 'FOREIGN KEY'} ($table->get_constraints);

    my $role      = _table2role($tablename, "s");
    foreach my $fk (@foreign_keys) {
      my $ref_table  = $fk->reference_table;
      my @ref_fields = $fk->reference_fields;

      my @assoc = (
        { table    => _table2class($ref_table),
          col      => $table_info->{pkey},
          role     => _table2role($ref_table),
          mult_min => 1, #0/1 (TODO: depend on is_nullable on other side)
          mult_max => 1,
        },
        { table    => $classname,
          col      => join(" ", $fk->fields),
          role     => $role,
          mult_min => 0,
          mult_max => '*',
        }
       );
      push @{$self->{assoc}}, \@assoc;
    }
  }
}


#----------------------------------------------------------------------
# emit perl code
#----------------------------------------------------------------------

sub perl_code {
  my ($self) = @_;

  # check that we have some data
  @{$self->{tables}}
    or croak "can't generate schema: no data. "
           . "Call parse_DBI() or parse_DBIx_Class() before";

  # make sure there is no duplicate role on the same table
  my %seen_role;
  foreach my $assoc (@{$self->{assoc}}) {
    my $count;
    $count = ++$seen_role{$assoc->[0]{table}}{$assoc->[1]{role}};
    $assoc->[1]{role} .= "_$count" if $count > 1;
    $count = ++$seen_role{$assoc->[1]{table}}{$assoc->[0]{role}};
    $assoc->[0]{role} .= "_$count" if $count > 1;
  }

  # compute max length of various fields (for prettier source alignment)
  my %l;
  foreach my $field (qw/classname tablename pkey/) {
    $l{$field} = max map {length $_->{$field}} @{$self->{tables}};
  }
  foreach my $field (qw/col role mult/) {
    $l{$field} = max map {length $_->{$field}} map {(@$_)} @{$self->{assoc}};
  }
  $l{mult} = max ($l{mult}, 4);

  # 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"};
eval "use Lingua::EN::Inflect::Phrase qw/to_S to_PL/;"
   . "\$to_S = \\&to_S; \$to_PL = \\&to_PL;"
  or warn "Lingua::EN::Inflect::Phrase is recommended; please install it to "
        . "generate better names for associations";
;

# generate a rolename from a database table name
sub _table2role{
  my ($tablename, $plural) = @_;

  my $inflect         = $plural ? $to_PL : $to_S;
  # my ($first, @other) = map {$inflect->($_)} split /[\W_]+/, lc $tablename;
  # my $role            = join '_', $first, @other;
  my $role            = $inflect->(lc $tablename);
  return $role;
}


1;

__END__