File Coverage

blib/lib/YATT/Lite/WebMVC0/DBSchema.pm

Criterion	Covered	Total	%
statement	33	529	6.2
branch	0	254	0.0
condition	0	101	0.0
subroutine	11	100	11.0
pod	1	80	1.2
total	45	1064	4.2

package YATT::Lite::WebMVC0::DBSchema; sub MY () {__PACKAGE__}
use strict;
use warnings qw(FATAL all NONFATAL misc);
use Carp;
use File::Basename;
use version;

use base qw/YATT::Lite::Object
	    YATT::Lite::Util::CmdLine
	  /;
use fields (qw/table_list table_dict dbtype cf_DBH
	       cf_user
	       cf_auth
	       cf_connection_spec
	       cf_connect_atstart
	       cf_verbose
	       cf_dbtype
	       cf_NULL
	       cf_name
	       cf_no_header
	       cf_auto_create
	       cf_coltype_map

	       cf_after_dbinit
	       cf_group_writable

	       cf_is_clone
	       cf_debug
	       cf_on_destroy

	       role_dict
	     /);

use YATT::Lite::Types
  ([Item => fields => [qw/not_configured
			  cf_name/]
    , [Table => fields => [qw/pk chk_unique
			      chk_index chk_check
			      col_list col_dict
			      relation_list relation_dict
			      reference_dict
			      initializer
			      cf_view cf_virtual
			      cf_trigger_after_delete
			    /]]
    , [Column => fields => [qw/cf_type
			       cf_hidden
			       cf_unique
			       cf_indexed
			       cf_primary_key
			       cf_autoincrement

			       cf_default
			       cf_null

			       cf_usage
			       cf_label
			       cf_max_length
			     /]]]
);

use YATT::Lite::Util qw/coalesce globref ckeval terse_dump lexpand
			shallow_copy
		       /;

#========================================
DESTROY {
  my MY $self = shift;
  if (my $sub = $self->{cf_on_destroy}) {
    $sub->($self);
  }
  $self->disconnect("from DBSchema->DESTROY");
}
sub disconnect {
  (my MY $schema, my $msg) = @_;
  $msg ||= "";
  if (my $dbh = delete $schema->{cf_DBH}) {
    # XXX: is_clone
    $dbh->commit unless $dbh->{AutoCommit};
    $dbh->disconnect;
    print STDERR "DEBUG: DBSchema->disconnect $msg $schema, had dbh $dbh\n"
      if $schema->{cf_debug};
  } else {
    print STDERR "DEBUG: DBSchema->disconnect $msg $schema, without dbh\n"
      if $schema->{cf_debug};
  }
}

#========================================

sub new {
  my $pack = shift;
  $pack->parse_import(\@_, \ my %opts);
  my MY $self = $pack->SUPER::new(%opts);
  $self->init_schema;
  $self->add_schema(@_) if @_;
  $self->verify_schema;
  $self;
}

sub clone {
  my MY $orig = shift;
  croak "Can't clone non-object: $orig" unless ref $orig;
  my MY $new = bless {}, ref($orig);
  foreach my $k (keys %$orig) {
    my $v = $orig->{$k};
    # shallow_copy with pass-thru flag.
    $new->{$k} = ref $v ? shallow_copy($v, 1) : $v;
  }
  $new->reset;
  $new->{cf_is_clone} = 1;
  $new->configure(@_) if @_;
  print STDERR "DEBUG: dbschema clone, now=$new\n" if $new->{cf_debug};
  $new;
}

sub reset {
  (my MY $self) = @_;
  if (my $dbh = delete $self->{cf_DBH}) {
    $dbh->disconnect if $self->{cf_is_clone};
  }
}

sub is_known_role {
  (my MY $self, my $class) = @_;
  $class //= caller;
  $self->{role_dict}{$class}++;
}

# Extension hook.
sub init_schema {}

sub add_schema {
  (my MY $self) = shift;
  foreach my $item (@_) {
    if (ref $item) {
      $self->add_table(@$item);
    } else {
      croak "Invalid schema item: $item";
    }
  }
}

sub parse_import {
  my ($pack, $list, $opts) = @_;
  # -bool_flag
  # key => value
  for (; @$list; shift @$list) {
    last if ref $list->[0];
    if ($list->[0] =~ /^-(\w+)/) {
      $opts->{$1} = 1;
    } else {
      croak "Option value is missing for $list->[0]"
	unless @$list >= 2;
      $opts->{$list->[0]} = $list->[1];
      shift @$list;
    }
  }
}

