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

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

use strict;
use warnings;
no warnings 'uninitialized';
use Carp;
use List::Util   qw/max/;
use Exporter     qw/import/;
use DBI;
use Try::Tiny;
use Module::Load ();
use Carp::Clan   qw[^(DBIx::DataModel::|SQL::Abstract)];


our @EXPORT = qw/fromDBIxClass fromDBI/;


use constant CASCADE => 0; # see L<DBI/foreign_key_info>

#----------------------------------------------------------------------
# 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<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
      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__

=head1 NAME

DBIx::DataModel::Schema::Generator - automatically generate a schema for DBIx::DataModel

=head1 SYNOPSIS

=head2 Command-line API

  perl -MDBIx::DataModel::Schema::Generator      \
       -e "fromDBI('dbi:connection:string')" --  \
       -schema My::New::Schema > My/New/Schema.pm

  perl -MDBIx::DataModel::Schema::Generator      \
       -e "fromDBIxClass('Some::DBIC::Schema')" -- \
       -schema My::New::Schema > My/New/Schema.pm

If L<SQL::Translator|SQL::Translator> is installed

  sqlt -f <parser> -t DBIx::DataModel::Schema::Generator <parser_input>

=head2 Object-oriented API

  use DBIx::DataModel::Schema::Generator;
  my $generator 
    = DBIx::DataModel::Schema::Generator->new(schema => "My::New::Schema");

  $generator->parse_DBI($connection_string, $user, $passwd, \%options);
  $generator->parse_DBI($dbh);

  $generator->parse_DBIx_Class($class_name);

  $generator->parse_SQL_Translator($translator);

  my $perl_code = $generator->perl_code;

  $generator->load();


=head1 DESCRIPTION

Generates schema, table and association declarations
for L<DBIx::DataModel|DBIx::DataModel>, either from
a L<DBI|DBI> connection, or from an existing 
L<DBIx::Class|DBIx::Class> schema. The result is written
on standard output and can be redirected to a F<.pm> file.

The module can be called easily from the perl command line,
as demonstrated in the synopsis above. Command-line arguments
after C<--> are passed to method L<new>.

Alternatively, if L<SQL::Translator|SQL::Translator> is 
installed, you can use C<DBIx::DataModel::Schema::Generator>
as a producer, translating from any available
C<SQL::Translator> parser.

Associations are derived from foreign key constraints declared in
the database. If clause C<ON DELETE CASCADE> is present, this is
interpreted as a composition; otherwise as an association.

The generated code is a skeleton that most probably will need some
manual additions or modifications to get a fully functional datamodel,
because part of the information cannot be inferred automatically. In
particular, you should inspect the names and multiplicities of the
generated associations, and decide which of these associations should
rather be L<compositions|DBIx::DataModel::Doc::Reference/Composition>;
and you should declare the L<column
types|DBIx::DataModel::Doc::Reference/ColumnType> for columns that
need automatic inflation/deflation.


=head1 METHODS

=head2 new

  my $generator = DBIx::DataModel::Schema::Generator->new(@args);

Creates a new instance of a schema generator.
Functions L<fromDBI> and L<fromDBIxClass> automatically call
C<new> if necessary, so usually you do not need to call it yourself.
Arguments are :

=over

=item -schema

Name of the L<DBIx::DataModel::Schema|DBIx::DataModel::Schema>
subclass that will be generated (default is C<My::Schema>).

=back


=head2 fromDBI

  $generator->fromDBI(@dbi_connection_args, $catalog, $schema, $type);
  # or
  fromDBI(@dbi_connection_args, $catalog, $schema, $type);

Connects to a L<DBI|DBI> data source, gathers information from the
database about tables, primary and foreign keys, and generates
a C<DBIx::DataModel> schema on standard output.

This can be used either as a regular method, or as 
a function (this function is exported by default).
In the latter case, a generator is automatically 
created by calling L<new> with arguments C<@ARGV>.

The DBI connection arguments are as in  L<DBI/connect>.
Alternatively, an already connected C<$dbh> can also be
passed as first argument to C<fromDBI()>.

The remaining arguments C<$catalog>, C<$schema> and C<$type> are optional;
they will be passed as arguments to L<DBI/table_info>.
The default values are C<undef>, C<undef> and C<'TABLE'>.


=head2 fromDBIxClass

  $generator->fromDBIxClass('Some::DBIC::Schema');
  # or
  fromDBIxClass('Some::DBIC::Schema');

Loads an existing  L<DBIx::Class|DBIx::Class> schema, and translates
its declarations into a C<DBIx::DataModel> schema 
printed on standard output.

This can be used either as a regular method, or as 
a function (this function is exported by default).
In the latter case, a generator is automatically 
created by calling L<new> with arguments C<@ARGV>.

=head2 produce

Implementation of L<SQL::Translator::Producer|SQL::Translator::Producer>.


=head2 parse_DBI

First step of L</FromDBI> : gather data from a L<DBI> connection and
populate internal datastructures.

=head2 parse_DBIx_Class

First step of L</FromDBIxClass> : gather data from a L<DBIx::Class> schema and
populate internal datastructures.

=head2 parse_SQL_Translator

First step of L</produce> : gather data from a L<SQL::Translator> instance and
populate internal datastructures.

=head2 perl_code

Emits perl code from the internal datastructures parsed by one of the methods above.

=head2 load();

Immediately evals the generated perl code.


=head1 AUTHOR

Laurent Dami, E<lt>laurent.dami AT etat  ge  chE<gt>

=head1 COPYRIGHT & LICENSE

Copyright 2008, 2012 Laurent Dami.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.




