Net::iContact - iContact API

    use Net::iContact;

    my $api = Net::iContact->new('user', 'pass', 'key', 'secret');
    $api->login();
    for my $list (keys %{$api->lists}) {
        print "ID: " . $list->{'id'} . "\n";
        print "Name: " . $list->{'name'} . "\n";
    }
    ...

    USERNAME: your iContact username
    PASSWORD: your iContact password
    APIKEY: the API key given to your application
    SECRET: the shared secret given to your application
    DEBUG: turns on debugging output.  Optional, default is zero.

    FIELDS: optional hash of search criteria

    ID: numeric contact ID

    ID: numeric contact ID

    ID: numeric contact ID

    ID: numeric campaign ID

    ID: numeric list ID

    ID: numeric message ID

    SUBJECT: subject of the message
    CAMPAIGN: campaign to use
    TEXT_BODY: text part of the message
    HTML_BODY: html part of the message

    CONTACT: hashref of contact info
    ID: optional contact ID

    CONTACTID: contact ID to update
    LISTID: list ID
    STATUS: CONTACTID's subscription to LISTID (eg 'subscribed',
        'unsubscribed', 'deleted'...)

    METHOD: scalar name of the method to be called
    ARGS: a hashref of arguments to above method

    METHOD: scalar name of the method to be called
    ARGS: a hashref of arguments to above method

    METHOD: scalar name of the method to be called
    ARGS: a hashref of arguments to above method

    METHOD: scalar name of the method to be called
    ARGS: hashref of arguments to above method
    XML: XML to PUT

    perldoc Net::iContact

package Net::iContact;
# vim: set expandtab tabstop=4 shiftwidth=4 autoindent smartindent:
use warnings;
use strict;

use Carp qw/carp croak/;
use Digest::MD5 qw/md5_hex/;
use HTTP::Request::Common qw/PUT GET/;
use LWP::UserAgent;
use XML::Bare;
use Data::Dumper;

### Not importing; don't want XML::Generator's AUTOLOAD
require XML::Generator;

use constant API_BASE => 'http://api.icontact.com/icp/core/api/v1.0/';

our $VERSION = '0.02';
our $AUTOLOAD;

our %ok_field;
for (qw|error username password api_key secret token seq debug ua|) { $ok_field{$_}++ };