#########################################
sub after_connect {
  my MY $self = shift;
  $self->ensure_created_on($self->{cf_DBH}) if $self->{cf_auto_create};
}

sub dbinit_sqlite {
  (my MY $self, my $sqlite_fn) = @_;
  chmod 0664, $sqlite_fn if $self->{cf_group_writable} // 1;
}

#========================================

sub startup {
  (my MY $schema, my (@apps)) = @_;
  foreach my $app (@apps) {
    # XXX: logging?
    my $sub = $app->can("backend_startup")
      or next;
    $sub->($app, $schema);
  }

  if ($schema->{cf_connect_atstart}) {
    $schema->make_connection;
  }
}

#========================================

sub has_connection { my MY $schema = shift; $schema->{cf_DBH} }

sub dbh {
  (my MY $schema) = @_;
  $schema->{cf_DBH} // $schema->make_connection;
}

#
# Quasi-option to configure $when and @spec at once.
#
sub configure_connect {
  (my MY $schema, my $config) = @_;
  my ($when, @spec) = @$config;
  $schema->{cf_connection_spec} = \@spec;
  $schema->{cf_connect_atstart} = $schema->parse_connect_when($when);
}

sub parse_connect_when {
  (my MY $schema, my $when) = @_;
  if ($when =~ /^at_?start$/i) {
    1;
  } elsif ($when =~ /^on_?demand$/i) {
    0;
  } else {
    croak "Unknown connection timing: '$when'";
  }
}

#
# This must fill cf_DBH.
#
sub make_connection {
  (my MY $schema) = shift;
  my ($spec) = @_ ? @_ : $schema->{cf_connection_spec};
  unless (defined $spec) {
    croak "connection_spec is empty";
  }
  if (ref $spec eq 'ARRAY' or not ref $spec) {
    $schema->connect_to(lexpand($spec));
  } elsif (ref $spec eq 'CODE') {
    $spec->($schema);
  } else {
    croak "Unknown connection spec obj: $spec";
  }
  print STDERR "DEBUG: dbh for $schema=$schema->{cf_DBH}"
    , ($schema->{cf_debug} >= 2 ? Carp::longmess() : ()), "\n\n"
      if $schema->{cf_debug};
  $schema->{cf_DBH};
}

#----------------------------------------
sub connect_to {
  (my MY $schema, my ($dbtype, @args)) = @_;
  if ($dbtype =~ /^dbi:/i) {
    $schema->connect_to_dbi($dbtype, @args);
  } elsif (my $sub = $schema->can("connect_to_\L$dbtype")) {
    $schema->{dbtype} = lc($dbtype);
    $sub->($schema, @args);
  } else {
    croak sprintf("%s: Unknown dbtype: %s", MY, $dbtype);
  }
}

sub connect_to_dbi {
  (my MY $schema, my ($dbi, @args)) = @_;
  my ($driver) = $dbi =~ m{^dbi:([^:]+):}i
    or croak "Unknown driver spec in DBI DSN! $dbi";
  if (my $sub = $schema->can("connect_to_\L$driver")) {
    $schema->{dbtype} = lc($driver);
    $sub->($schema, $dbi, @args);
  } else {
    $schema->dbi_connect($dbi, @args);
  }
}

#----------------------------------------

sub connect_to_sqlite {
  (my MY $schema, my ($dsn_or_sqlite_fn, %opts)) = @_;
  require DBD::SQLite; my $minver = version->parse("1.30_02");

  my ($sqlite_fn, $dbi_dsn) = do {
    if ($dsn_or_sqlite_fn =~ /^dbi:SQLite:(?:dbname=)?(.*)$/i) {
      ($1, $dsn_or_sqlite_fn);
    } else {
      ($dsn_or_sqlite_fn, "dbi:SQLite:dbname=$dsn_or_sqlite_fn");
    }
  };
  unless (delete $opts{RO}) {
    $opts{sqlite_use_immediate_transaction} = 1
      if version->parse($DBD::SQLite::VERSION) >= $minver;
  }
  $schema->{dbtype} //= 'sqlite';
  my $first_time = not -e $sqlite_fn;
  $schema->{cf_auto_create} //= 1;
  $schema->dbi_connect($dbi_dsn, undef, undef, %opts);
  $schema->dbinit_sqlite($sqlite_fn) if $first_time;
  $schema;
}

