File Coverage

blib/lib/Net/APNS/Persistent.pm

Criterion	Covered	Total	%
statement	18	60	30.0
branch	0	12	0.0
condition	0	5	0.0
subroutine	6	13	46.1
pod	3	3	100.0
total	27	93	29.0

package Net::APNS::Persistent;

# perl 5.8 required for utf8 safe substr
use 5.008;
use strict;
use warnings;

our $VERSION = '0.02';

use base 'Net::APNS::Persistent::Base';

use Encode qw(decode encode encode_utf8);

# NB: Using JSON::XS as not all JSON modules allowed
# by JSON::Any do unicode correctly
use JSON::XS;

__PACKAGE__->mk_accessors(qw(
                                devicetoken
                                _queue
                                max_payload_size
                                command
                                _json
                           ));

my %defaults = (
    host_production  => 'gateway.push.apple.com',
    host_sandbox     => 'gateway.sandbox.push.apple.com',
    max_payload_size => 256,
    port             => 2195,
    command          => 0
   );

=head1 NAME

Net::APNS::Persistent - Send Apple APNS notifications over a persistent connection

=head1 SYNOPSIS

  use Net::APNS::Persistent;

  my $devicetoken_hex = '04ef...a878416';

  my $apns = Net::APNS::Persistent->new({
    sandbox => 1,
    cert    => 'cert.pem',
    key     => 'key.pem',
    passwd  => 'key password',
  });

  $apns->queue_notification(
    $devicetoken_hex,
    {
      aps => {
          alert => 'sweet!',
          sound => 'default',
          badge => 1,
      },
    });

  $apns->send_queue;

  $apns->disconnect;

You can queue more than one notification in one transmission
by calling L multiple times. If you want to
pass in utf8 text in the alert (either as a string or alert-Ebody),
you need to be careful with the encoding. See the test files for an
example of reading utf8 from a text file. You should also be able
to pass utf8 through from eg. a database in a similar way.

You can also use the connection many times (ie. queue then send, queue then send,
ad nauseum). The call to disconnect is not strictly necessary since the object
will disconnect as soon as it falls out of scope.

You can place your own custom data outside the C hash. L
Apple Push Notification Service Programming Guide for more info.

All methods are fatal on error. Eg. if the ssl connection returns an error,
the code will die. You can either then just restart your script or you can use
C to catch the exception.

=head1 DESCRIPTION

Class to create a persistent connection to Apple's APNS servers

=head1 METHODS

=head2 new

Args:

=over

=item sandbox

set to true if you want to use the sandbox host. defaults to 0. ignored if you set the host manually

=item cert

path to your certificate

=item cert_type

defaults to PEM - see L.

=item key

path you your private key

=item key_type

defaults to PEM - see L.

=item passwd

password for your private key, if required.

=item host

defaults to gateway.push.apple.com or gateway.sandbox.push.apple.com depending
on the setting of sandbox. can be set manually.

=item port

defaults to 2195

=item command

defaults to 0

=back

NB: all these args are available as accessors, but you need to set them before the connection
is first used.

=cut

sub new {
    my ($class, $init_vals) = @_;

    $init_vals ||= {};

    my $self = $class->SUPER::new({

        %defaults,

        %{$init_vals}
       });

    $self->_queue([]);

    $self->_json(JSON::XS->new());
    $self->_json->utf8(1);

    return $self;
}

sub _apply_to_alert_body {
    my ($payload, $func) = @_;

    return
      if ! exists $payload->{aps}{alert};

    # can be in alert->body, or a plain string in alert
    if (ref $payload->{aps}{alert} eq 'HASH') {
        $payload->{aps}{alert}{body} = $func->($payload->{aps}{alert}{body});
    } else {
        $payload->{aps}{alert} = $func->($payload->{aps}{alert});
    }
}

sub _pack_payload_for_devicetoken {
    my ($self, $devicetoken, $payload) = @_;

    if (ref($payload) ne 'HASH' || ref($payload->{aps}) ne 'HASH') {
        die "Invalid payload: " . Dumper($payload);
    }

    # force badge to be integer
    $payload->{aps}{badge} += 0
      if exists $payload->{aps}{badge};

    # convert message to unicode, after ensuring it was utf8 in the first place
    _apply_to_alert_body($payload, sub {
                             my $str = shift; # decode won't work on string literals
                             encode('unicode', decode('utf8', $str, Encode::FB_CROAK));
                         });

    my $json = $self->_json->encode($payload);

    # enforce max_payload_size
    my $max_payload_size = $self->max_payload_size;
    if ( bytes::length($json) > $max_payload_size ) {

        # not sure why this is necessary. Must be something
        # about the difference in density b/n utf8 and unicode?
        # This isn't very efficient,
        # but users shouldn't be passing in huge strings, surely...

        while (bytes::length($json) > $max_payload_size) {
            _apply_to_alert_body($payload, sub {
                                     substr($_[0], 0, -1);
                                 });

            $json = JSON::XS::encode_json($payload);
        }
    }

    return pack(
        'c n/a* n/a*',
        $self->command,
        pack( 'H*', $devicetoken ),
        $json
       );
}

=head2 queue_notification

takes two arguments - a device token (as a string representation of hex), and
a hashref with the payload. eg:

  my $devicetoken_hex = '04ef...a878416';

  $apns->queue_notification(
    $devicetoken_hex,
    {
      aps => {
          alert => 'sweet!',
          sound => 'default',
          badge => 1,
      },
    });

  $apns->queue_notification(
    $devicetoken_hex,
    {
      aps => {
          alert => {
              body => 'foo',
              'action-loc-key' => undef,
          },
          sound => 'default',
          badge => 1,
      },
      foo => 'bar',
    });

The second example shows the complex alert format and also custom application
data outside the aps hash.

This method will ensure that the payload is at most 256 bytes by trimming the
alert body. The trimming function is utf8-safe, but not very efficient (so
don't ask it to trim War and Peace).

=cut

sub queue_notification {
    my ($self, $devicetoken, $payload) = @_;

    push @{$self->_queue}, [$devicetoken, $payload];

    return 1;
}

=head2 send_queue

This will actually send the data to the ssl connection.

=cut

sub send_queue {
    my $self = shift;

    my $data = '';

    for my $queue_entry (@{$self->_queue}) {
        my ($devicetoken, $payload) = @{$queue_entry};

        $data .= $self->_pack_payload_for_devicetoken($devicetoken, $payload);
    }

    $self->_send($data)
      if $data;

    $self->_queue([]);

    return 1;
}

=head2 disconnect

Disconnect the ssl connection and socket, and free the ssl structures. This usually
isn't necessary as this will happen implicitly when the object is destroyed.

=head1 SEE ALSO

=over 4

=item Presentation on this module by Author

L

=item Apple Push Notification Service Programming Guide

L

=item L

=item GIT Source Repository for this module

L

=back

=head1 AUTHOR

Mark Aufflick, [e-mail], L

=head1 CREDITS

Some inspiration came from haoyayoi's L.

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 by Mark Aufflick

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.9 or,
at your option, any later version of Perl 5 you may have available.

=cut

1;