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

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

use warnings;
use strict;
use Carp;
use DBIx::DataModel::Source::Table;

use Scalar::Util     qw/blessed reftype/;
use Module::Load     qw/load/;
use Params::Validate qw/validate SCALAR ARRAYREF CODEREF UNDEF 
                                 OBJECT BOOLEAN/;
use Acme::Damn       qw/damn/;
use SQL::Abstract::More 1.0;

use namespace::clean;

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

my $spec = {
  dbh                          => {type => OBJECT|ARRAYREF, optional => 1},
  debug                        => {type => OBJECT|SCALAR,   optional => 1},
  sql_abstract                 => {type => OBJECT,
                                   isa  => 'SQL::Abstract::More',
                                   optional => 1},
  dbi_prepare_method           => {type => SCALAR, default => 'prepare'},
  placeholder_prefix           => {type => SCALAR, default => '?:'},
  select_implicitly_for        => {type => SCALAR, default => ''},
};



sub new {
  my $class = shift;

  not $class->metadm->{singleton}
    or croak "$class is already used in single-schema mode, can't call new()";

  # validate params
  my %params = validate(@_, $spec);

  # instantiate and call 'setter' methods for %params
  my $self = bless {}, $class;
  while (my ($method, $arg) = each %params) {
    $self->$method($arg);
  }

  # default SQLA
  $self->{sql_abstract} ||= SQL::Abstract::More->new;

  # from now on, singleton mode will be forbidden
  $class->metadm->{singleton} = undef;

  return $self;
}


# proxy methods, forwarded to the meta-schema
foreach my $method (qw/Table View Association Composition Type/) {
  no strict 'refs';
  *{$method} = sub {
    my $class = shift;
    not ref $class or croak "$method() is a class method";
    $class->metadm->$method(@_);
  }
}


sub singleton {
  my $class = shift;
  my $metadm = $class->metadm;

  if (!$metadm->{singleton}) {
    not exists $metadm->{singleton}
      or croak "attempt to call a class method in single-schema mode after "
             . "Schema::new() has been called; instead, use an instance "
             . "method : \$schema->table(\$name)->method(...)";
    $metadm->{singleton} = $class->new(@_);
    $metadm->{singleton}{is_singleton} = 1;
  }
  elsif (@_) {
    croak "can't pass args to ->singleton(..) after first call"; 
  }
  return $metadm->{singleton};
}



#----------------------------------------------------------------------
# RUNTIME METHODS
#----------------------------------------------------------------------

sub dbh {
  my ($self, $dbh, %dbh_options) = @_;

  ref $self or $self = $self->singleton;

  # if some args, then this is a "setter" (updating the dbh)
  if (@_ > 1) {

    # also support syntax ->dbh([$dbh, %dbh_options])
    ($dbh, %dbh_options) = @$dbh 
      if $dbh && ref $dbh eq 'ARRAY' && ! keys %dbh_options;

    # forbid change of dbh while doing a transaction
    not $self->{dbh} or $self->{dbh}[0]{AutoCommit}
      or croak "cannot change dbh(..) while in a transaction";

    if ($dbh) {
      # $dbh must be a database handle
      $dbh->isa('DBI::db')
        or croak "invalid dbh argument";

      # only accept $dbh with RaiseError set
      $dbh->{RaiseError} 
        or croak "arg to dbh(..) must have RaiseError=1";

      # store the dbh
      $self->{dbh} = [$dbh, %dbh_options];
    }
    else {
      # $dbh was explicitly undef, so remove previous dbh
      delete $self->{dbh};
    }
  }

  my $return_dbh = $self->{dbh} || [];
  return wantarray ? @$return_dbh : $return_dbh->[0];
}



# some rw setters/getters
my @accessors = qw/debug select_implicitly_for dbi_prepare_method 
                   sql_abstract placeholder_prefix/;
foreach my $accessor (@accessors) {
  no strict 'refs';
  *$accessor = sub {
    my $self = shift;
    ref $self or $self = $self->singleton;

    if (@_) {
      $self->{$accessor} = shift;
    }
    return $self->{$accessor};
  };
}




my @default_state_components = qw/dbh debug select_implicitly_for
                                  dbi_prepare_method /;