sub dbi_connect {
  (my MY $schema, my ($dbi_dsn, $user, $auth, %attr)) = @_;
  my %default = $schema->default_dbi_attr;
  $attr{$_} //= $default{$_} for keys %default;
  require DBI;
  my $dbh = $schema->{cf_DBH} = DBI->connect($dbi_dsn, $user, $auth, \%attr);
  $schema->after_connect;
  $schema;
}

sub default_dbi_attr {
  (RaiseError => 1, PrintError => 0, AutoCommit => 1);
}

#----------------------------------------

#
# ./lib/MyModel.pm create sqlite data/myapp.db3
#
sub create {
  (my MY $schema, my @spec) = @_;
  # $schema->dbh() will call ensure_created_on when auto_create is on.
  my $dbh = $schema->{cf_DBH} || $schema->make_connection(\@spec);
  #
  $schema->ensure_created_on($dbh) unless $schema->{cf_auto_create};
  $schema;
}

sub ensure_created_on {
  (my MY $schema, my $dbh) = @_;
  # Carp::cluck("ensure_created is called");

  $schema->dbtype_try_invoke('begin_create');

  my (@sql, @created);
  foreach my Table $table ($schema->list_tables(raw => 1)) {
    next if $schema->has_table($table->{cf_name}, $dbh);
    push @created, $table;
    foreach my $create ($schema->sql_create_table($table)) {
      unless ($schema->{cf_verbose}) {
      } elsif ($schema->{cf_verbose} >= 2) {
	print STDERR "-- $table->{cf_name} --\n$create\n\n"
      } elsif ($schema->{cf_verbose} and $create =~ /^create table /i) {
	print STDERR "CREATE TABLE $table->{cf_name}\n";
      }
      push @sql, $create;
    }
  }
  foreach my Table $view ($schema->list_views(raw => 1)) {
    next if $schema->has_view($view->{cf_name}, $dbh);
    next if $view->{cf_virtual};
    if ($schema->{cf_verbose}) {
      print STDERR "CREATE VIEW $view->{cf_name}\n";
    }
    push @sql, "CREATE VIEW $view->{cf_name}\nAS $view->{cf_view}";
  }
  $dbh->do($_) for @sql;
  if (@created) {
    foreach my Table $tab (@created) {
      $schema->ensure_table_populated($dbh, $tab);
    }
  }
  if (@sql) {
    $dbh->commit unless $dbh->{AutoCommit};
  }
  @created;
}

sub ensure_table_populated {
  (my MY $schema, my $dbh, my Table $tab) = @_;
  foreach my $init (lexpand($tab->{initializer})) {
    my ($colSpec, @values) = @$init;
    my $sql = $schema->sql_to_insert($tab->{cf_name}, @$colSpec);
    my $ins = $dbh->prepare($sql);
    foreach my $record (@values) {
      if (grep {ref $_ eq 'SCALAR'} @$record) {
	my ($sql, $values) = $schema->sql_and_values_to_insert_expr
	  ($tab->{cf_name}, $colSpec, $record);
	my @vals = $schema->expand_codevalue($tab, $values);
	print STDERR $sql, "\n -- (", join(",", @vals), ")\n"
	  if $schema->{cf_verbose};
	$dbh->do($sql, undef, @vals);
      } else {
	my @vals = $schema->expand_codevalue($tab, $record);
	print STDERR $sql, "\n -- (", join(",", @vals), ")\n"
	  if $schema->{cf_verbose};
	$ins->execute(@vals);
      }
    }
  }
}

sub sqlite_begin_create {
  (my MY $schema) = @_;
  # To speedup create statements.
  $schema->dbh->do("PRAGMA synchronous = OFF");
}

sub expand_codevalue {
  (my MY $schema, my $tab, my $record) = @_;
  map {ref $_ ? $_->($schema, $tab) : $_} @$record;
}

sub has_table { shift->has_type(table => @_); }
sub has_view  { shift->has_type(view => @_); }

