File Coverage

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

Criterion	Covered	Total	%
statement	171	173	98.8
branch	42	52	80.7
condition	27	52	51.9
subroutine	30	30	100.0
pod	6	8	75.0
total	276	315	87.6

package DBIx::DataModel::Meta::Schema;
use strict;
use warnings;
use parent 'DBIx::DataModel::Meta';
use DBIx::DataModel;
use DBIx::DataModel::Meta::Utils qw/define_class define_readonly_accessors/;
use DBIx::DataModel::Source::Join;
use DBIx::DataModel::Meta::Source::Join;

use Params::Validate     qw/validate_with SCALAR ARRAYREF CODEREF UNDEF BOOLEAN
                                          OBJECT HASHREF/;
use List::MoreUtils      qw/any firstval lastval uniq/;
use Module::Load         qw/load/;
use Carp::Clan           qw[^(DBIx::DataModel::|SQL::Abstract)];
use namespace::clean;

#----------------------------------------------------------------------
# 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},
  join_with_USING              => {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};


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

sub new {
  my $class = shift;

  # check parameters
  my $self = validate_with(
    params      => \@_,
    spec        => $spec,
    allow_extra => 0,
   );

  # 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
  define_class(
    name    => $self->{class},
    isa     => $isa,
    metadm  => $self,
   );

  return $self;
}

# accessors for args passed to new()
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};
  };
}


sub db_table {
  my ($self, $db_name) = @_;
  return firstval {uc($_->db_from) eq uc($db_name)} $self->tables;
}


#----------------------------------------------------------------------
# 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 defining tables, associations and types
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;
  };
}


# defining joins (different from the common pattern above)
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},
      using     => $join->{using},
    };
    push @sqla_join_args, $join_spec, $join->{db_table};
  }

  # install the Join
  my %args = (
    schema         => $self,
    class          => $class_name,
    parents        => [uniq 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)
    or croak "...->join('$initial_table', ...) : this schema has "
           . "no table named '$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 connector like '=>' or '<=>' or '<=' (see SQLAM syntax) ...
    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;   # for joining with a ON clause
      my $using = [];  # for joining with a USING clause
      while (my ($left_col, $right_col) = each %{$path->{on}}) {
        if ($left_col eq $right_col) {
          # both cols of equal name ==> can participate in a USING clause
          push @$using, $left_col if $using;
        }
        else {
          # USING clause no longer possible as soon as there are unequal names
          undef $using;
        }

        # for the ON clause, prefix column names by their table names
        # FIXME: honor SQL::Abstract's "name_sep" setting
        $left_col  = "$left_table.$left_col";
        $right_col = "$right_table.$right_col";
        $condition{$left_col} = { -ident => $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,
                       using     => $using,
                     };
      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__