package Supporters;

use 5.020002;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Supporters ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);

our $VERSION = '0.02';

use Scalar::Util qw(looks_like_number blessed);
use Mail::RFC822::Address;

my $NESTED_TRANSACTION_COUNTER = 0;

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

=begin new

Create new Supporters object.

Arguments:

=over

=item $dbh

   Scalar references for the database handle from the L<DBI>, already opened
   and pointing to the right database.  This class will take over and control
   the DBI object after C<new()> completes.

=item $ledgerCmd

   Scalar string that contains the main ledger command (without arguments) to
   run for looking up Supporter donation data.

=back

=cut

sub new ($$) {
  my $package = shift;
  my($dbh, $ledgerCmd) = @_;

  my $self = bless({ dbh => $dbh, ledgerCmd => $ledgerCmd },
                   $package);

  die "new: first argument must be a database handle"
    unless (defined $dbh and blessed($dbh) =~ /DBI/);

  # Turn off AutoCommit, and create our own handler that resets the
  # begin_work/commit reference counter.
  $dbh->{RaiseError} = 0;
  $dbh->{HandleError} = sub {
    $NESTED_TRANSACTION_COUNTER = 0;
    die $_[0];
  };
  return $self;
}
######################################################################

=begin dbh

Accessor method, returns the database handle currently used by this
Supporters object.

=cut

sub dbh ($) {
  return $_[0]->{dbh};
}
######################################################################

=begin ledgerCmd

Accessor method, returns the ledger command currently used by this Supporters
object.

=cut

sub ledgerCmd ($) {
  return $_[0]->{ledgerCmd};
}
######################################################################
sub addSupporter ($$) {
  my($self, $sp) = @_;

  die "ledger_entity_id required" unless defined $sp->{ledger_entity_id};

  $sp->{public_ack} = 0 if not defined $sp->{public_ack};

  if ($sp->{public_ack}) {
    die "display_name required if public_ack requested" unless defined $sp->{display_name};
  }
  $self->_beginWork;
  my $sth = $self->dbh->prepare(
                      "INSERT INTO supporter(ledger_entity_id, display_name, public_ack)" .
                                    " values(?,                ?,            ?)");

  $sth->execute($sp->{ledger_entity_id}, $sp->{display_name}, $sp->{public_ack});
  my $id = $self->dbh->last_insert_id("","","","");
  $sth->finish();

  $self->addEmailAddress($id, $sp->{email_address}, $sp->{email_address_type})
    if defined $sp->{email_address};

  $self->_commit;
  return $id;
}
######################################################################

=begin addAddressType

Adds an address type, or returns the existing one of that name if it already exists.

Arguments:

=over

=item $addressType

  Scalar string that contains the email address type.  die() is called if not defined.

=back

  Returns id of the address type.

=cut

sub addAddressType($$) {
  my($self, $type) = @_;

  die "addAddressType: type argument must be defined" if not defined $type;

  my $val = $self->dbh()->selectall_hashref("SELECT id, name FROM address_type WHERE name = '$type'", 'name');
  return $val->{$type}{id} if (defined $val and defined $val->{$type} and defined $val->{$type}{id});

  my $sth = $self->dbh->prepare("INSERT INTO address_type(name) VALUES(?)");

  $sth->execute($type);
  my $id = $self->dbh->last_insert_id("","","","");
  $sth->finish();

  return $id;
}
######################################################################

=begin addEmailAddress

Arguments:

=over

=item $id

   Valid supporter id number currently in the database.  die() will occur if
   the id number is not in the database already as a supporter id.

=item $emailAddress

   Scalar string that contains an email address.  die() will occur if the
   email address isn't properly formatted.

=item $emailAddressType

  Scalar string that contains the email address type.  This type will be
  created in the database if it does not already exist, so be careful.

=back

Returns the id value of the email_address entry.

=cut