sub has_type {
  (my MY $schema, my ($type, $table, $dbh)) = @_;
  if ($$schema{dbtype}
      and my $sub = $schema->can("$$schema{dbtype}_has_type")) {
    $sub->($schema, $type, $table, $dbh);
  } else {
    $dbh ||= $schema->dbh;
    $dbh->tables("", "", $table, uc($type));
  }
}

sub dbtype_try_invoke {
  (my MY $schema, my ($method, @args)) = @_;
  return unless $schema->{dbtype};
  my $sub = $schema->can("$schema->{dbtype}_$method")
    or return;
  $sub->($schema, @args);
}

sub sqlite_has_type {
  (my MY $schema, my ($type, $name, $dbh)) = @_;
  my ($found) = $dbh->selectrow_array(<<'END', undef, $type, $name)
select name from sqlite_master where type = ? and name = ?
END

    or return undef;
  $found;
}

sub tables {
  my MY $schema = shift;
  keys %{$schema->{table_dict}};
}

sub has_column {
  (my MY $schema, my ($table, $column, $dbh)) = @_;
  my $hash = $schema->columns_hash($table, $dbh || $schema->dbh);
  exists $hash->{$column};
}

sub columns_hash {
  (my MY $schema, my ($table, $dbh)) = @_;
  $dbh ||= $schema->dbh;
  my $sth = $dbh->prepare("select * from $table limit 0");
  $sth->execute;
  my %hash = %{$sth->{NAME_hash}};
  \%hash;
}

sub drop {
  (my MY $schema) = @_;
  foreach my $sql ($schema->sql_drop) {
    $schema->dbh->do($sql);
  }
}

#========================================

sub _list_items {
  (my MY $self, my $opts) = splice @_, 0, 2;
  $opts->{raw} ? @_ : map {
    my Item $item = $_;
    $item->{cf_name}
  } @_;
}

sub list_tables {
  (my MY $self, my %opts) = @_;
  $self->_list_items(\%opts, grep {
    my Table $tab = $_;
    not $tab->{cf_view}
  } @{$self->{table_list}});
}

sub list_views {
  (my MY $self, my %opts) = @_;
  $self->_list_items(\%opts, grep {
    my Table $tab = $_;
    $tab->{cf_view}
  } @{$self->{table_list}});
}

sub list_relations {
  (my MY $self, my ($tabName, %opts)) = @_;
  my Table $tab = $self->{table_dict}{$tabName}
    or return;
  if ($opts{raw}) {
    @{$tab->{relation_list}}
  } else {
    map {
      (my ($relType, $relName, $fkName), my Table $subTab) = @$_;
      $fkName //= do {
	if (my Column $pk = $self->get_table_pk($subTab)
	    || $self->get_table_pk($tab)) {
	  $pk->{cf_name};
	}
      };
      [$relType, $relName, $fkName, $subTab->{cf_name}];
    } @{$tab->{relation_list}};
  }
}

sub list_table_columns {
  (my MY $self, my ($tabName, %opts)) = @_;
  my Table $tab = $self->{table_dict}{$tabName}
    or return;
  $self->_list_items(\%opts, @{$tab->{col_list}});
}

sub get_table {
  (my MY $self, my $name) = @_;
  $self->{table_dict}{$name} //= do {
    push @{$self->{table_list}}
      , my Table $tab = $self->Table->new(name => $name);
    $tab->{not_configured} = 1;
    $tab;
  };
}

sub get_table_pk {
  (my MY $self, my ($tabName, %opts)) = @_;
  my Table $tab = ref $tabName ? $tabName : $self->{table_dict}{$tabName};
  my $pkinfo = $tab->{pk};
  return unless $pkinfo;
  if (wantarray) {
    $self->_list_items(\%opts, ref $pkinfo eq 'ARRAY' ? @$pkinfo : $pkinfo);
  } else {
    ref $pkinfo eq 'ARRAY' ? $pkinfo->[0] : $pkinfo
  }
}

sub add_table {
  my MY $self = shift;
  my ($name, $opts, @colpairs) = @_;
  my Table $tab = $self->get_table($name);
  return $tab if @_ == 1;
  if ($tab and not $tab->{not_configured}) {
    croak "Duplicate definition of table $name";
  }
  delete $tab->{not_configured};
  $self->extend_table(@_);
}

