package DBIx::DataModel::Meta::Schema;
use strict;
use warnings;
use parent 'DBIx::DataModel::Meta';
use DBIx::DataModel;
use DBIx::DataModel::Meta::Utils;
use DBIx::DataModel::Source::Join;
use DBIx::DataModel::Meta::Source::Join;

use Params::Validate     qw/validate SCALAR ARRAYREF CODEREF UNDEF BOOLEAN
                                     OBJECT HASHREF/;
use List::MoreUtils      qw/any lastval/;
use Scalar::Util         qw/reftype/;
use Module::Load         qw/load/;
use Carp;
use namespace::clean;

{no strict 'refs'; *CARP_NOT = \@DBIx::DataModel::CARP_NOT;}

#----------------------------------------------------------------------
# Params::Validate specification for new()
#----------------------------------------------------------------------

# new() parameter specification (in Params::Validate format)
my $spec = {
  class                        => {type => SCALAR  },
  isa                          => {type => SCALAR|ARRAYREF,
                                   default => 'DBIx::DataModel::Schema'},

  sql_no_inner_after_left_join => {type => BOOLEAN, optional => 1},

  # fields below are in common with tables (schema is a kind of "pseudo-root")
  auto_insert_columns          => {type => HASHREF, default => {}},
  auto_update_columns          => {type => HASHREF, default => {}},
  no_update_columns            => {type => HASHREF, default => {}},

  # beware: more members of %$spec are added below
};

# parameters for optional subclasses of the builtin source classes
for my $member (qw/table join/) {
  my $capitalized = ucfirst $member;
  my $parent     = "DBIx::DataModel::Source::$capitalized";
  my $meta_class = "DBIx::DataModel::Meta::Source::$capitalized";
  $spec->{$member."_parent"}    = {type    => SCALAR|ARRAYREF,
                                   default => $parent};
  $spec->{$member."_metaclass"} = {type    => SCALAR, 
                                   isa     => $meta_class,
                                   default => $meta_class};
}

# parameters for optional subclasses of the builtin metaclasses
for my $member (qw/association path type/) {
  my $capitalized = ucfirst $member;
  my $meta_class = "DBIx::DataModel::Meta::$capitalized";
  $spec->{$member."_metaclass"} = {type    => SCALAR, 
                                   isa     => $meta_class, 
                                   default => $meta_class};
}

# parameters for optional subclasses of builtin classes
my $statement_class = 'DBIx::DataModel::Statement';
$spec->{statement_class}        = {type    => SCALAR, 
                                   isa     => $statement_class,
                                   default => $statement_class};
my $connected_source_class = 'DBIx::DataModel::ConnectedSource';
$spec->{connected_source_class} = {type    => SCALAR, 
                                   isa     => $connected_source_class,
                                   default => $connected_source_class};


#----------------------------------------------------------------------
# PUBLIC METHODS : CONSTRUCTOR AND ACCESSORS
#----------------------------------------------------------------------

sub new {
  my $class = shift;

  # check parameters
  my $self = validate(@_, $spec);

  # canonical representations (arrayref) for some attributes
  for my $attr (qw/isa table_parent parent join_parent/) {
    ref $self->{$attr} or $self->{$attr} = [$self->{$attr}];
  }

  # initial hashrefs for schema members
  $self->{$_} = {} for qw/table association type/;

  # TODO : some checking on auto_update_columns, auto_insert, etc.

  # attributes just for initialisation, don't keep them within $self
  my $isa = delete $self->{isa};

  bless $self, $class;

  # create the Perl class
  DBIx::DataModel::Meta::Utils->define_class(
    name    => $self->{class},
    isa     => $isa,
    metadm  => $self,
   );

  return $self;
}

# accessors for args passed to new()
DBIx::DataModel::Meta::Utils->define_readonly_accessors(
  __PACKAGE__, grep {$_ ne 'isa'} keys %$spec
 );