sub addEmailAddress($$$$) {
  my($self, $id, $emailAddress, $emailAddressType) = @_;

  die "addEmailAddress: invalid id, $id" unless $self->_verifyId($id);

  die "addEmailAddress: invalid email address, $emailAddressType"
    unless defined $emailAddressType and Mail::RFC822::Address::valid($emailAddress);

  $self->_beginWork();

  my $addressTypeId;
  eval {
    $addressTypeId = $self->addAddressType($emailAddressType);
  };
  if ($@ or not defined $addressTypeId) {
    my $err = $@;
    $err = "addEmailAddress: unable to addAddressType"  if (not defined $err);
    $self->_rollback();
    die $@ if $@;
  }
  my $sth = $self->dbh->prepare("INSERT INTO email_address(email_address, type_id, date_encountered)" .
                                "VALUES(                    ?,            ?,       date('now'))");

  $sth->execute($emailAddress, $addressTypeId);
  my $addressId = $self->dbh->last_insert_id("","","","");
  $sth->finish();

  $sth = $self->dbh->prepare("INSERT INTO supporter_email_address_mapping" .
                                      "(supporter_id, email_address_id) " .
                                "VALUES(           ?, ?)");
  $sth->execute($id, $addressId);
  $sth->finish();

  $self->_commit();

  return $addressId;
}
######################################################################

=begin addPostalAddress

Arguments:

=over

=item $id

   Valid supporter id number currently in the database.  die() will occur if
   the id number is not in the database already as a supporter id.

=item $formattedPostalAddress

   Scalar string that contains a multi-line, fully formatted, postal address.

=item $addressType

  Scalar string that contains the address type.  This type will be created in
  the database if it does not already exist, so be careful.

=back

Returns the id value of the postal_address table entry.

=cut

sub addPostalAddress($$$$) {
  my($self, $id, $formattedPostalAddress, $addressType) = @_;

  die "addPostalAddress: invalid id, $id" unless $self->_verifyId($id);
  die "addPostalAddress: the formatted postal address must be defined"
    unless defined $formattedPostalAddress;

  $self->_beginWork();

  my $addressTypeId;
  eval {
    $addressTypeId = $self->addAddressType($addressType);
  };
  if ($@ or not defined $addressTypeId) {
    my $err = $@;
    $err = "addPostalAddress: unable to addAddressType"  if (not defined $err);
    $self->_rollback();
    die $@ if $@;
  }
  my $sth = $self->dbh->prepare("INSERT INTO postal_address(formatted_address, type_id, date_encountered)" .
                                "VALUES(                    ?,             ?,       date('now'))");

  $sth->execute($formattedPostalAddress, $addressTypeId);
  my $addressId = $self->dbh->last_insert_id("","","","");
  $sth->finish();

  $sth = $self->dbh->prepare("INSERT INTO supporter_postal_address_mapping" .
                                      "(supporter_id, postal_address_id) " .
                                "VALUES(           ?, ?)");
  $sth->execute($id, $addressId);
  $sth->finish();

  $self->_commit();

  return $addressId;
}
######################################################################

=begin getRequestType

Arguments:

=over

=item type

   A string describing the request.

=back

Returns the id value of the request_type entry.  undef is returned if there
is no request of that type.

=cut

sub getRequestType($$) {
  my($self, $type) = @_;

  return undef if not defined $type;
  my $val = $self->dbh()->selectall_hashref("SELECT id, type FROM request_type WHERE type = '$type'", 'type');
  return $val->{$type}{id} if (defined $val and defined $val->{$type} and defined $val->{$type}{id});
  return undef;
}
######################################################################

=begin addRequestType

Arguments:

=over

=item type

   A string describing the request.  die()'s if not defined.

=back

Returns the id value of the request_type entry.  If the type already exists,
it is simply returned.

=cut

sub addRequestType($$) {
  my($self, $requestType) = @_;

  die "addRequestType: undefined request type." unless defined $requestType;

  my $requestId = $self->getRequestType($requestType);
  return $requestId if (defined $requestId);

  $self->_beginWork();

  my $sth = $self->dbh->prepare("INSERT INTO request_type(type) VALUES(?)");

  $sth->execute($requestType);
  $requestId = $self->dbh->last_insert_id("","","","");
  $sth->finish();
  $self->_commit();
  return $requestId;
}
######################################################################

=begin getRequestConfigurations

Arguments:

=over

=item type

   A string describing the request_type.

=back

Returns undef if the request_type is not found in the database.  If the reuqest type is 
is no request of that type.

=cut

sub getRequestConfigurations($$) {
  my($self, $type) = @_;

  return undef if not defined $type;
  my $typeId = $self->getRequestType($type);
  return undef if not defined $typeId;

  my %descriptions;
  my $dbData =
    $self->dbh()->selectall_hashref("SELECT description, id FROM request_configuration " .
                                    "WHERE request_type_id = " . $self->dbh->quote($typeId, 'SQL_INTEGER'),
                                    'description');
  foreach my $description (keys %$dbData) {
    $descriptions{$description} = $dbData->{$description}{id};
  }
  return { $typeId => \%descriptions };
}
######################################################################

