69945c2704
A basic implementation of getRequestConfigurations and tests to go with it. Also added here is the test to verify that no items are added when duplicates are included.
431 lines
10 KiB
Perl
431 lines
10 KiB
Perl
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);
|
|
use Mail::RFC822::Address;
|
|
|
|
######################################################################
|
|
|
|
=begin new
|
|
|
|
Create new Supporters object.
|
|
|
|
Arguments:
|
|
|
|
=over
|
|
|
|
=item $dbh
|
|
|
|
Scalar references for the database handle, already opened and pointing to
|
|
the right database.
|
|
|
|
=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) = @_;
|
|
|
|
return bless({ dbh => $dbh, ledgerCmd => $ledgerCmd },
|
|
$package);
|
|
}
|
|
######################################################################
|
|
|
|
=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($this, $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};
|
|
}
|
|
my $sth = $this->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 = $this->dbh->last_insert_id("","","","");
|
|
$sth->finish();
|
|
|
|
$this->addEmailAddress($id, $sp->{email_address}, $sp->{email_address_type})
|
|
if defined $sp->{email_address};
|
|
|
|
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->dbh->begin_work();
|
|
|
|
my $addressTypeId = $self->addAddressType($emailAddressType);
|
|
|
|
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();
|
|
$self->dbh->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->dbh->begin_work();
|
|
|
|
my $sth = $self->dbh->prepare("INSERT INTO request_type(type) VALUES(?)");
|
|
|
|
$sth->execute($requestType);
|
|
$requestId = $self->dbh->last_insert_id("","","","");
|
|
$sth->finish();
|
|
$self->dbh->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->dbh->begin_work();
|
|
|
|
my $requestId = $self->addRequestType($requestType);
|
|
|
|
die "addRequestConfigurations: unable to create request configurations"
|
|
unless defined $requestType;
|
|
|
|
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->dbh->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->dbh->commit();
|
|
return { $requestId => \%descriptions };
|
|
}
|
|
######################################################################
|
|
|
|
=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 = $id", 'id');
|
|
return (defined $val and defined $val->{$id});
|
|
|
|
}
|
|
|
|
|
|
=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:
|