sub localize_state {
  my ($self, @components) = @_; 
  ref $self or $self = $self->singleton;

  @components = @default_state_components unless @components;

  my %saved_state;
  $saved_state{$_} = $self->{$_} foreach @components;

  return DBIx::DataModel::Schema::_State->new($self, \%saved_state);
}



sub do_transaction { 
  my ($self, $coderef, @new_dbh) = @_; 
  ref $self or $self = $self->singleton;

  ref $coderef eq 'CODE'
    or croak 'first arg to $schema->do_transaction(...) should be a coderef';

  my $transaction_dbhs = $self->{transaction_dbhs} ||= [];

  # localize the dbh and its options, if so requested. 
  my $local_state = $self->localize_state(qw/dbh/)
    and
        delete($self->{dbh}),  # cheat so that dbh() does not complain
        $self->dbh(@new_dbh)   # and now update the dbh
    if @new_dbh; # postfix "if" because $local_state must not be in a block

  # check that we have a dbh
  my $dbh = $self->{dbh}[0]
    or croak "no database handle for transaction";

  # how to call and how to return will depend on context
  my $want = wantarray ? "array" : defined(wantarray) ? "scalar" : "void";
  my $in_context = {
    array  => do {my @array;
                  {call   => sub {@array = $coderef->()}, 
                   return => sub {return @array}}},
    scalar => do {my $scalar;
                  {call   => sub {$scalar = $coderef->()}, 
                   return => sub {return $scalar}}},
    void   =>     {call   => sub {$coderef->()}, 
                   return => sub {return}}
   }->{$want};


  my $begin_work_and_exec = sub {
    # make sure dbh is in transaction mode
    if ($dbh->{AutoCommit}) {
      $dbh->begin_work; # will set AutoCommit to false
      push @$transaction_dbhs, $dbh;
    }

    # do the real work
    $in_context->{call}->();
  };

  if (@$transaction_dbhs) { # if in a nested transaction, just exec
    $begin_work_and_exec->();
  }
  else { # else try to execute and commit in an eval block
    eval {
      # check AutoCommit state
      $dbh->{AutoCommit}
        or croak "dbh was not in Autocommit mode before initial transaction";

      # execute the transaction
      $begin_work_and_exec->();

      # commit all dbhs and then reset the list of dbhs
      $_->commit foreach @$transaction_dbhs;
      delete $self->{transaction_dbhs};
    };

    # if any error, rollback
    my $err = $@;
    if ($err) {              # the transaction failed
      my @rollback_errs = grep {$_} map {eval{$_->rollback}; $@} 
                                        reverse @$transaction_dbhs;
      delete $self->{transaction_dbhs};
      DBIx::DataModel::Schema::_Exception->throw($err, @rollback_errs);
    }
  }

  return $in_context->{return}->();
}




sub unbless {
  my $class = shift;
  _recursive_unbless($_) foreach @_;

  return wantarray ? @_ : $_[0];
}


# accessors to connected sources (tables or joins) from the current schema
#                   local method     metadm method
#                   ============     =============
my %accessor_map = (table         => 'table',
                    join          => 'define_join');
while (my ($local, $remote) = each %accessor_map) {
  no strict 'refs';
  *$local = sub {
    my $self = shift;
    ref $self or $self = $self->singleton;

    my $meta_source = $self->metadm->$remote(@_) or return;
    my $cs_class = $self->metadm->connected_source_class;
    load $cs_class;
    return $cs_class->new($meta_source, $self);
  }
}


#----------------------------------------------------------------------
# UTILITY FUNCTIONS (PRIVATE)
#----------------------------------------------------------------------

sub _recursive_unbless {
  my $obj = shift;

  damn $obj if blessed $obj;

  for (ref $obj) {
    /^HASH$/  and do {  delete $obj->{__schema};
                        _recursive_unbless($_) foreach values %$obj;  };
    /^ARRAY$/ and do {  _recursive_unbless($_) foreach @$obj;         };
  }
}


sub _debug { # internal method to send debug messages
  my ($self, $msg) = @_;
  my $debug = $self->debug;
  if ($debug) {
    if (ref $debug && $debug->can('debug')) { $debug->debug($msg) }
    else                                    { carp $msg; }
  }
}