sub extend_table {
  my MY $self = shift;
  my ($name, $opts, @colpairs) = @_;
  my Table $tab = $self->get_table($name);
  $tab->configure(lhexpand($opts)) if $opts;
  while (@colpairs) {
    # colName => [colSpec]
    # [check => args]
    unless (ref $colpairs[0]) {
      my ($col, $desc) = splice @colpairs, 0, 2;
      $self->add_table_column($tab, $col, ref $desc ? @$desc : $desc);
    } else {
      my ($method, @args) = @{shift @colpairs};
      $method =~ s/^-//;
      # XXX: [has_many => @tables]
      if (my ($relType, @relSpec) = $self->known_rels($method, undef, @args)) {
	$self->add_table_relation($tab, undef, $relType => \@relSpec, @args);
      } else {
	my $sub = $self->can("add_table_\L$method")
	  or croak "Unknown table option '$method' for table $name";
	$sub->($self, $tab, @args);
      }
    }
  }

  $tab;
}

sub add_table_primary_key {
  (my MY $self, my Table $tab, my @args) = @_;
  if ($tab->{pk} and @args) {
    croak "Duplicate PK definition. old $tab->{pk}";
  }
  $tab->{pk} = [map {$tab->{col_dict}{$_}} @args];
}

sub add_table_unique {
  (my MY $self, my Table $tab, my @cols) = @_;
  # XXX: 重複検査, 有無検査
  push @{$tab->{chk_unique}}, [@cols];
}

sub add_table_index {
  (my MY $self, my Table $tab, my @cols) = @_;
  # XXX: 重複検査, 有無検査
  push @{$tab->{chk_index}}, [@cols];
}

# -opt は引数無フラグ、又は [-opt, ...] として可変長オプションに使う
sub add_table_relation {
  (my MY $self, my Table $tab, my Column $fkCol
   , my ($relType, $relSpec, $item, $fkName, $atts)) = @_;
  unless (defined $item) {
    croak "Undefined relation spec for table $tab->{cf_name}";
  }

  #
  # [-has_many => 'table.key']
  #
  $fkName = $1 if not ref $item and $item =~ s/\.(\w+)$//;

  my Table $subTab = ref $item ? $self->add_table(@$item)
    : $self->get_table($item);
  my $relName = $relSpec->[0] // lc($subTab->{cf_name});
  $fkName //= $relSpec->[1] // $fkCol->{cf_name}
    // $subTab->{reference_dict}{$tab->{cf_name}};
  if ($tab->{relation_dict}{$relName}) {
    croak "Conflicting relation! $tab->{cf_name}.$relName";
  }
  push @{$tab->{relation_list}}
    , $tab->{relation_dict}{$relName}
      = [$relType => $relName, $fkName, $subTab];
}

sub add_table_column {
  (my MY $self, my Table $tab, my ($colName, $type, @colSpec)) = @_;
  if ($tab->{col_dict}{$colName}) {
    croak "Conflicting column name $colName for table $tab->{cf_name}";
  }
  # $tab.$colName is encoded by $refTab.pk
  if (ref $type) {
    croak "Deprecated column spec in $tab->{cf_name}.$colName";
  } elsif (not defined $type) {
    Carp::cluck "Column type $tab->{cf_name}.$colName is undef";
  }

  my (@opt, @rels);
  while (@colSpec) {
    unless (defined (my $key = shift @colSpec)) {
      croak "Undefined colum spec for $tab->{cf_name}.$colName";
    } elsif (ref $key) {
      my ($method, @args) = @$key;
      $method =~ s/^-//;
      # XXX: [has_many => @tables]
      # XXX: [unique => k1, k2..]
      if (my ($relType, @relSpec)
	  = $self->known_rels($method, $colName, @args)) {
	push @rels, [$relType => \@relSpec, @args];
      } else {
	croak "Unknown method $method";
      }
    } elsif ($key =~ /^-/) {
      push @opt, $key => 1;
    } else {
      push @opt, $key, shift @colSpec;
    }
  }
  push @{$tab->{col_list}}, ($tab->{col_dict}{$colName})
    = (my Column $col) = $self->Column->new
      (@opt, name => $colName, type => $type);
  $tab->{pk} = $col if $col->{cf_primary_key};

  $self->add_table_relation($tab, $col, @$_) for @rels;

  # XXX: Validation: name/option conflicts and others.
  $col;
}