# accessors for internal lists of other meta-objects
foreach my $kind (qw/table association type join/) {
  no strict 'refs';
  # retrieve list of meta-objects
  *{$kind."s"} = sub {
    my $self = shift;
    return values %{$self->{$kind}};
  };

  # retrieve single named object
  *{$kind}     = sub { 
    my ($self, $name) = @_;
    # remove schema prefix, if any
    $name =~ s/^$self->{class}:://;
    return $self->{$kind}{$name};
  };
}



#----------------------------------------------------------------------
# PUBLIC FRONT-END METHODS FOR DECLARING SCHEMA MEMBERS
# (syntactic sugar for back-end define_table(), define_association(), etc.)
#----------------------------------------------------------------------

sub Table {
  my $self = shift;
  my %args;

  # last member of @_ might be a hashref with named parameters
  %args = %{pop @_} if ref $_[-1];

  # parse positional parameters (old syntax)
  my ($class_name, $db_name, @primary_key) = @_;
  $db_name && @primary_key
    or croak "not enough args to \$schema->Table(); "
           . "did you mean \$schema->table() ?";
  $args{class}       ||= $class_name;
  $args{db_name}     ||= $db_name;
  $args{primary_key} ||= \@primary_key;

  # define it
  $self->define_table(%args);

  return $self->class;
}

sub View {
  my $self = shift;
  my %args;

  # last member of @_ might be a hashref with named parameters
  %args = %{pop @_} if ref $_[-1];

  # parse positional parameters (old syntax)
  my ($class_name, $default_columns, $sql, $where, @parents) = @_;
  $args{class}           ||= $class_name;
  $args{db_name}         ||= $sql;
  $args{where}           ||= $where;
  $args{default_columns} ||= $default_columns;
  $args{parents}         ||= [map {$self->table($_)} @parents];

  # define it
  $self->define_table(%args);

  return $self->class;
}

sub Type {
  my ($self, $type_name, %handlers) = @_;

  $self->define_type(
    name     => $type_name,
    handlers => \%handlers,
   );

  return $self->class;
}

sub Association {
  my $self = shift;

  $self->define_association(
    kind => 'Association',
    $self->_parse_association_end(A => shift),
    $self->_parse_association_end(B => shift),
   );

  return $self->class;
}

# MAYBE TODO : sub Aggregation {} with kind => 'Aggregation'.
# This would be good for UML completeness, but rather useless since
# aggregations behave exactly like compositions, so there is nothing
# special to implement.

sub Composition {
  my $self = shift;

  $self->define_association(
    kind => 'Composition',
    $self->_parse_association_end(A => shift),
    $self->_parse_association_end(B => shift),
   );

  return $self->class;
}

#----------------------------------------------------------------------
# PUBLIC BACK-END METHODS FOR DECLARING SCHEMA MEMBERS
#----------------------------------------------------------------------

# common pattern for qw/table association type/; "join" is specific (see below)
foreach my $kind (qw/table association type/) {
  my $metaclass = "${kind}_metaclass";
  no strict 'refs';
  *{"define_$kind"} = sub {
    my $self = shift;

    # force metaclass to be loaded (it could be a user-defined subclass)
    load $self->{$metaclass};

    # instanciate the metaclass
    unshift @_, schema => $self;
    my $meta_obj = $self->{$metaclass}->new(@_);

    # store into our registry (except paths because they are accessed through
    # tables or through associations)
    $self->{$kind}{$meta_obj->{name}} = $meta_obj
      unless $kind eq 'path';

    return $self;
  };
}


