File Coverage

blib/lib/SMS/Send/DistributeSMS.pm

Criterion	Covered	Total	%
statement	74	182	40.6
branch	14	54	25.9
condition	2	11	18.1
subroutine	10	18	55.5
pod	2	4	50.0
total	102	269	37.9

package SMS::Send::DistributeSMS;

use warnings;
use strict;

=head1 NAME

SMS::Send::DistributeSMS - SMS::Send DistributeSMS Driver

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

  # Create a sender
  my $send = SMS::Send->new('DistributeSMS'
    _account_no  => '1234',
    _login       => 'login',
    _password    => 'password',
    _proxy       => 'http://host:port/', # optional.
    _verbose     => 1, # optional. for debugging purposes only.
  );

  # Send a message
  $send->send_sms(
  	text  => 'Hi there',
  	to    => '[phone]',
  	_from => 'TEST',
  );

  # Get send status (NOTE: specific to this driver)
  my @status = $sms->status_sms();
  print "status: $status[0] (state: $status[1])\n";

=head1 DESCRIPTION

SMS::Send::DistributeSMS is a driver for L for
the SMS gateway at www.distributesms.com.au.

It currently supports the ability to send an SMS to any country
in the world.  This is possible by including a translation map
from international dialing codes to DistributeSMS specific IDs,
requiring no intervention or assistance on the programmer's behalf.

As an added bonus, retrieving the send status is possible,
although specific to this driver only.

Bugs, fixes, flames, rants, patches and messages are welcome.

=head1 AUTHOR

David Sobon, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web
interface at
L.
I will be notified, and then you'll automatically be notified of
progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc SMS::Send::DistributeSMS


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2008 David Sobon, all rights reserved.

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


=cut

use URI::Escape;
use base 'SMS::Send::Driver';

require LWP::UserAgent;
require HTTP::Cookies;

#####################################################################
# Constructor

sub new {
	my $class = shift;
	my %args  = @_;

	#
    # Create the object
	#
	my $self = bless {
		ua            => undef,
		cj            => undef,
		verbose       => $args{'_verbose'},
		proxy         => $args{'_proxy'},
		messages      => [],
		private       => \%args,

		account_no    => $args{'_account_no'},
		login         => $args{'_login'},
		password      => $args{'_password'},

		# private variables.
		_MessageID    => 0,
		_loggedin     => 0,
	}, $class;

	return $self;
}

#####################################################################
# PUBLIC METHODS

#####
#  Usage: $class->send_sms(%args);
# Return: 1 on success, croak-before-return on failure.
#
sub send_sms {
    my $self = shift;
	my %hash = @_;

	# error: to
	if (!$hash{'to'}) {
		Carp::croak("[send_sms] to number not specified");
	}

	# login.
	$self->_login();
	$self->_getCredits();

	# post.
	my $url  = "http://www.distributesms.com.au/cgi-bin/sm.pl";
	my %dial = $self->_getDialInfoByNumber( $hash{'to'} );
	$hash{'to'} =~ s#^\+$dial{'DialCode'}##;

	my %post = (
		PhoneNumber     => $hash{'to'},
		ReplyTo         => $hash{'_from'} || '',
		Message         => uri_escape( $hash{'text'} ),
		DialCodeSeq     => $dial{'DialCodeSeq'},
		PhoneGroup      => "",
		Send            => 'send',
	);

	# error: dialcodeseq could not be determined.
	if (!$post{'DialCodeSeq'}) {
		Carp::croak("send_sms: could not determine DialCodeSeq from $hash{'to'}");
	}

	# send.
	$self->print('verbose', "[send_sms] sending message:");
	$self->print('verbose', "[send_sms]   to: $post{'PhoneNumber'}");
	$self->print('verbose', "[send_sms]   from: $post{'ReplyTo'}") if ($post{'ReplyTo'});
	$self->print('verbose', "[send_sms]   dialcode: $post{'DialCodeSeq'}");
	$self->print('verbose', "[send_sms]   message: $post{'Message'}");
	my $res = $self->_getURL($url, \%post);

	# error: check if send failed.
    if ($res->content !~ /Processed/) {
		my $data = $res->content();
		$data =~ s#<\/?(body|html)>##gi;

		Carp::croak("send_sms: could not send sms - $data");
    }

	# if successful, get the current message ID, so we can
	# determine the message status.
	$self->_setLastMessageID();

	return 1;
}