sub add_table_values {
  (my MY $self, my Table $tab, my ($colspec, @values)) = @_;
  push @{$tab->{initializer}}, [$colspec, @values];
}

sub verify_schema {
  (my MY $self) = @_;
  my @not_configured;
  foreach my Table $tab (lexpand($self->{table_list})) {
    if ($tab->{not_configured}) {
      push @not_configured, $tab->{cf_name};
      next;
    }
    # foreach my Column $col (lexpand($tab->{col_list})) { }
  }
  if (@not_configured) {
    croak "Some tables are not configure, possibly spellmiss!: @not_configured";
  }
}

{
  my %known_rels = qw(has_many 1 has_one 1 belongs_to 1
		      many_to_many 1 might_have 1
		    );
  sub known_rels {
    (my MY $self, my ($desc, $myColName, @args)) = @_;
    # ['-has_many:rel:fk' => 'table']
    # has_many   ..fk is their_fk
    # belongs_to ..fk is our_fk
    my ($relType, $relName, $fkName) = split /:/, $desc, 3;
    return unless $known_rels{$relType};
    ($relType, $relName, $fkName || $myColName)
  }
}

#========================================

sub sql_create {
  (my MY $schema, my %opts) = @_;
  $schema->foreach_tables_do('sql_create_table', \%opts)
}

sub default_dbtype {'sqlite'}
sub sql_create_table {
  (my MY $schema, my Table $tab, my $opts) = @_;
  my (@cols, @indices);
  my $dbtype = $opts->{dbtype} || $schema->default_dbtype;
  my $sub = $schema->can($dbtype.'_sql_create_column')
    || $schema->can('sql_create_column');

  my $pk_ok;
  foreach my Column $col (@{$tab->{col_list}}) {
    $pk_ok = 1 if $col->{cf_primary_key};
    push @cols, $sub->($schema, $tab, $col, $opts);
    push @indices, $col if $col->{cf_indexed};
  }

  # Multi column primary key(...)
  # XXX: conflict clause
  if (not $pk_ok and $tab->{pk}) {
    push @cols, "PRIMARY KEY(".join(", ", map {
      my Column $col = $_;
      $col->{cf_name}
    } @{$tab->{pk}}).")";
  }

  # Other unique(...)
  foreach my $constraint (lexpand($tab->{chk_unique})) {
    push @cols, sprintf q{unique(%s)}, join(", ", @$constraint);
  }

  # XXX: SQLite specific.
  # XXX: MySQL ENGINE(TYPE) = ...
  push my @create
    , sprintf qq{CREATE TABLE %s\n(%s)}, $tab->{cf_name}
      , join "\n, ", @cols;

  foreach my Column $ix (@indices) {
    push @create
      , sprintf q{CREATE INDEX %1$s_%2$s on %1$s(%2$s)}
	, $tab->{cf_name}, $ix->{cf_name};
  }

  foreach my $colnames (lexpand($tab->{chk_index})) {
    my $ixname = join "_", $tab->{cf_name}, @$colnames;
    push @create, sprintf(q{CREATE INDEX %s on %s(%s)}
			  , $tab->{cf_name}
			  , join("_", $tab->{cf_name}, @$colnames)
			  , join(",", @$colnames));
  }

  # after delete on user for each row begin
  if (my $trigger = $tab->{cf_trigger_after_delete}) {
    push @create, map {
      qq{CREATE TRIGGER $_ AFTER DELETE ON $tab->{cf_name}}
	. qq{ FOR EACH ROW } . $schema->sql_compound_trigger($trigger->{$_});
    } keys %$trigger;
  }

  wantarray ? @create : join(";\n", @create);
}

# XXX: text => varchar(80)
sub map_coltype {
  (my MY $schema, my $typeName) = @_;
  $schema->{cf_coltype_map}{$typeName} // $typeName;
}

sub sql_create_column {
  (my MY $schema, my Table $tab, my Column $col, my $opts) = @_;
  # XXX: primary key ASC/DESC
  join(" ", $col->{cf_name}
       , $schema->map_coltype($col->{cf_type})
       , ($col->{cf_primary_key} ? "primary key" : ())
       , ($col->{cf_unique} ? "unique" : ())
       , ($col->{cf_autoincrement} ? "autoincrement" : ()));
}