sub define_join {
  my $self = shift;

  # parse arguments
  my ($joins, $aliased_tables) = $self->_parse_join_path(@_);

  # build class name
  my $subclass   = join "", map {($_->{kind}, $_->{name})} @$joins;
  my $class_name = "$self->{class}::AutoJoin::$subclass";

  # do nothing if join class was already loaded
  { no strict 'refs'; return $class_name->metadm if @{$class_name.'::ISA'}; }

  # otherwise, build the new class

  # prepare args for SQL::Abstract::More::join
  my @sqla_join_args = ($joins->[0]{db_table});
  foreach my $join (@$joins[1 .. $#$joins]) {
    my $join_spec = {
      operator  => $join->{kind},
      condition => $join->{condition},
    };
    push @sqla_join_args, $join_spec, $join->{db_table};
  }

  # install the Join
  my %args = (
    schema         => $self,
    class          => $class_name,
    parents        => [map {$_->{table}} @$joins],
    sqla_join_args => \@sqla_join_args,
    aliased_tables => $aliased_tables,
  );
  $args{primary_key} = $joins->[0]{primary_key} if $joins->[0]{primary_key};
  my $meta_join = DBIx::DataModel::Meta::Source::Join->new(%args);

  # store into our registry 
  $self->{join}{$subclass} = $meta_join;

  return $meta_join;
}



#----------------------------------------------------------------------
# PRIVATE UTILITY METHODS
#----------------------------------------------------------------------


sub _parse_association_end {
  my ($self, $letter, $end_params)= @_;

  my ($table, $role, $multiplicity, @cols) = @$end_params;

  # prepend schema name in table, unless it already contains "::"
  $table =~ s/^/$self->{class}::/ unless $table =~ /::/;

  # if role is 0, or 'none', or '---', make it empty
  $role = undef if $role && $role =~ /^(0|""|''|-+|none)$/; 

  # pair of parameters for this association end
  my %letter_params = (
    table        => $table->metadm,
    role         => $role,
    multiplicity => $multiplicity,
   );
  $letter_params{join_cols} = \@cols if @cols;
  return $letter => \%letter_params;
}




my $path_regex = qr/^(?:(.+?)\.)?    # $1: optional source followed by '.'
                     (.+?)           # $2: path name (mandatory)
                     (?:\|(.+))?     # $3: optional alias following a '|'
                    $/x;

sub _parse_join_path {
  my ($self, $initial_table, @join_names) = @_;
  my %aliased_tables;

  $initial_table && @join_names
    or croak "join: not enough arguments";

  # build first member of the @join result
  my %first_join = (kind => '', name => $initial_table);
  $initial_table =~ s/\|(.+)$//  and $first_join{alias} = $1;
  my $table = $self->table($initial_table);
  $first_join{table}       = $table;
  $first_join{primary_key} = [$table->primary_key];
  $first_join{db_table}    = $table->db_from;
  if ($first_join{alias}) {
    $first_join{db_table} .= "|$first_join{alias}";
    $aliased_tables{$first_join{alias}} = $table->name;
  }

  # initial infrastructure for looping over path specifications
  my %source = (($first_join{alias} || $table->name) => \%first_join);
  my @joins  = (\%first_join);
  my $join_kind;
  my $seen_left_join;

  foreach my $join_name (@join_names) {
    # if it is a INNER (<=>) or LEFT (=>) connector ..
    if ($join_name =~ /^<?=>$/) {
      !$join_kind or croak "'$join_kind' can't be followed by '$join_name'";
      $join_kind = $join_name;
      # TODO: accept more general join syntax as recognized by SQLA::More::join
    }

    # otherwise, it must be a path specification
    else {
      # parse
      my ($source_name, $path_name, $alias) = $join_name =~ $path_regex
        or croak "incorrect item '$join_name' in join specification";

      # find source and path information, from join elements seen so far
      my $source_join
        = $source_name ? $source{$source_name}
                       : lastval {$_->{table}{path}{$path_name}} @joins;
      my $path = $source_join && $source_join->{table}{path}{$path_name}
        or croak "couldn't find item '$join_name' in join specification";
      # TODO: also deal with indirect paths (many-to-many)

      # if join kind was not explicit, compute it from min. multiplicity
      $join_kind ||= 
        ($path->{multiplicity}[0] == 0
           || ($seen_left_join && $self->{sql_no_inner_after_left_join})) 
          ? '=>' : '<=>';
      $seen_left_join = 1 if $join_kind eq '=>';

      # if max. multiplicity > 1, the join has no primary key
      delete $joins[0]{primary_key} if $path->{multiplicity}[1] > 1;

      # build new join hashref and insert it into appropriate structures
      my $left_table  = $source_join->{alias} || $source_join->{db_table};
      my $right_table = $alias || $path->{to}->db_from;
      my %condition;
      while (my ($left_col, $right_col) = each %{$path->{on}}) {
        $condition{"$left_table.$left_col"} = \"= $right_table.$right_col";
      }
      my $db_table = $path->{to}->db_from;
      $db_table .= "|$alias" if $alias;
      my $new_join = { kind      => $join_kind,
                       name      => $join_name,
                       alias     => $alias,
                       table     => $path->{to},
                       db_table  => $db_table,
                       condition => \%condition,   };
      push @joins, $new_join;
      $source{$alias || $path_name} = $new_join;

      # remember aliased table
      $aliased_tables{$alias} = $path->{to}->name if $alias;

      # reset join kind for next loop
      undef $join_kind;
    }
  }

  return (\@joins, \%aliased_tables);
}





1;

__END__

=head1 NAME

DBIx::DataModel::Meta::Schema - Meta-information about a DBIx::DataModel schema

=head1 SYNOPSIS

See synopsis in L<DBIx::DataModel>.

=head1 DESCRIPTION

An instance of this class holds meta-information about a
DBIx::DataModel schema; so it is called a I<meta-schema>. Within the
schema class, the C<metadm> method points to the meta-schema; within the
meta-schema instance, the C<class> method points to the associated class.
Both are created together: the C<new()> method simultaneously builds
a B<subclass> of L<DBIx::DataModel::Schema>, and an B<instance> of
C<DBIx::DataModel::Meta::Schema>.

The meta-schema instance contains information about :

=over

=item *

possible application-specific subclasses of the
builtin C<DBIx::DataModel> classes for statements, associations, types, etc.

=item *

possible overriding of methods at the L<DBI> layer

=item *

global specifications for columns that should be automatically
inserted or updated in every table.

=item *

lists of tables, types, associations declared within that schema.

=back

and it contains methods for declaring those meta-objects.


=head1 CONSTRUCTOR

=head2 new

  my $meta_schema = DBIx::DataModel::Meta::Schema->new(%args);

Simultaneously creates a new subclass of L<DBIx::DataModel::Schema>, and 
an new instance of DBIx::DataModel::Meta::Schema. Arguments are
described in the  
L<reference documentation|DBIx::DataModel::Doc::Reference/"Schema() / define_schema()">.


=head1 FRONT-END METHODS FOR DECLARING SCHEMA MEMBERS


=head2 Table

  $meta_schema->Table($class_name, $db_name, @primary_key, \%options);


=head2 View

  $meta_schema->View($class_name, $columns, $db_tables, 
                     \%where, @parent_tables);


=head2 Association

  $schema->Association([$class1, $role1, $multiplicity1, @columns1],
                       [$class2, $role2, $multiplicity2, @columns2]);


=head2 Composition

  $schema->Composition([$class1, $role1, $multiplicity1, @columns1], 
                       [$class2, $role2, $multiplicity2, @columns2]);


=head3 Type

  $meta_schema->Type($type_name => 
     $handler_name_1 => sub { ... },
     ...
   );




=head1 PRIVATE METHODS

=head2 _parse_association_end

Utility methods for parsing both ends of an association declaration.

=head2 _parse_join_path

Utility method for parsing arguments to L</join>, finding the most
appropriate source for each path item, retrieving
implicit left or inner connectors, and keeping track of aliases.




=cut





















