The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package schemaUtil;
use t::lib;
use strict;
use List::MoreUtils qw(uniq);
use DBI;
use Test::More;
use Test::Deep;
use autodbUtil;
use Exporter();
our @ISA=qw(Exporter);
our @EXPORT=(@autodbUtil::EXPORT,
	     qw($class2colls $class2transients $coll2keys label %test_args
		correct_tables correct_columns
		alter_class alter_coll alter_class_colls expand_coll
		drop_all
	      ));

# class2colls for all classes in schema tests
our $class2colls=
  {Person=>[qw(Person HasName)],
   Place=>[qw(Place HasName)],
   Thing=>[],
   Expand=>[qw(Person Expand)],
   NewColl=>[qw(NewColl)],
   NewExpand=>[qw(Expand NewColl)],
  };

# coll2keys for all collections in schema tests
our $coll2keys=
  {Person=>[[qw(id name sex)],[qw(friends)]],
   Place=>[[qw(id name country)],[]],
   HasName=>[[qw(id name)],[]],
   Expand=>[[qw(id name)],[]],
   NewColl=>[[qw(id name)],[]],
  };

# class2transients for all collections in schema tests
our $class2transients={};

# label sub for all graph 'TestObject' tests
sub label {
  my $test=shift;
  my $object=$test->current_object;
#  $object->id.' '.$object->name if $object;
  (UNIVERSAL::can($object,'name')? $object->name:
   (UNIVERSAL::can($object,'desc')? $object->desc:
    (UNIVERSAL::can($object,'id')? $object->id: '')));
}

our %test_args=(class2colls=>$class2colls,class2transients=>$class2transients,
		coll2keys=>$coll2keys,label=>\&label);
################################################################################
our($autodb,$dbh);

# return correct tables for a list of classes. adapted from autodbTestObject
sub correct_tables {
  my @classes=@_;
  my @correct_tables=qw(_AutoDB);
  for my $class (@classes) {
    my $colls=$class2colls->{$class};
    for my $coll (@$colls) {
      my $pair=$coll2keys->{$coll};
      my @tables=($coll,map {$coll.'_'.$_} @{$pair->[1]});
      push(@correct_tables,@tables);
    }
  }
  @correct_tables=uniq(@correct_tables);
  wantarray? @correct_tables: \@correct_tables;
}
# return correct columns for a list of classes. adapted from autodbTestObject
# result is hash of table=>[columns]
sub correct_columns {
  my @classes=@_;
  my %correct_columns=(_AutoDB=>[qw(oid object)]);
  for my $class (@classes) {
    my $colls=$class2colls->{$class};
    for my $coll (@$colls) {
      my $pair=$coll2keys->{$coll};
      $correct_columns{$coll}=['oid',@{$pair->[0]}]; # base keys
      map {$correct_columns{$coll.'_'.$_}=['oid',$_]} @{$pair->[1]};
    }}
  wantarray? %correct_columns: \%correct_columns;
}

# change class2colls for class
sub alter_class {
  my($class,$new_colls)=@_;
  $class2colls->{$class}=$new_colls;
}
# change coll2keys for collection
sub alter_coll {
  my($coll,$new_keylists)=@_;
  $coll2keys->{$coll}=$new_keylists;
}
# expand coll2keys for collection
sub expand_coll {
  my($coll,$expand_basekeys,$expand_listkeys)=@_;
  my($basekeys,$listkeys)=@{$coll2keys->{$coll}};
  push(@$basekeys,@$expand_basekeys) if $expand_basekeys;
  push(@$listkeys,@$expand_listkeys) if $expand_listkeys;
}
# change class2colls, coll2keys for class
sub alter_class_colls {
  my($class,$new_colls,$new_coll2keys)=@_;
  $class2colls->{$class}=$new_colls;
  while(my($coll,$keylists)=each %$new_coll2keys) {
    $coll2keys->{$coll}=$keylists;
  }
}
# drop all tables to start clean
sub drop_all {
  my $label=@_? shift: 'drop all';
  my $tables=dbh->selectcol_arrayref(qq(SHOW TABLES)); #  return ARRAY ref of table names
  # NG 10-09-15: added DROP VIEW. changed SQL syntax to do all tables in one go
  # my @sql=map {qq(DROP TABLE IF EXISTS $_)} @$tables;
  $tables=join(',',@$tables);
  my @sql=(qq(DROP TABLE IF EXISTS $tables),qq(DROP VIEW IF EXISTS $tables));
  do_sql(@sql);
  # make sure it worked
  my($package,$file,$line)=caller; # for fails
  _ok_dbtables([],$label,$file,$line);
} 

sub do_sql {
  for my $sql (@_) {
    dbh->do($sql);
  }}

1;