sub sqlite_sql_create_column {
  (my MY $schema, my Table $tab, my Column $col, my $opts) = @_;
  unless (defined $col->{cf_type}) {
    croak "Column type is not yet defined! $tab->{cf_name}.$col->{cf_name}"
  } elsif ($col->{cf_type} =~ /^int/i && $col->{cf_primary_key}) {
    "$col->{cf_name} integer primary key"
  } else {
    $schema->sql_create_column($tab, $col, $opts);
  }
}

sub sql_compound_trigger {
  (my MY $schema, my $item) = @_;
  my $sub = $schema->can($$schema{dbtype}.'_sql_compound_trigger')
    or croak "Compound trigger for $$schema{dbtype} is not yet implemented";
  $sub->($schema, $item);
}

sub mysql_sql_compound_trigger {
  (my MY $schema, my $item) = @_;
  unless (ref $item) {
    $item
  } elsif (@$item == 1) {
    $item->[0]
  } else {
    "BEGIN ".join("; ", @$item). "; END";
  }
}

sub sqlite_sql_compound_trigger {
  (my MY $schema, my $item) = @_;
  "BEGIN ".join("; ", ref $item ? @$item : $item). "; END";
}

sub sql_drop {
  shift->foreach_tables_do
    (sub {
       (my Table $tab) = @_;
       qq{drop table $tab->{cf_name}};
     })
}

sub foreach_tables_do {
  (my MY $self, my $method, my $opts) = @_;
  my $code = ref $method ? $method : sub {
    $self->$method(@_);
  };
  my @result;
  my $wantarray = wantarray;
  foreach my Table $tab (@{$self->{table_list}}) {
    push @result, map {
      $wantarray ? $_ . "\n" : $_
    } $code->($tab, $opts);
   }
  wantarray ? @result : join(";\n", @result);
}

########################################
# Below is poorman's CRUD closure generator(instead of ORM).


sub to_encode {
  (my MY $self, my $tabName, my $keyCol, my @otherCols) = @_;

  my $to_find = $self->to_find($tabName, $keyCol);
  my $to_ins = $self->to_insert($tabName, $keyCol, @otherCols);

  sub {
    my ($value, @rest) = @_;
    $to_find->($value) || $to_ins->($value, @rest);
  };
}

# to_fetchall は別途用意する
sub to_find {
  (my MY $self, my ($tabName, $keyCol, $rowidCol)) = @_;
  my $sql = $self->sql_to_find($tabName, $keyCol, $rowidCol);
  print STDERR "-- $sql\n" if $self->{cf_verbose};
  my $sth;
  sub {
    my ($value) = @_;
    $sth ||= $self->dbh->prepare($sql);
    $sth->execute($value);
    my ($rowid) = $sth->fetchrow_array
      or return;
    $rowid;
  };
}

sub to_fetch {
  (my MY $self, my ($tabName, $keyColList, $resColList, @rest)) = @_;
  my $sql = $self->sql_to_fetch($tabName, $keyColList, $resColList, @rest);
  print STDERR "-- $sql\n" if $self->{cf_verbose};
  my $sth;
  sub {
    my (@value) = @_;
    $sth ||= $self->dbh->prepare($sql);
    $sth->execute(@value);
    $sth;
  };
}

sub to_insert {
  (my MY $self, my ($tabName, @fields)) = @_;
  my $sql = $self->sql_to_insert($tabName, @fields);
  print STDERR "-- $sql\n" if $self->{cf_verbose};
  my $sth;
  sub {
    my (@value) = @_;
    $sth ||= $self->dbh->prepare($sql);
    # print STDERR "-- inserting @value to $sql\n";
    $sth->execute(@value);
    $self->dbh->last_insert_id('', '', '', '');
  };
}

sub sql_to_find {
  (my MY $self, my ($tabName, $keyCol, $rowidCol)) = @_;
  my Table $tab = $self->{table_dict}{$tabName}
    or croak "No such table: $tabName";
  # XXX: col name check.
  $rowidCol ||= $self->rowid_col($tab);
  <
select $rowidCol from $tabName where $keyCol = ?
END
}