#####
#  Usage: $class->status_sms([$mid]);
#   Args: $mid - if not set, $class->{_MessageID} is used.
# Return: failure: array: current status string, state (YES/NO).
# Return: success: array: (undef, undef)
#   Note: this method is specific to DistributeSMS as there
#         is no standardized way to obtain whether an sms
#         was successfully delivered or not.
#         to be called $MODULE->_OBJECT->status_sms($mid);
#
sub status_sms {
	my $class   = shift;
	my ($mid)   = @_ || $class->{'_MessageID'};

	# error: no mid specified.
	if (!$mid) {
		Carp::croak("error: status_sms: no messageid specified");
	}

	# if not logged in yet, log in!
	if (!$class->{'_loggedin'}) {
		$class->_login();
	}

	# todo: check if $mid is valid?
	my $hashref = $class->_getMessageIDStatus($mid);
	my %status  = %{ $hashref };

	# valid status strings.
	my @_status = (
		'Scheduled',
		'Sent to Gateway',
		'Delivered to Network',
		'Delivered to Phone'
	);

	# return last status.
	for (my $i=0; $i
		my $status = $_status[$#_status - $i];
		my $state  = $status{ $status };
		next unless ($state);

		return ($status, $state);
	}

	return (undef, undef);
}

#####
#  Usage: $class->print($level, $string);
#   Args:
#	$level  - 'verbose'
#	$string - string to print.
# Return: undef or return code from printf()
#
sub print {
	my $class = shift;
	my ($level, $string) = @_;

	# error: level is NULL.
	if (!$level) {
		Carp::croak("DistributeSMS::print: no level specified.");
	}

	# error: invalid level.
	if ($level !~ /^(verbose)$/) {
		Carp::croak("DistributeSMS::print: invalid level: $level");
	}

	# error: string is NULL.
	if (!$string) {
		Carp::croak("DistributeSMS::print: string is NULL.");
	}

	# do not print unless this level has been set via the new constructor
	return unless ($class->{ $level });

	printf "::: %s\n", $string;
}

#####################################################################
# PRIVATE METHODS
#####################################################################

#####
#  Usage: $class->_getMessageIDStatus( $MessageID );
# Return: %hash reference of status and states.
#
sub _getMessageIDStatus {
	my $class = shift;
	my ($mid) = @_;
	my $url   = "http://www.distributesms.com.au/cgi-bin/md.pl?mls=$mid";
	my $res   = $class->_getURL($url);
	my $data  = $res->content();
	my %status;

	$class->print('verbose', "[getMessageIDStatus] length(data) == ".length($data) );

	# we could use HTML::TreeBuilder... but that is just overkill!
	while ($data =~ s#(
		my $row = $1;
		my @col;
###		$class->print('verbose', "[getMessageIDStatus] line: $row");

		while ($row =~ s#(.*?)(
			$class->print('verbose', "[getMessageIDStatus] col: $1");
			push(@col, $1);
		}

		my $status = $col[0];
		my $state  = $col[2];

		# status:
		#   Scheduled
		#   Sent to Gateway
		#   Delivered to Network
		#   Delivered to Phone

		$class->print('verbose', "[getMessageIDStatus] status{ $status } = $state;");

		$status{ $status } = $state;
	}

	return \%status;
}

#####
#   Desc: get the last/current message ID and store it privately.
#  Usage: $class->_getLastMessageID();
# Return: $MessageID
#
sub _getLastMessageID {
	my $class = shift;
	return $class->{'_MessageID'};
}

#####
#   Desc: set the last/current message ID and store it privately.
#  Usage: $class->_setLastMessageID();
# Return: 0 on failure, 1 on success.
#   Note: MessageID is determined within the function itself, not provided
#         as an input. We are misleading!
#
sub _setLastMessageID {
	my $class = shift;
	my $url   = "http://www.distributesms.com.au/cgi-bin/ml.pl";
	my $res   = $class->_getURL($url);

	if ($res->content() !~ /DeliveryStatus\('\/cgi-bin\/md.pl\?mls=(\d+)'/) {
		# todo: warning message?
		return 0;
	}

	$class->{'_MessageID'} = $1;

	return 1;
}

#####
#  Usage: $class->_getDialInfoByNumber( $number );
# Return: undef on failure.
# Return: %hash on success:
#   'CountryCode' - ISO3166-1-alpha-2 country code.
#   'CountryName' - country string.
#   'DialCodeSeq' - DistributeSMS specific integer.
#   'DialCode'    - international dial code.
#
sub _getDialInfoByNumber {
	my $class    = shift;
	my ($number) = @_;
	$number      =~ s/^\+//;

	while () {
		chop;

		next unless (/^(\S{2}):(.*?):(\d+):(\d+)/);
		my %hash = (
			'CountryCode' => $1,
			'CountryName' => $2,
			'DialCodeSeq' => $3,
			'DialCode'    => $4,
		);

		if ($number =~ /^$hash{'DialCode'}/) {
			$class->print('verbose', "[getDialInfoByNumber] number $number matched dialcode $hash{'DialCode'}");
			return %hash;
		}
	}

	# error.
	Carp::croak("getDialInfoByNumber: could not determine dial info by $number");
}

#####
#  Usage: $class->_login();
# Return: 1 for failure, 0 for success.
#
sub _login {
	my $class = shift;

	if ($class->{'_loggedin'}) {
		$class->print('verbose', "[login] already logged in!");
		return 0;
	}

	$class->print('verbose', "[login] logging in");

	#
	# error handling.
	#

	# error: no account_no
	if (!$class->{'account_no'}) {
		Carp::croak("login: no account_no specified");
	}

	# error: user
	if (!$class->{'login'}) {
		Carp::croak("login: no login specified");
	}

	# error: password.
	if (!$class->{'password'}) {
		Carp::croak("login: no password specified");
	}

	#
	# post details.
	#
	my %post  = (
		AccountNo  => $class->{'account_no'},
		UserId1    => $class->{'login'},
		Password1  => $class->{'password'},
		Remember1  => 1,
		OK1        => 'ok',
		Retry      => '',
    );

	#
	# login.
	#
	$class->print('verbose', "[login] logging in with");
	$class->print('verbose', "[login]   account number: ".$post{'AccountNo'} );
	$class->print('verbose', "[login]   username: ".$post{'UserId1'} );
	$class->print('verbose', "[login]   password: ".$post{'Password1'} );

	my $url = "http://www.distributesms.com.au/cgi-bin/li.pl";
	my $res = $class->_getURL($url, \%post);

	#
	# error: login failed.
	#
	if ($res->content() !~ /sm\.pl/) {
		my $data = $res->content();
#		$data =~ s#<\/?(body|html)>##gi;

		$class->print('verbose', "[login] ".$data);

		die("login: could not log in");
	}

	$class->print('verbose', "[login] successful!");
	$class->{'_loggedin'} = 1;

	return 1;
}

#####
#  Usage: $class->_getCredits();
# Return: 0 for failure, # of credits left for success.
#
sub _getCredits {
	my $class = shift;
	my $url   = "http://www.distributesms.com.au/cgi-bin/sm.pl";
	my $res   = $class->_getURL($url);
	my $check = 0;

	$check++ if ($res->content() =~ /Pre-Paid Messages Left/);
	$check++ if ($res->content() =~ /Leave blank to send immediately/);

	#
	# error: login or something weird failed.
	#
	if (!$check) {
		my $data = $res->content();
		$data =~ s#<\/?(body|html)>##gi;

		Carp::croak("getCredits: login failed - $data");
	}

	# todo: change so it returns # of credits left.
	return 1;
}

#####
#  Usage: $class->_getURL($url, $postref);
# Return: $res object
#
sub _getURL {
	my $class = shift;
	my ($url, $postref) = @_;
	my $req;
	my $res;

	# initialize.
	if (!$class->{'ua'} || !$class->{'cj'}) {
		$class->{'cj'} = $class->_newCJ();
		$class->{'ua'} = $class->_newUA();
	}

	# todo: check if url exists and is valid.
	# todo: if postref exists and is a hash reference.

	$class->print('verbose', "[getURL] url: $url");

	if ($postref) {
		my %post = %{ $postref };
		my $post = join('&', map { $_.'='.$post{$_} } keys %post);

		foreach (sort keys %post) {
			$class->print('verbose', "[getURL] post: $_ => $post{$_}");
		}
		$class->print('verbose', "[getURL] POST: $post");

		$req = HTTP::Request->new('POST', $url);
		$req->content_type('application/x-www-form-urlencoded');
		$req->content($post);
	} else {
		$req = HTTP::Request->new('GET', $url);
	}

	# todo: convert all $class->{'cj'} to $cj = $class->_getCJ();
	$class->{'cj'}->add_cookie_header($req);
	$res = $class->{'ua'}->request($req);
	$class->{'cj'}->extract_cookies($res);

	$class->{'cj'}->scan( sub {
		$class->{'cj'}->set_cookie(@_);
	} );

	# error: http 500 or something catastrophic.
	if ($res->code() =~ /^5/ && $res->content() =~ /timeo/i) {
		Carp::croak("getURL: proxy is dead; please update.");
	}

	return $res;
}

#####
#  Usage: $class->_newCJ();
# Return: $cj object.
#
sub _newCJ {
	my $class = shift;
	my $cj    = new HTTP::Cookies;

	return $cj;
}

#####
#  Usage: $class->_newUA();
# Return: $ua object.
#
sub _newUA {
	my $class = shift;
	my $ua    = new LWP::UserAgent;

	$ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)");
	$ua->cookie_jar($class->{'cj'});
	$ua->timeout(10);

	# set useragent.
	if ($class->{'agent'}) {
		$class->print('verbose', "[newUA] setting useragent to ".$class->{'agent'} );
		$ua->agent( $class->{'agent'} );
	}

	# set proxy.
	if ($class->{'proxy'}) {
		$class->print('verbose', "[newUA] setting proxy to ".$class->{'proxy'} );
		$ua->proxy('http', $class->{'proxy'});
	}

	return $ua;
}

1;

###########################################################
# DATA:
###########################################################

__DATA__