#----------------------------------------------------------------------
# PRIVATE CLASS FOR LOCALIZING STATE (see L</localizeState> method
#----------------------------------------------------------------------

package DBIx::DataModel::Schema::_State;

sub new {
  my ($class, $schema, $state) = @_;
  bless [$schema, $state], $class;
}


sub DESTROY { # called when the guard goes out of scope
  my ($self) = @_;

  # localize $@, in case we were called while dying - see L<perldoc/Destructors>
  local $@;

  my ($schema, $previous_state) = @$self;

  # must cleanup dbh so that ->dbh(..) does not complain if in a transaction
  if (exists $previous_state->{dbh}) {
    delete $schema->{dbh};
  }

  # invoke "setter" method on each state component
  $schema->$_($previous_state->{$_}) foreach keys %$previous_state;
}


#----------------------------------------------------------------------
# PRIVATE CLASS FOR TRANSACTION EXCEPTIONS
#----------------------------------------------------------------------

package DBIx::DataModel::Schema::_Exception;
use strict;
use warnings;

use overload '""' => sub {
  my $self = shift;
  my $err             = $self->initial_error;
  my @rollback_errs   = $self->rollback_errors;
  my $rollback_status = @rollback_errs ? join(", ", @rollback_errs) : "OK";
  return "FAILED TRANSACTION: $err (rollback: $rollback_status)";
};


sub throw {
  my $class = shift;
  my $self = bless [@_], $class;
  die $self;
}

sub initial_error {
  my $self = shift;
  return $self->[0];
}

sub rollback_errors {
  my $self = shift;
  return @$self[1..$#{$self}];
}


1; 

__END__

=head1 NAME

DBIx::DataModel::Schema - Factory for DBIx::DataModel Schemas

=head1 DESCRIPTION

This is the parent class for all schema classes created through

  DBIx::DataModel->Schema($schema_name, ...);

=head1 CONSTRUCTOR

[TODO]

=head1 METHODS

Methods are documented in 
L<DBIx::DataModel::Doc::Reference|DBIx::DataModel::Doc::Reference>.
This module implements

=over

=item L<Schema|DBIx::DataModel::Doc::Reference/Schema>

=item L<Table|DBIx::DataModel::Doc::Reference/Table>

=item L<View|DBIx::DataModel::Doc::Reference/View>

=item L<Association|DBIx::DataModel::Doc::Reference/Association>

=item L<join|DBIx::DataModel::Doc::Reference/join>

=item L<ColumnType|DBIx::DataModel::Doc::Reference/ColumnType>

=item L<dbh|DBIx::DataModel::Doc::Reference/dbh>

=item L<debug|DBIx::DataModel::Doc::Reference/debug>

=item L<noUpdateColumns|DBIx::DataModel::Doc::Reference/noUpdateColumns>

=item L<autoUpdateColumns|DBIx::DataModel::Doc::Reference/autoUpdateColumns>

=item L<selectImplicitlyFor|DBIx::DataModel::Doc::Reference/selectImplicitlyFor>

=item L<dbiPrepareMethod|DBIx::DataModel::Doc::Reference/dbiPrepareMethod>

=item L<tables|DBIx::DataModel::Doc::Reference/tables>

=item L<table|DBIx::DataModel::Doc::Reference/table>

=item L<localizeState|DBIx::DataModel::Doc::Reference/localizeState>

=item L<statementClass|DBIx::DataModel::Doc::Reference/statementClass>

=item L<doTransaction|DBIx::DataModel::Doc::Reference/doTransaction>

=item L<unbless|DBIx::DataModel::Doc::Reference/unbless>

=item L<_createPackage|DBIx::DataModel::Doc::Reference/_createPackage>

=item L<_defineMethod|DBIx::DataModel::Doc::Reference/_defineMethod>

=back

=head1 PRIVATE SUBCLASSES

This module has two internal subclasses.

=head2 _State

A private class for localizing state (using a DESTROY method).

=head2 _Exception

A private class for exceptions during transactions
(see  L<doTransaction|DBIx::DataModel::Doc::Reference/doTransaction>).



=head1 AUTHOR

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

=head1 COPYRIGHT & LICENSE

Copyright 2006, 2008 Laurent Dami.

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