### catchall accessor
sub AUTOLOAD {
    my $name = $AUTOLOAD;
    $name =~ s/.*://;
    return if $name =~ /^[A-Z]+$/;

    carp "Invalid attribute or method" and return unless $ok_field{$name};
    return $_[0]->{$name};
}
sub new {
    $#_ >= 4 or croak "Invalid number of arguments";

    my ($class_name, $user, $pass, $api_key, $secret) = @_;
    my $debug = $_[5] if ($#_ == 5);

    $pass = md5_hex($pass);
    my ($self) = {  'username' => $user,
                    'password' => $pass,
                    'api_key'  => $api_key,
                    'secret'   => $secret,
                    ## Token and sequence number are given to us by
                    ## the app after login
                    'token'    => '',
                    'seq'      => 0,
                    ## debug mode
                    'debug'    => $debug,
                    ## keep one of these around
                    'ua'       => LWP::UserAgent->new,
    };
    bless($self, $class_name);
    return $self;
}

sub login {
    my $self = shift;
    my $call = 'auth/login/' . $self->username . '/' . $self->password;
    my $root = $self->get($call, {'api_key' => $self->api_key });
    return unless $root;

    $self->{'token'} = $root->{response}->{auth}->{token}->{value};
    $self->{'seq'}   = $root->{response}->{auth}->{seq}->{value};
    return 1;
}

### Most of this code is shared with all of the GET calls.
### _getcall takes a string (the RHS of `my $call =') and a coderef
### (callback for processing the tree XML::Bare returns).
###
### It returns a subroutine that preforms the requested call.
sub _getcall {
    my ($cstr, $munge) = @_;

    my $ret = q|sub {
                my $self = shift;my $call = CALL;my %args = @_;
                my $root = $self->get($call, { $self->_stdargs, %args });
                unless ($root) {
                        warn 'Got error: ' . $self->error->{code} . ': ' . $self->error->{message} . "\n";
                        return;
                }
                return $munge->($root);
        }|;
    $ret =~ s/CALL/$cstr/;
    return eval $ret;
}

### Build the GET functions with _getcall.
*contacts = _getcall q("contacts"), 
                    sub { _to_arrayref(shift->{response}->{contact}) };
*contact  = _getcall q("contact/" . shift),
                    sub { _to_hashref (shift->{response}->{contact}) };
*subscriptions = _getcall q{"contact/" . shift() . "/subscriptions"},
                    sub { _to_subs(shift->{response}->{contact}->{subscription})};
*campaigns = _getcall q("campaigns"),
                    sub { _to_arrayref(shift->{response}->{campaigns}->{campaign})};
*campaign  = _getcall q("campaign/" . shift),
                    sub { _to_hashref (shift->{response}->{campaign})};
*lists = _getcall q("lists"),
                    sub { _to_arrayref(shift->{response}->{lists}->{list})};
*list  = _getcall q("list/" . shift),
                    sub { _to_hashref (shift->{response}->{list})};
*custom_fields = _getcall q{"contact/" . shift() . "/custom_fields"},
                    sub { _to_cfields (shift->{response}->{contact}->{custom_fields}->{custom_field})};
*stats = _getcall q{"message/" . shift() . "/stats"},
                    sub { _to_stats   (shift->{response}->{message}->{stats})};


sub putmessage {
    my ($self, $subject, $campaign, $text, $html) = @_;
    my $call = 'message';

    my $X = new XML::Generator ':pretty';
    my $xml = $X->xml($X->message(
                  $X->subject($X->xmlcdata($subject)),
                  $X->campaign($campaign),
                  $X->text_body($X->xmlcdata($text)),
                  $X->html_body($X->xmlcdata($html)),
              ))->stringify;

    my $root = $self->put($call, { $self->_stdargs }, $xml);
    return unless $root;

    return $root->{response}->{result}->{message}->{id}->{value};
}

sub putcontact {
    my ($self, $contact, $id) = @_;
    my $call = 'contact' . ($id ? "/$id" : '');

    my $X = new XML::Generator ':pretty';
    my $xml = $X->xml($X->contact(($id ? { 'id' => $id } : { }),
                                   map {$X->$_($contact->{$_})} keys %$contact,
                     ))->stringify;

    my $root = $self->put($call, { $self->_stdargs }, $xml);
    return unless $root;

    return $root->{response}->{result}->{contact}->{id}->{value};
}

sub putsubscription {
    my ($self, $contactid, $listid, $status) = @_;
    my $call = "contact/$contactid/subscription/$listid";

    my $X = new XML::Generator ':pretty';
    my $xml = $X->xml($X->subscription({'id' => $listid},
                                       $X->status($status),
                     ))->stringify;

    my $root = $self->put($call, { $self->_stdargs }, $xml);
    ## False on failure, 1 on success.
    return unless $root;
    return 1;
}

sub gen_sig {
    my ($self,$call,$args) = @_;
    my $sig = $self->secret;
    $sig .= $call;
    for my $key (sort (keys(%$args))) {
        $sig .= $key . $args->{$key};
    }
    return md5_hex($sig);
}

sub gen_url {
    my ($self,$call,$args) = @_;
    my $url = API_BASE . $call;
    my $sig = $self->gen_sig($call, $args);

    $url .= "/?api_sig=$sig";

    while (my ($key,$val) = each(%$args)) {
        $url .= "&$key=$val";
    }
    return $url;
}

sub get {
    my ($self,$call,$args) = @_;

    ## Generate the URL and make the call
    my $url = $self->gen_url($call, $args);
    warn "GET'ing: $url\n\n" if $self->debug;
    my $response = $self->ua->request(GET $url);
    croak "Could not make API call: GET/$call" unless $response->is_success;

    $self->{'seq'}++;
    my $xml = $response->content;
    warn "\n\nGot:\n$xml\n\n" if $self->debug;

    ## Parse it, check for errors
    my $root = _parse($xml);
    unless (_success($root)) {
        $self->{'error'} = _get_error($root);
        return;
    }
    return $root;
}

sub put { 
    my ($self,$call,$args,$xml) = @_;
    $args->{'api_put'} = $xml;

    ## Generate the URL and make the call
    my $url = $self->gen_url($call, $args);
    warn "PUT'ing: $url\ncontent:\n$xml\n\n" if $self->debug;
    my $response = $self->ua->request(PUT $url, Content => $xml);
    croak "Could not make API call: PUT/$call" unless $response->is_success;

    $self->{'seq'}++;
    $xml = $response->content;
    warn "\n\nGot:\n$xml\n" if $self->debug;

    ## Parse it, check for errors
    my $root = _parse($xml);
    unless (_success($root)) {
        $self->{'error'} = _get_error($root);
        return;
    }

    return $root;
}

### The following subs are for internal use only.

# _get_error( ROOT )
#
# Extracts the error code and message from the given XML.
# 
#     ROOT: an XML::Bare root node
#
# Returns a hashref.  (See C<error>).


sub _get_error {
    my $root = shift;
    return  {   'code'    => $root->{response}->{error_code}->{value},
                'message' => $root->{response}->{error_message}->{value}, };
}

# _parse( TEXT )
#
# Parses the XML in the first argument.
#
#     TEXT: scalar string containing XML
#
# Returns an XML::Bare root node.

sub _parse {
    my $xml = new XML::Bare( text => shift );
    return $xml->parse;
}

# _success( ROOT )
#
# Check whether or not a call was successful based on the XML returned.
#
#     ROOT: an XML::Bare root node
#
# Returns true on success and false on failure

sub _success {
    my $root = shift;
    my $status = $root->{response}->{status}->{value};
    return unless $status eq 'success'; # false return on failure,
    return 1;                           # otherwise 1
}

# _to_arrayref( NODE )
#
# Convert an XML::Bare hash tree to an array.
# Returns an arrayref.

sub _to_arrayref {
    my @ret;
    my $ar = shift;
    if (ref($ar) eq 'ARRAY') {
        for my $item (@$ar) {
            push @ret, $item->{id}->{value};
        }
    } else {
        if (defined($ar->{id}->{value})) {
            push @ret, $ar->{id}->{value};
        }
    }
    return \@ret;
}

# _to_hashref( NODE )
#
# Convert an XML::Bare hash tree to a hash.
# Returns a hashref.

sub _to_hashref {
    ## Convert the tree returned by XML::Bare into a "normal" hashref,
    ##  so keys can be accessed without excessive referenceage..
    my %ret;
    my $ar = shift;
    while (my ($key,$val) = each(%$ar)) {
        next if $key =~ /(value|pos)/;
        $ret{$key} = $val->{value};
    }
    return \%ret;
}

# _to_subs( NODE )
#
# Convert an XML::Bare hash tree to a hash.  Special case for
# GET call `subscriptions'

sub _to_subs {
    my $subscription = shift;
    my %ret;

    if (ref($subscription) eq 'ARRAY') {
        for my $item (@$subscription) {
            $ret{$item->{id}->{value}} = $item->{status}->{value};
        }
    } else {
        if (defined($subscription->{id}->{value})) {
            $ret{$subscription->{id}->{value}} = $subscription->{status}->{value};
        }
    }
    return \%ret;
}

# _to_cfields( NODE )
#
# Convert an XML::Bare hash tree to a hash.  Special case for
# GET call `custom_fields'

sub _to_cfields {
    my %ret;
    my $fields = shift;
    if (ref($fields) eq 'ARRAY') {
        for my $item (@$fields) {
            $ret{$item->{name}->{value}} = {
                'formal_name' => $item->{formal_name}->{value},
                'value' => $item->{value}->{value},
                'type' => $item->{type}->{value},
            }
        }
    } else {
        if (defined($fields->{name}->{value})) {
            $ret{$fields->{name}->{value}} = {
                'formal_name' => $fields->{formal_name}->{value},
                'value' => $fields->{value}->{value},
                'type' => $fields->{type}->{value},
            }
        }
    }

    return \%ret;
}

# _to_stats( NODE )
#
# Convert an XML::Bare hash tree to a hash.  Special case for
# GET call `stats'

sub _to_stats {
    my $stats = shift;
    my %ret;
    for (qw/bounces released unsubscribes forwards complaints opens clicks/) {
        $ret{$_} = {
          'count'   => $stats->{$_}->{count}->{value},
          'percent' => $stats->{$_}->{percent}->{value},
        }
    }
    $ret{opens}->{unique} = $stats->{opens}->{unique}->{value};
    $ret{clicks}->{unique} = $stats->{clicks}->{unique}->{value};

    return \%ret;
}



# _stdargs( SELF )
#
# Return a hash containing the standard arguments to api calls.
# Requires access to $self.

sub _stdargs {
    my $self = shift;
    return ( 'api_key' => $self->api_key,
             'api_seq' => $self->seq,
             'api_tok' => $self->token, );
}

1; # End of Net::iContact