=begin addRequestConfigurations

Arguments:

=over

=item type

   A string describing the request type.  This will be created if it does not
   already exist, so be careful.

=item descriptionListRef

   A list reference to the list of configuration descriptions to associate
   with this requestId.  Duplicates aren't permitted in this list, and
   die()'s if duplicates exist.

=back

Returns a hash in the form of:

  $requestTypeId => { description => $requestConfigurationId }

=cut

sub addRequestConfigurations($$$) {
  my($self, $requestType, $descriptionListRef) = @_;

  die "addRequestConfigurations: undefined request type." unless defined $requestType;

  $self->_beginWork();

  my $requestId = $self->addRequestType($requestType);

  if (not defined $requestType) {
    $self->_rollback();
    die "addRequestConfigurations: unable to create request configurations";
  }

  my %descriptions;
  my $sth = $self->dbh->prepare("INSERT INTO request_configuration(request_type_id, description) " .
                                                           "VALUES(?,               ?)");
  foreach my $description (@{$descriptionListRef}) {
    if (defined $descriptions{$description}) {
      $self->_rollback();
      die "addRequestConfigurations: attempt to create duplicate request_configuration \"$description\" for requestType, \"$requestType\"";
    }
    $sth->execute($requestId, $description);
    $descriptions{$description} = $self->dbh->last_insert_id("","","","");
  }
  $sth->finish();
  $self->_commit();
  return { $requestId => \%descriptions };
}
######################################################################

=begin addRequest

Arguments:

=over

=item $parmas

A hash reference, the following keys are considered:

=over

=item supporterId

   Valid supporter_id number currently in the database.  die() will occur if
   the id number is not in the database already as a supporter id.

=item requestTypeId

   Numeric id of a request_type entry.  This must be a valid id in the
   request_type table, otherwise the method  L<die>()s.

   requestType is ignored if this parameter is set.

=item requestType

   If requestTypeId is not given, requestType will be used.  The type is
   added to the request_type table if it is not present, so be careful.


=item requestConfigurationId

   Numeric id of a request_configuration entry.  This must be a valid id in
   the request_configuration table, otherwise the method L<die>()s.

=item requestConfiguration

   If requestConfigurationId is not given, requestConfiguration will be used.
   This configuration will be added to the request_configuration table if it
   is not present, so be careful.

=back

=back

Returns the id value of the request entry.

=cut

sub addRequest($$) {
  my($self, $params) = @_;
  die "addRequest: undefined supporterId" unless defined $params->{supporterId};
  my $supporterId = $params->{supporterId};
  die "addRequest: supporterId, \"$supporterId\" not found in supporter database"
    unless $self->_verifyId($supporterId);
  $self->_beginWork;
  $self->_getOrCreateRequestType($params);
  $self->_commit;
}
######################################################################

=head1 Non-Public Methods

These methods are part of the internal implementation are not recommended for
use outside of this module.

=over

=item _verifyId()

Parameters:

=over

=item $self: current object.

=item $id: A scalar numeric argument that is the to lookup


=back

Returns: scalar boolean, which is true iff. the $id is valid and already in the supporter database.


=cut


sub _verifyId($$) {
  my($self, $id) = @_;

  die "_verifyId() called with a non-numeric id" unless defined $id and looks_like_number($id);

  my $val = $self->dbh()->selectall_hashref("SELECT id FROM supporter WHERE id = " .
                                            $self->dbh->quote($id, 'SQL_INTEGER'), 'id');
  return (defined $val and defined $val->{$id});

}

=item _verifyRequestTypeId()

Parameters:

=over

=item $self: current object.

=item $requestTypeId: A scalar numeric argument that is the request type id to  lookup


=back

Returns: scalar boolean, which is true iff. the $requestTypeId is valid and
already in the supporter database's request_type table.


=cut


sub _verifyRequestTypeId($$) {
  my($self, $requestTypeId) = @_;

  die "_verifyRequestTypeId() called with a non-numeric id" unless defined $requestTypeId and looks_like_number($requestTypeId);

  my $val = $self->dbh()->selectall_hashref("SELECT id FROM request_type WHERE id = " .
                                            $self->dbh->quote($requestTypeId, 'SQL_INTEGER'), 'id');
  return (defined $val and defined $val->{$requestTypeId});

}

