The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Business::PayPoint;
{
    $Business::PayPoint::VERSION = '0.01';
}

# ABSTRACT: PayPoint online payment

use strict;
use warnings;
use Carp 'croak';

#use Data::Dumper;
use XML::Writer;
use SOAP::Lite;    # +trace => 'all';
use URI::Escape qw/uri_escape/;

sub new {
    my $class = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    $args->{debug} ||= $ENV{PAYPOINT_DEBUG};
    SOAP::Trace->import('all') if $args->{debug};

    $SOAP::Constants::PREFIX_ENV = 'soap';
    $args->{soap} ||= SOAP::Lite->readable(1)
      ->proxy('https://www.secpay.com/java-bin/services/SECCardService?wsdl');

    bless $args, $class;
}

sub set_credentials {
    my ( $self, $mid, $vpn_pass, $remote_pass ) = @_;

    $self->{__mid}         = $mid;
    $self->{__vpn_pswd}    = $vpn_pass;
    $self->{__remote_pswd} = $remote_pass;
}

sub validateCardFull {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [
        'trans_id', 'ip',          'name',         'card_number',
        'amount',   'expiry_date', 'issue_number', 'start_date',
        'order',    'shipping',    'billing',      'options'
    ];
    $self->_request( 'validateCardFull', $ordered_keys, $args );
}

sub repeatCardFullAddr {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [
        'trans_id', 'amount', 'remote_pswd', 'new_trans_id',
        'exp_date', 'order',  'bill',        'ship',
        'options'
    ];
    $self->_request( 'repeatCardFullAddr', $ordered_keys, $args );
}

sub repeatCardFull {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [
        'trans_id', 'amount', 'remote_pswd', 'new_trans_id',
        'exp_date', 'order'
    ];
    $self->_request( 'repeatCardFull', $ordered_keys, $args );
}

sub refundCardFull {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [ 'trans_id', 'amount', 'remote_pswd', 'new_trans_id' ];
    $self->_request( 'refundCardFull', $ordered_keys, $args );
}

sub releaseCardFull {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [ 'trans_id', 'amount', 'remote_pswd', 'new_trans_id' ];
    $self->_request( 'releaseCardFull', $ordered_keys, $args );
}

sub getReport {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [
        'remote_pswd', 'report_type', 'cond_type', 'condition',
        'currency',    'predicate',   'html',      'showErrs'
    ];
    $self->_request( 'getReport', $ordered_keys, $args );
}

sub getTZReport {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [
        'remote_pswd', 'report_type', 'cond_type', 'condition',
        'currency',    'predicate',   'html',      'showErrs',
        'tz'
    ];
    $self->_request( 'getTZReport', $ordered_keys, $args );
}

sub threeDSecureEnrolmentRequest {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [
        'trans_id',                   'ip',
        'name',                       'card_number',
        'amount',                     'expiry_date',
        'issue_number',               'start_date',
        'order',                      'shipping',
        'billing',                    'options',
        'device_category',            'accept_headers',
        'user_agent',                 'mpi_merchant_name',
        'mpi_merchant_url',           'mpi_description',
        'purchaseRecurringFrequency', 'purchaseRecurringExpiry',
        'purchaseInstallments'
    ];
    $self->_request( 'threeDSecureEnrolmentRequest', $ordered_keys, $args );
}

sub threeDSecureAuthorisationRequest {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [ 'trans_id', 'md', 'paRes', 'options' ];
    $self->_request( 'threeDSecureAuthorisationRequest', $ordered_keys, $args );
}

sub performTransactionViaAlternatePaymentMethod {
    my $self = shift;
    my $args = @_ % 2 ? $_[0] : {@_};

    my $ordered_keys = [
        'paymentOrganisation', 'paymentMethod',
        'paymentType',         'paymentRequestType',
        'trans_id',            'amount',
        'currency',            'options'
    ];
    $self->_request( 'performTransactionViaAlternatePaymentMethod',
        $ordered_keys, $args );
}

