Net::PingFM - Interact with ping.fm from perl

 # Make pingfm object with our user and api keys:
 my $pfm = Net::PingFM->new( user_key => 'blah',
                            api_key => 'foo' );

 # check they like our keys (you don't need to do this!)
 $pfm->user_validate or die 'Couldn\'t log in to ping.fm!';

 # make a post using our default method:
 $pfm->post( 'Hello ping.fm!' );

 # make a microblog post:
 $pfm->post( 'Testing Net::PingFM' , { method => 'microblog' } );

 # make a real blog post, with title and everything!
 $pfm->post( 'Testing Net::PingFM. Hours of fun..',
             { method => 'blog', title => 'Testing Testing!'} );

 # get the list of services for the account:
 my @services = $pfm->services;

 my $pfm = Net::PingFM->new( api_key => 'blah', user_key => 'blah' );

 if ( $pfm->user_validate ){
    # we have a valid user key
 }
 else{
   # we don't!
 }

 $pfm->post( $body , \%optional_params );
 $pfm->post( 'Hacking on Net::PingFM', { post_method => 'status' });
 $pfm->post( 'Posting using my default method' );
 $pfm->post( 'Hacking on Net::PingFM, don\'t tell facebook', { service => 'twitter' });

 $pfm->trigger_post( $trigger, $body, $opts );
 $pfm->trigger_post( 'tw', 'Testing Ping.fm triggers!' );

 my @services = $pfm->services;

package Net::PingFM;

use strict; # moose will do this anyway, but...
use Moose;
use Moose::Util::TypeConstraints;

require 5.008;

use Readonly;
use LWP;
use Hash::Util qw{ lock_hash };
use XML::Twig;
use Carp;

# our internals:
use Net::PingFM::Service;
use Net::PingFM::Trigger;

# moose attribute defininitions
has api_key => (
    is => 'ro',
    isa => 'Str',
    required => 1,
);
has user_key => (
    is => 'rw',
    isa => 'Str',
    required => 1,
);
has debug_mode => (
    is => 'rw',
    isa => 'Bool',
    default => 0,
);

has dump_responses => (
    is => 'rw',
    isa => 'Bool',
    default => 0,
);

has _lwp => (
    is => 'ro',
    isa => 'LWP::UserAgent',
    lazy => 1,
    builder => '__lwp',
);

has last_error => (
    is => 'ro',
    isa => 'Str',
    writer => '_last_error',
);


# supply a class to use in place of LWP ( for testing )
has _use_lwp_replacement => (
    is => 'rw',
    default => 0,
);

# save our posts for test script inspection:
has '_debug_save_last_post' => (
    is => 'rw',
    default => 0,
);

has '_debug_last_post' => (
    is => 'rw',
);



our $VERSION = '0.6';

# constants #
Readonly my $PINGFM_URL => 'http://api.ping.fm/v1/';
Readonly my $UAGENT => 'PerlNetPingFM/' . $VERSION;

# request definitions #
Readonly my $USER_VALIDATE => 'user.validate';
Readonly my $USER_POST => 'user.post';
Readonly my $SERVICES => 'user.services';
Readonly my $TRIGGERS => 'user.triggers';
Readonly my $USER_TPOST => 'user.tpost';

# Make a hash of valid requests
Readonly my %REQUESTS => (
    map{ $_ => 1 } (
        $USER_VALIDATE,
        $USER_POST,
        $SERVICES,
        $TRIGGERS,
        $USER_TPOST,
    )
);
lock_hash( %REQUESTS );

sub user_validate{
    my $self = shift;
    my $rsp = $self->_request( $USER_VALIDATE );
    __rsp_ok( $rsp );
}

Readonly our %VALID_POST_PARAMS => (
    post_method => 1, title => 1, service => 1
);
Readonly our %VALID_POST_METHODS => (
    default => 1, blog => 1, microblog => 1, status => 1,
);

sub post {
    my $self = shift;
    my $body = shift or confess 'Need a post body!';
    my $opts = shift || {};

    my %ARGS;

    # fill in the main post body:
    $ARGS{body} = $body;

    # what kind of post?:
    $ARGS{post_method} = $opts->{post_method} || $opts->{method};
    $ARGS{post_method} ||= 'default';

    # validate post_method
    exists $VALID_POST_METHODS{ $ARGS{post_method} }
    	or confess 'Invalid post method: ' . $ARGS{post_method};


    if ( $opts->{service}
         && ( my $service = __parse_service_opt( $opts->{service} )))
    {
        $ARGS{ service } = $service;
    }

    __populate_common_post_args( $opts, \%ARGS );

    # do the request!
    my $response = $self->_request( $USER_POST, \%ARGS );
    return __rsp_ok( $response );
}

# work out what we were given
sub __parse_service_opt{
    my $so = shift;

    # maybe a service object?:
    if ( ref  $so ) {
        if ( $so->isa( 'Net::PingFM::Service' ) ) {
            return $so->id;
        }
        confess 'Can\'t use a reference for your "service" unless that reference is a Net::PingFM::Service. What you provided seems to be a :'. ref $so;
    }

    # probably a service id:
    return $so;
}

sub __populate_common_post_args{
    my( $opts, $post_args ) = @_;

    # copy in misc. options:
    for ( 'title', ) {
    	if ( exists $opts->{$_} ) {
            $post_args->{$_}  = $opts->{$_};
        }
    }

    return;
}