sub sql_to_fetch {
  (my MY $self, my ($tabName, $keyColList, $resColList, %opts)) = @_;
  my $group_by = delete $opts{group_by};
  my $order_by = delete $opts{order_by};
  my Table $tab = $self->{table_dict}{$tabName}
    or croak "No such table: $tabName";
  # XXX: col name check... いや、式かもしれないし。
  my $cols = $resColList ? join(", ", lexpand $resColList) : '*';
  my $where = do {
    unless (defined $keyColList) {
      undef;
    } elsif (not ref $keyColList) {
      "$keyColList = ?"
    } elsif (ref $keyColList eq 'ARRAY') {
      join " AND ", map {"$_ = ?"} @$keyColList
    } elsif (ref $keyColList eq 'SCALAR') {
      # RAW SQL
      $$keyColList;
    } else {
      die "Not yet implemented!";
    }
  };
  if ($group_by) {
    $where .= " GROUP BY $group_by";
  }
  if ($order_by) {
    $where .= " ORDER BY $order_by";
  }
  qq|select $cols from $tabName| . (defined $where ? " where $where" : "");
}


sub sql_to_insert {
  (my MY $self, my ($tabName, @fields)) = @_;
  sprintf qq{INSERT INTO $tabName(%s) VALUES(%s)}
    , join(", ", @fields)
      , join(", ", map {'?'} @fields);
}

sub sql_and_values_to_insert_expr {
  (my MY $self, my ($tabName, $colNames, $valsOrExprs)) = @_;
  my (@values);
  my @exprs = map {
    if (ref $_) {
      $$_;
    } else {
      push @values, $_;
      '?'
    }
  } @$valsOrExprs;
  my $sql = sprintf qq{INSERT INTO $tabName(%s) VALUES(%s)}
    , join(", ", @$colNames), join(", ", @exprs);

  ($sql, \@values);
}


sub default_rowid_col { 'rowid' }
sub rowid_col {
  (my MY $schema, my Table $tab) = @_;
  if (my Column $pk = $tab->{pk}) {
    $pk->{cf_name}
  } else {
    # XXX: dbtype dispatch
    $schema->default_rowid_col;
  }
}

########################################

sub add_inc {
  my ($pack, $callpack) = @_;
  $callpack =~ s{::}{/}g;
  $INC{$callpack . '.pm'} = 1;
}

########################################

use YATT::Lite::XHF::Dumper;

sub cmd_deploy {
  (my MY $schema) = @_;
  local $schema->{cf_verbose} = 1;
  my $dbh = $schema->dbh;
  local $dbh->{AutoCommit};
  $schema->ensure_created_on($dbh);
  $dbh->commit;
}

sub cmd_schema {
  (my MY $schema) = @_;
  print $schema->dump_xhf(map {
    $schema->info_tableobj($_);
  } @{$schema->{table_list}}), "\n";
}

sub info_tableobj {
  (my MY $schema, my Table $tab) = @_;
  [$tab->{cf_name}, undef, map {
    $schema->info_columnobj($_);
   } @{$tab->{col_list}}];
}

sub info_columnobj {
  (my MY $schema, my Column $col) = @_;
  ($col->{cf_name}, $col->{cf_type});
}

sub cmd_help {
  my ($self) = @_;
  my $pack = ref($self) || $self;
  my @opts = do {
    if (my $sub = $pack->can('cf_list')) {
      $sub->($pack, qr{^cf_([a-z]\w*)});
    } else {
      ();
    }
  };
  require YATT::Lite::Util::FindMethods;
  my @methods = YATT::Lite::Util::FindMethods::FindMethods
    ($pack, , sub {s/^cmd_//});
  die <
Usage: @{[basename($0)]} [--opt=value]  [--opt=value] []

Available commands are:
  @{[join("\n  ", @methods)]}

All options(might not usefull) are:
  @{[join "\n  ", map {"--$_"} @opts]}
END

}

#========================================

sub ymd_hms {
  my ($pack, $time, $as_utc) = @_;
  my ($S, $M, $H, $d, $m, $y) = map {
    $as_utc ? gmtime($_) : localtime($_)
  } $time;
  sprintf q{%04d-%02d-%02d %02d:%02d:%02d}, 1900+$y, $m+1, $d, $H, $M, $S;
}

sub lhexpand {
  return unless defined $_[0];
  ref $_[0] eq 'HASH' ? %{$_[0]}
    : ref $_[0] eq 'ARRAY' ? @{$_[0]}
      : croak "Invalid option: $_[0]";
}

use YATT::Lite::Breakpoint ();
YATT::Lite::Breakpoint::break_load_dbschema();

1;