sub _request {
    my ( $self, $method, $ordered_keys, $args ) = @_;

    unless ( $self->{__mid} ) {
        return { valid => 'false', message => 'credentials is not setup yet' };
    }

    my @requests = ( vpn_pswd => $self->{__vpn_pswd}, mid => $self->{__mid} );
    foreach my $k (@$ordered_keys) {
        if ( $k eq 'amount' ) {
            push @requests, ( amount => sprintf( '%.2f', $args->{amount} ) );
        }
        elsif ( $k eq 'remote_pswd' ) {
            push @requests, ( remote_pswd => $self->{__remote_pswd} || '' );
        }
        else {
            push @requests, ( $k => $args->{$k} || '' );
        }
    }

    my $xml;
    my $writer = new XML::Writer( OUTPUT => \$xml );
    $writer->startTag('XX');
    while (1) {
        last unless @requests;
        $writer->dataElement( shift @requests, shift @requests );
    }
    $writer->endTag('XX');

    $xml =~ s/\<\/?XX\>//g;    # remove placeholder

    my $som = $self->{soap}->call( $method, SOAP::Data->type( 'xml' => $xml ) );
    if ( $som->fault ) {
        return { valid => 'false', message => $som->faultstring };
    }
    my $result = $som->result;
    unless ($result) {
        return { valid => 'false', message => 'Unknown Error' };
    }

# ?valid=true&trans_id=tran0001&code=A&auth_code=9999&message=TEST AUTH&amount=50.0&test_status=true
# valid=false&trans_id=tran0001&code=P:C&message=Luhn Check Failed&correct=false

    $result =~ s/^\?//;
    my @p = split( '&', $result );
    my %result = map { split(/=/) } @p;
    return %result;
}

1;

__END__

=pod

=head1 NAME

Business::PayPoint - PayPoint online payment

=head1 VERSION

version 0.01

=head1 SYNOPSIS

    use Business::PayPoint;

    my $bp = Business::PayPoint->new();
    $bp->set_credentials($mid, $vpn_pass, $remote_pass);

=head1 DESCRIPTION

L<https://www.paypoint.net/assets/guides/Gateway_Freedom.pdf>

=head2 METHODS

=head3 set_credentials

    $bp->set_credentials($mid, $vpn_pass, $remote_pass);
    # $bp->set_credentials('secpay', 'secpay', 'secpay');

=head3 validateCardFull

    my %result = $bp->validateCardFull(
        'trans_id' => 'tran0001',
        'ip' => '127.0.0.1',
        'name' => 'Mr Cardholder',
        'card_number' => '4444333322221111',
        'amount' => '50.00',
        'expiry_date' => '0115',
        'billing' => "name=Fred+Bloggs,company=Online+Shop+Ltd,addr_1=Dotcom+House,addr_2=London+Road,city=Townville,state=Countyshire,post_code=AB1+C23,tel=01234+567+890,fax=09876+543+210,email=somebody%40secpay.com,url=http%3A%2F%2Fwww.somedomain.com",
        'options' => 'test_status=true,dups=false,card_type=Visa,cv2=123'
    );

=head3 repeatCardFullAddr

=head3 repeatCardFull

=head3 refundCardFull

=head3 releaseCardFull

=head3 getReport

    my %report = $bp->getReport(
        report_type => 'XML-Report',
        cond_type   => 'TransId',
        condition   => $trans_id,
        currency    => 'GBP',
        predicate   => '',
        html        => 'false',
        showErrs    => 'false'
    );

=head3 getTZReport

=head3 threeDSecureEnrolmentRequest

=head3 threeDSecureAuthorisationRequest

=head3 performTransactionViaAlternatePaymentMethod

=head1 AUTHOR

Fayland Lam <fayland@gmail.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by Fayland Lam.

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

=cut