=item _getOrCreateRequestType

Arguments:

=over

=item $params (hash reference)

This hash reference usually contains other paramaters, too, but this method
looks only at the keys C<requestType> and C<requestTypeId>.  If
C<requestTypeId> is set, it simply deletes the C<requestType> parameter and
verifies c<reuqestTypeId> is in the request_type table.

=cut

sub _getOrCreateRequestType($$) {
  my($self, $params) = @_;

  if (not defined $params->{requestTypeId}) {
    $params->{requestTypeId} = $self->addRequestType($params->{requestType});
  } else {
    my $id = $params->{requestTypeId};
    die "_getOrCreateRequestType(): called with a non-numeric requestTypeId"
      unless defined $id and looks_like_number($id);

    my $val = $self->dbh()->selectall_hashref("SELECT id FROM request_type WHERE id = " .
                                              $self->dbh->quote($id, 'SQL_INTEGER'), 'id');

    die "_getOrCreateRequestType(): given requestTypeId, $id, is invalid"
      unless (defined $val and defined $val->{$id});
  }
  delete $params->{requestType};
}

=item _getOrCreateRequestConfiguration

Arguments:

=over

=item $params (hash reference)

This hash reference usually contains other paramaters, too, but this method
looks only at the keys C<requestTypeId>, C<requestConfiguration> and
C<requestConfigurationId>.  If C<requestConfigurationId> is set, it simply
deletes the C<requestConfiguration> parameter and verifies c<reuqestTypeId>
is in the request_type table.

=cut

sub _getOrCreateRequestConfiguration($$) {
  my($self, $params) = @_;

  die "_getOrCreateRequestConfiguration: requestTypeId is required" unless defined $params->{requestTypeId};
  my $id = $params->{requestTypeId};
  die "_getOrCreateRequestConfiguration: requestTypeId must be a number" unless looks_like_number($id);
  die "_getOrCreateRequestConfiguration: requestTypeId is unknown" unless $self->_verifyRequestTypeId($id);

}

=item _beginWork()

Parameters:

=over

=item $self: current object.

=back

Returns: None.

This method is a reference counter to keep track of nested begin_work()/commit().


=cut

sub _beginWork($) {
  my($self) = @_;

  if ($NESTED_TRANSACTION_COUNTER < 0) {
    die "_beginWork: Mismatched begin_work/commit pair in API implementation";
    $NESTED_TRANSACTION_COUNTER = 0;
  }
  $self->dbh->begin_work() if ($NESTED_TRANSACTION_COUNTER++ == 0);
}

=item _commit()

Parameters:

=over

=item $self: current object.

=back

Returns: None.

This method is a reference counter to keep track of nested begin_work()
transactions to verify we don't nest $self->dbh->begin_work()

=cut

sub _commit($) {
  my($self) = @_;

  if ($NESTED_TRANSACTION_COUNTER < 0) {
    die "_commit: Mismatched begin_work/commit pair in API implementation";
    $NESTED_TRANSACTION_COUNTER = 0;
  }
  $self->dbh->commit() if (--$NESTED_TRANSACTION_COUNTER == 0);
}

=item _rollback()

Parameters:

=over

=item $self: current object.

=back

Returns: None.

This method resets the reference counter entirely and calls $dbh->rollback.

=cut

sub _rollback($) {
  my($self) = @_;

  $NESTED_TRANSACTION_COUNTER = 0;
  $self->dbh->rollback();
}

=back

=cut

1;
__END__

=head1 NAME

Supporters - Simple database of supporters of an organation.

=head1 SYNOPSIS

  use Supporters;

=head1 DESCRIPTION

Supporters is an extremely lightweight alternative to larger systems like
CiviCRM to manage a database of Supporters.  The module assumes a setup that
works with Ledger-CLI to find the actual amounts donated.

=head2 EXPORT

None by default.

=head1 AUTHOR

Bradley M. Kuhn, E<lt>bkuhn@ebb.org<gt>

=head1 COPYRIGHT AND LICENSE

See COPYRIGHT.md and LICENSE.md in the main distribution of this software.

License: AGPLv3-or-later

=cut

###############################################################################
#
# Local variables:
# compile-command: "perl -c Supporters.pm"
# End: