File Coverage

blib/lib/Net/CIMD.pm

Criterion	Covered	Total	%
statement	36	133	27.0
branch	0	42	0.0
condition	0	9	0.0
subroutine	11	28	39.2
pod	7	12	58.3
total	54	224	24.1

# Net::CIMD.pm  -  CIMD over TCP, pure perl implementation
# Copyright (c) 2013 Badr Zarhri , , All rights reserved.
# This code may be distributed under same terms as perl. NO WARRANTY.
# The implementation of this module is based on CIMD interface specification available in the internet.
# I should mention that Net::SMPP of Sampo Kellomaki  was of great help in implementing this protocol.
# Writing this module in perl makes it independant of other packages (it requires only a working perl installation).
# This module was tested in perl 5.8.8 (redhat EL 5), and 5.16.3 (centos 6.3).
# Please feel free to contact me if you've any remarks or ideas to improve this work.
# 23-June-2013, Created the module -- Badr
# 27-June-2013, fixed decode RE to handle nack --Badr
# 11-July-2013, added server support -- Badr
# 12-July-2013, added 7bit encoding functions -- Badr

package Net::CIMD;

use 5.008008;
use strict;
use warnings;
use Carp;
use IO::Socket;
use Data::Dumper;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Net::CIMD ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw( pack_7bit unpack_7bit

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.01_03';


my $trace = 0;
my %inv_op;
my %inv_par;
use constant Defaults => {
	host	=>	"127.0.0.1",
	port => 9971,
	timeout => 300,
	queue_size	=>	120
};
# CIMD interface specification 3.5 operation codes
use constant operation => {
	login	=>	"01",
	login_resp	=>	"51",
	logout	=>	"02",
	logout_resp	=>	"52",
	submit	=>	"03",
	submit_resp	=>	"53",
	submit_status_report	=>	"13",
	submit_status_report_resp	=>	"63",
	enquire_message_status	=>	"04",
	enquire_message_status_resp	=>	"54",
	delivery_request	=>	"05",
	delivery_request_resp	=>	"55",
	cancel	=>	"06",
	cancel_resp	=>	"56",
	deliver_message	=>	"20",
	deliver_message_resp	=>	"70",
	deliver_status_report	=>	"23",
	deliver_status_report_resp	=>	"73",
	set_parameters	=>	"08",
	set_parameters_resp	=>	"58",
	get_parameters	=>	"09",
	get_parameters_resp	=>	"59",
	alive	=>	"40",
	alive_resp	=>	"90",
	general_error_resp	=>	"98",
	nack	=>	"99"
};
# CIMD specification 7.2 parameters.
use constant parameter => {
	user_identity	=>	"010",
	password	=>	"011",
	subaddr	=>	"012",
	window_size	=>	"019",
	destination_address	=>	"021",
	originating_address	=>	"023",
	originating_IMSI	=>	"026",
	alphanumeric_ariginating_address	=>	"027",
	originated_visited_MSC_address	=>	"028",
	data_coding_scheme	=>	"030",
	user_data_header	=>	"032",
	user_data	=>	"033",
	user_data_binary	=>	"034",
	more_messages_to_send	=>	"044",
	validity_Period_Relative	=>	"050",
	validity_Period_Absolute	=>	"051",
	protocol_identifier	=>	"052",
	first_delivery_time_relative	=>	"053",
	first_delivery_time_absolute	=>	"054",
	reply_path	=>	"055",
	status_report_request	=>	"056",
	cancel_enabled	=>	"058",
	cancel_mode	=>	"059",
	service_centre_time_stamp	=>	"060",
	status_code	=>	"061",
	status_error_code	=>	"062",
	discharge_time	=>	"063",
	tariff_class	=>	"064",
	service_description	=>	"065",
	message_count	=>	"066",
	priority	=>	"067",
	delivery_request_mode	=>	"068",
	service_center_address	=>	"069",
	IP_address	=>	"071",
	get_parameter	=>	"500",
	SMS_center_time	=>	"501",
	error_code	=>	"900",
	error_text	=>	"901"
};

BEGIN {
	foreach( keys %{&operation})
	{
		$inv_op{operation->{$_}}=$_;
	}
	foreach( keys %{¶meter} )
	{
		$inv_par{parameter->{$_}}=$_;
	}
}
sub new_connect {
    my %arg = @_;
	my %parms=(
         PeerAddr  => exists $arg{host} ? $arg{host} : Defaults->{host},
         PeerPort  => exists $arg{port} ? $arg{port} : Defaults->{port},
         Proto     => 'tcp',
         Timeout   => exists $arg{timeout} ? $arg{timeout} : Defaults->{timeout} );
    my $s = IO::Socket::INET->new(%parms)  # pass any extra args to constructor
        or croak "Can't connect $! $@\n";
	return undef unless defined $s;
	$s->autoflush(1);
	return $s;
}

# buffer here is for future use.
sub receive_packet {
        my $me=shift;
        my $temp;
        while ($me->{tunnel}->sysread($temp, 1)) {
                $me->{buffer} .= $temp;
		last if($me->{buffer} =~ /\x09(?:..)?\x03$/);
        }
        my $result=$me->{buffer};
        $me->{buffer}="";
        return $result;
}

sub send_packet {
    my $me = shift;
    my $data = shift;
    $me->{seq}=sprintf("%03d", (($me->{seq}+2)%1000));
    carp "sending packet :\n".hexdump($data,"\t") if $trace;
    $me->{tunnel}->syswrite($data) or return undef;
	return 'Ok';
}

sub login {
    my $type = shift;
	$type=ref($type) || $type;
    my $tunnel = new_connect(@_);
    return undef if !defined $tunnel;
	my $me= bless {
		seq	=>	"001",
		buffer	=>	"",
		checksum	=>	0,
		tunnel	=>	$tunnel
		}, $type;
	my %args=@_;
    $me->send_packet($me->encode_packet("login", 'user_identity',$args{user_identity},'password',$args{password}));
	my $resp=$me->receive_packet();
	print "received\n".Dumper($resp) if $trace;
    return $me;
}

sub AUTOLOAD {
    my $me = shift;
	my $operation=our $AUTOLOAD;
	$operation =~ s/^.*::([^:]+)$/$1/;
	return undef unless defined (operation->{$operation});
	$me->send_packet($me->encode_packet($operation,@_));
	return "Ok";
}

sub encode_packet {
	my $me=shift;
	my $op=shift;
	my %args=@_;
        my $res="\x02".
	operation->{$op}.":".(defined $args{seq}?$args{seq}:$me->{seq})."\t";
	foreach (sort { parameter->{$a} <=> parameter->{$b} } keys %args)
        {
                $res.=parameter->{$_}.":".$args{$_}."\t" if(defined parameter->{$_});
        }
        return $res.&checksum($res)."\x03";
	#return $res."\x03";
}

sub decode_packet {
	my $me=shift;
	my $data=shift;
	return undef unless($data =~ /^\x02([^:]+):([^\x09]+)\x09(.*\x09)?(..)?\x03/);
	my ($op, $seq)=($1, $2);
	$data=$3;
	my $checksum=$4;
	my %parms;
	$data =~ s/([^:]+):([^\x09]*)\x09/$parms{$inv_par{$1}}=$2/eg if(defined $data);
	return bless {"operation", $inv_op{$op}, "sequence", $seq, %parms}, 'Net::CIMD::PDU';
}

sub checksum {
	my $hash = 0;
	foreach (split //, shift) {
		$hash += ord($_);
		$hash &= 0xFF;
	}
	return sprintf("%02x",$hash);
}
sub read_sync()
{
	my $me=shift;
	my $req=$me->decode_packet($me->receive_packet());
	$me->send_packet($me->encode_packet($req->{"operation"}."_resp",'seq', $req->{"sequence"})) if defined (operation->{$req->{"operation"}."_resp"});
	return $req;
}
sub read_async()
{
	my $me=shift;
        return $me->decode_packet($me->receive_packet());
}
sub DESTROY
{
	my $me=shift;
	$me->logout();
}

# Server commands
sub listen {
	my $type=shift;
	$type=ref($type) || $type;
	my %arg=@_;
	my %parms=(
        Listen  => exists $arg{queue_size} ? $arg{queue_size} : Defaults->{queue_size},
        LocalPort  => exists $arg{port} ? $arg{port} : Defaults->{port},
        Proto     => 'tcp',
        ReuseAddr => 'true',
        );
	return Net::CIMD::Listener->new(%parms);
}

sub pack_7bit {
    my ($s) = @_;
    $s = unpack 'b*', $s;
    $s =~ s/(.{7})./$1/g;    # Zap the high order (8th) bits
    $s= pack 'b*', $s;
	$s=unpack("H*", $s);
	return uc($s);
}

sub unpack_7bit {
    my ($s) = @_;
	$s=pack("H*", $s);
    $s = unpack 'b*', $s;
    $s =~ s/(.{7})/${1}0/g;  # Stuff in high order (8th) bits
    $s = pack 'b*', $s;
    chop $s if substr($s, -1, 1) eq "\x00";
    return $s;
}

package Net::CIMD::PDU;
sub new
{
	my $class=shift;
	return bless {@_}, $class;
}

package Net::CIMD::Listener;
use Carp;

sub new {
	my $type=shift;
	$type=ref($type) || $type;
	print "Listening : ".join(";", @_)." ...\n";
	my $s = IO::Socket::INET->new(@_) or croak "Can't Listen $! $@\n";
        return undef unless defined $s;
        $s->autoflush(1);
        return bless {'listener'	=>	$s}, $type;
}
sub accept {
	my $self=shift;
	my $tunnel = $self->{'listener'}->accept();
	return bless {
                seq     =>      "002",
                buffer  =>      "",
                tunnel  =>      $tunnel
                }, 'Net::CIMD';
}

1;
__END__