sub trigger_post{
    my $self = shift;
    my ( $trigger, $body, $opts ) = @_;

    # vet the required arguments:
    unless ( $trigger && $body ) {
        confess 'trigger_post usage: $pfm->trigger_post( $trigger, $body )';
    }

    $opts ||= {};

    # check the options hash:
    unless ( ref $opts eq 'HASH' ) {
        confess 'trigger_post options should be a hash reference';
    }

    # now start building our request args:
    my %ARGS;

    $ARGS{body} = $body;

    # populate the trigger option:
    $ARGS{trigger} = __parse_trigger_option( $trigger );

    __populate_common_post_args( $opts, \%ARGS );

    # do the request!
    my $response = $self->_request( $USER_TPOST, \%ARGS );
    return __rsp_ok( $response );
}

sub __parse_trigger_option{
    my( $trig ) = @_;

    if ( ref $trig ) {
        # does this look like a trigger object?
        if( $trig->isa( 'Net::PingFM::Trigger' ) ) {
            return $trig->id;
        }
        confess 'You provided a reference for your trigger, but it doesn\'t look like a Net::PingFM::Trigger object';
    }

    return $trig;
}

sub __service_xml_to_object;
sub services{
    my $self = shift;
    my $rsp = $self->_request( $SERVICES );

    # bail if we've failed:
    if ( ! __rsp_ok( $rsp )) {
        return;
    }

    # otherwise build our response
    return map{ __service_xml_to_object }
           $rsp->get_xpath( './services/service' );
}

sub __service_xml_to_object{
    my @c_args;

    # direct properties of the service object:
    foreach my $prop ( 'id', 'name' ) {
        if ( my $val = $_->att( $prop )) {
            push @c_args, $prop => $val;
        }
    }

    # deal with the strings:
    foreach my $prop ( 'trigger', 'url', 'icon' ) {
        if ( my $val = $_->first_child_text( $prop ) ) {
            push @c_args, $prop => $val;
        }
    }

    # now the list of methods:
    if ( my $methods = $_->first_child_text( 'methods' ) ) {
        push @c_args, 'methods' => [ grep{
            $VALID_POST_METHODS{ $_ } or warn "I don\'t understand post method $_, ignore";
            $VALID_POST_METHODS{ $_ };
        } split ',', $methods ];
    }

    # make object!
    return Net::PingFM::Service->new( @c_args  );
}

sub __trigger_xml_to_object;
sub triggers{
    my $self = shift;

    my $rsp = $self->_request( $TRIGGERS );

    # bail if we've failed:
    if ( ! __rsp_ok( $rsp )) {
        return;
    }

    return map{ __trigger_xml_to_object }
           $rsp->get_xpath( './triggers/trigger' );
}

sub __trigger_xml_to_object{
    my @c_args;

    # attributes from the trigger that we're interested in:
    foreach my $prop ( 'id', 'method' ) {
        if ( my $val = $_->att( $prop )) {
            push @c_args, $prop => $val;
        }
    }

    return Net::PingFM::Trigger->new( @c_args );
}

###INTERNALS###

sub _request{
    my $self = shift;

    # collect and validate args #
    my ( $request ) = shift or confess 'Need $request!';
    my $extras = shift || {};

    exists $REQUESTS{$request} or confess qq+Unknown request $request+;

    my $raw_rsp = $self->_web_request( $request, $extras );

    # parse response:
    my $twig = XML::Twig->new();
    eval{
        $twig->parse( $raw_rsp );
    };
    if ( $@ ) {
        die join '', "Error parsing response for '$request': $@";
    }

    # dump response? 
    if ( $self->dump_responses ) {
        print $twig->sprint, "\n";
    }

    my $rsp = $twig->root;

    # maybe have a fit if our XML doesn't look right
    if ( ! __valid_rsp( $rsp ) ) {
        die 'Invalid XML response!';
    }

    if ( $rsp->first_child_text( 'method' ) ne $request ) {
        warn 'Response method doesn\'t match request method. Something has probably gone wrong!';
    }

    # possibly stash an error message
    if ( ! __rsp_ok( $rsp ) ) {
        if ( my $msg = $rsp->first_child_text( 'message' ) ) {
            $self->_last_error( $msg );
        }
        else {
            $self->_last_error( 'None set' );
        }
    }

    return $rsp;
}

# handle the nuts'n'bolts of talking over the web
sub _web_request{
    my $self = shift;
    my ( $request, $extra_params ) = @_
    	or confess 'Need $request and $extra_params';

    my $lwp;

    # get our lwp user agent
    unless ( $lwp = $self->_use_lwp_replacement ) {
        $lwp = $self->_lwp();
    }

    # form always takes user & api keys:
    my %form = (
        user_app_key => $self->user_key,
        api_key => $self->api_key,
        debug => $self->debug_mode,
        %$extra_params,
    );

    # are we recording things for tests?
    if ( $self->_debug_save_last_post ) {
        $self->_debug_last_post( \%form );
    }

    # make a url for this request:
    my $url =  __request_url( $request );

    # POST!
    my $response = $lwp->post( $url, \%form );

    # handle failure:
    if ( ! $response || ! $response->is_success ) {
        die join '', "Request '$request' failed to $url",
                     ( $response ? ( ': ', $response->status_line )
                                 : '.' );
    }

    return $response->content;
}

# make a lwp request object
sub __lwp{
    my $ua = LWP::UserAgent->new();
    $ua->agent( $UAGENT );
    return $ua;
}

# build the url for a parictular request
sub __request_url{
    my $request = shift;
    return join '' => $PINGFM_URL, $request;
}

# check response OK/Fail status
sub __rsp_ok{
    my $rsp = shift;
    $rsp->att( 'status' ) eq 'OK';
}

# check rsp looks like a rsp
sub __valid_rsp{
    my $rsp = shift;
    return $rsp->tag eq 'rsp' && $rsp->att('status');
}

no Moose;

;1;
__END__