Net-SNPP-1.17/0040755000033500000000000000000010035314231011753 5ustar tobeyarootNet-SNPP-1.17/lib/0040755000033500000000000000000010035314231012521 5ustar tobeyarootNet-SNPP-1.17/lib/Net/0040755000033500000000000000000010035314231013247 5ustar tobeyarootNet-SNPP-1.17/lib/Net/SNPP/0040755000033500000000000000000010035314231014027 5ustar tobeyarootNet-SNPP-1.17/lib/Net/SNPP/HylaFAX.pm0100644000033500000000000000433607337523624015647 0ustar tobeyaroot package Net::SNPP::HylaFAX; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); use Net::SNPP; use Carp; $VERSION = do { my @r=(q$Revision: 1.1 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r}; @ISA = qw(Exporter Net::SNPP); @EXPORT = @Net::SNPP::EXPORT; @EXPORT_OK = qw(NOTIFY_NONE NOTIFY_DONE NOTIFY_REQUEUE MODEM_DEVICE MODEM_CLASS); %EXPORT_TAGS = ( NOTIFY => [qw(NOTIFY_NONE NOTIFY_DONE NOTIFY_REQUEUE)], MODEM => [qw(MODEM_DEVICE MODEM_CLASS)], ); sub NOTIFY_NONE () { 1 } sub NOTIFY_DONE () { 2 } sub NOTIFY_REQUEUE () { 4 } sub MODEM_CLASS () { 1 } sub MODEM_DEVICE () { 2 } sub jqueue { @_ == 2 or croak 'usage: $snpp->jqueue( BOOLEAN )'; my $snpp = shift; my $arg = $_[0] ? "YES" : "NO"; $snpp->_SITE('JQUEUE', $arg)->response() == CMD_OK; } sub from_user { @_ == 2 or croak 'usage: $snpp->from_user( MAIL_ADDRESS )'; my $snpp = shift; ($snpp->_SITE('FROMUSER',@_)->response == CMD_OK) ? ($snpp->message =~ /"([^"]+)"/)[0] : undef; } my %modem = ( DEVICE => MODEM_DEVICE, CLASS => MODEM_CLASS); sub modem { @_ == 2 or croak 'usage: $snpp->modem( [MODEM_DEVICE|MODEM_CLASS] )'; my $snpp = shift; my $modem = shift; my $arg = $modem == MODEM_DEVICE ? "DEVICE" : $modem == MODEM_CLASS ? "CLASS" : croak 'Unknown modem type'; my $ret = ($snpp->_SITE('MODEM',$arg)->response == CMD_OK) ? ($snpp->message =~ /"([^"]+)"/)[0] : undef; if(defined $ret) { $ret = uc $ret; $ret = $modem{$ret} || croak "Unknown modem type '$ret'"; } $ret; } my $i = 0; my %notify = map { $_ => (1 << $i++) } qw(NONE DONE REQUEUE); sub notify { @_ == 2 or croak 'usage: $snpp->notify( NOTIFY_LEVEL )'; my $snpp = shift; my $arg = shift; my @arg = (); croak 'Bad notify argument' if $arg < 1 || $arg == 3 || $arg == 5 || $arg > 6; push(@arg,"NONE") if $arg & 1; push(@arg,"DONE") if $arg & 2; push(@arg,"REQUEUE") if $arg & 4; my $str = ($snpp->_SITE('NOTIFY',join("+",@arg))->response == CMD_OK) ? ($snpp->message =~ /"([^"]+)"/)[0] : undef; my $val = undef; if($str) { $val = 0; map { $val |= $notify{$_} } split(/\+/, $str) } $val; } sub notify_addr { my $snpp = shift; ($snpp->_SITE('MAILADDR',@_)->response == CMD_OK) ? ($snpp->message =~ /"([^"]+)"/)[0] : undef; } 1; Net-SNPP-1.17/lib/Net/SNPP/Server.pm0100644000033500000000000006314510035313130015636 0ustar tobeyarootpackage Net::SNPP::Server; use strict; use warnings; use Socket; use IO::Handle; use Net::Cmd; use Fcntl qw(:flock); use Carp; use vars qw( @ISA $counter ); @ISA = qw( IO::Handle Net::Cmd ); $counter = 0; =head1 NAME Net::SNPP::Server =head1 DESCRIPTION An object interface for creating SNPP servers. Almost everything you need to create your very own SNPP server is here in this module. There is a callback() method that can replace default function with your own. them. Any SNPP command can be overridden or new/custom ones can be created using custom_command(). To disable commands you just don't want to deal with, use disable_command(). =head1 SYNOPSIS There may be a synopsis here someday ... =head1 METHODS =over 4 =item new() Create a Net::SNPP::Server object listening on a port. By default, it only listens on the localhost (127.0.0.1) - specify MultiHomed to listen on all addresses or LocalAddr to listen on only one. my $svr = Net::SNPP::Server->new( Port => port to listen on BindTo => interface address to bind to MultiHomed => listen on all interfaces if true (and BindTo is unset) Listen => how many simultaneous connections to handle (SOMAXCONN) # the following two options are only used by handle_client() MaxErrors => maximum number of errors before disconnecting client Timeout => timeout while waiting for data (uses SIGARLM) ); =cut sub new { my( $class, %args ) = @_; my $self = {}; # set defaults for basic parameters if ( !exists($args{Listen}) ) { $args{Listen} = SOMAXCONN } if ( !exists($args{Port}) ) { $args{Port} = 444 } # choose either a unix domain socket or an inet socket if ( !exists($args{UnixSocket}) ) { $args{Domain} = AF_INET } else { $args{Domain} = PF_UNIX } # by default, bind only to the loopback interface # i.e. MultiHomed and BindTo were not specified if ( !exists($args{MultiHomed}) && !exists($args{BindTo}) ) { $args{BindTo} = INADDR_LOOPBACK; } # if a bind address is passed in, bind to it elsif ( exists($args{BindTo}) ) { $args{BindTo} = inet_aton( $args{BindTo} ); } # bind to all interfaces if MultiHomed is defined # and BindTo is not else { $args{BindTo} = INADDR_ANY; } # these two values are only used by the handle_client method $self->{'MaxErrors'} = delete($args{MaxErrors}); $self->{'Timeout'} = delete($args{Timeout}); # create the socket by hand instead of IO::Socket::INET to # make manipulation a little easier within this module $self->{sock} = IO::Handle->new(); socket( $self->{sock}, $args{Domain}, SOCK_STREAM, getprotobyname('tcp') ) || croak "couldn't create socket: $!"; setsockopt( $self->{sock}, SOL_SOCKET, SO_REUSEADDR, 1 ); if ( $args{Domain} == PF_UNIX ) { if ( -e $args{UnixSocket} ) { unlink( $args{UnixSocket} ) } $self->{sockaddr} = sockaddr_un( $args{UnixSocket} ) || croak "couldn't get socket address: $!"; } else { $self->{sockaddr} = sockaddr_in( $args{Port}, $args{BindTo} ) || croak "couldn't get socket address: $!"; } bind( $self->{sock}, $self->{sockaddr} ) || croak "could not bind socket: $!"; listen( $self->{sock}, $args{Listen} ) || croak "could not listen on socket: $!"; # set default callbacks $self->{CB} = { process_page => sub { my( $pgr, $page, $results ) = @_; push( @$results, [ $pgr, $page ] ); }, validate_pager_id => sub { return undef if ( $_[0] =~ /\D/ || length($_[0]) < 7 ); return $_[0]; }, validate_pager_pin => sub { $_[1] || 1 }, write_log => sub { print STDERR "@_\n" }, create_id_and_pin => sub { srand(); # re-seed the pseudrandom number generator return( time().$counter, int(rand(1000000000)) ); } }; # initialize disabled and custom commands hashrefs $self->{disabled} = {}; $self->{custom} = {}; return bless( $self, $class ); } =item client() Calls accept() for you and returns a client handle. This method will block if there is no waiting client. The handle returned is a subclass of IO::Handle, so all IO::Handle methods should work. my $client = $server->client(); =cut sub client { my $handle = IO::Handle->new(); accept( $handle, $_[0]->{sock} ); return bless($handle, ref($_[0])); } =item ip() Return the IP address associated with a client handle. printf "connection from %s", $client->ip(); =cut sub ip { my $remote_client = getpeername($_[0]); return 'xxx.xxx.xxx.xxx' if ( !defined($remote_client) ); my($port,$iaddr) = unpack_sockaddr_in($remote_client); return inet_ntoa($iaddr); } =item socket() Returns the raw socket handle. This mainly exists for use with select() or IO::Select. my $select = IO::Select->new(); $select->add( $server->socket() ); =cut sub socket { $_[0]->{sock}; } =item connected() For use with a client handle. True if server socket is still alive. =cut sub connected { $_[0]->opened() && getpeername($_[0]) } =item shutdown() Shuts down the server socket. $server->shutdown(2); =cut sub shutdown { shutdown($_[0],$_[1] || 2) } =item callback() Insert a callback into Server.pm. $server->callback( 'process_page', \&my_function ); $server->callback( 'validate_pager_id', \&my_function ); $server->callback( 'validate_pager_pin', \&my_function ); $server->callback( 'write_log', \&my_function ); $server->callback( 'create_id_and_pin', \&my_function ); =over 2 =item process_page( $PAGER_ID, \%PAGE, \@RESULTS ) $PAGER_ID = [ 0 => retval of validate_pager_id 1 => retval of validate_pager_pin ] $PAGE = { mess => $, responses => [], } =item validate_pager_id( PAGER_ID ) The return value of this callback will be saved as the pager id that is passed to the process_page callback as the first list element of the first argument. =item validate_pager_pin( VALIDATED_PAGER_ID, PIN ) The value returned by this callback will be saved as the second list element in the first argument to process_page. The PAGER_ID input to this callback is the output from the validate_pager_id callback. NOTE: If you really care about the PIN, you must use this callback. The default callback will return 1 if the pin is not set. =item write_log First argument is a Unix syslog level, such as "warning" or "info." The rest of the arguments are the message. Return value is ignored. =item create_id_and_pin Create an ID and PIN for a 2way message. =back =cut sub callback ($ $ $) { croak "first argument callback() to must be one of: ", join(', ', keys(%{$_[0]->{CB}})) if ( !exists($_[0]->{CB}{$_[1]}) ); croak "second argument callback() to must be a CODE ref" if ( ref($_[2]) ne 'CODE' ); $_[0]->{CB}{$_[1]} = $_[2]; } =item custom_command() Create a custom command or override a default command in handle_client(). The command name must be 4 letters or numbers. The second argument is a coderef that should return a text command, i.e. "250 OK" and some "defined" value to continue the client loop. +++If no value is set, the client will be disconnected after executing your command.+++ If you need MSTA or KTAG, this is the hook you need to implement them. The subroutine will be passed the command arguments, split on whitespace. sub my_MSTA_sub { my( $id, $password ) = @_; # ... return "250 OK", 1; } $server->custom_command( "MSTA", \&my_MSTA_sub ); =cut sub custom_command ($ $ $) { croak "first argument to custom_command must be exactly 4 characters" if ( length($_[1]) != 4 ); croak "second argument to custom_command must be a coderef" if ( ref($_[2]) ne 'CODE' ); $_[0]->{custom}{uc($_[1])} = $_[2]; } =item disable_command() Specify a command to disable in the server. This is useful, for instance, if you don't want to support level 3 commands. $server->disable_command( "2WAY", "550 2WAY not supported here" ); The second argument is an optional custom error message. The default is: "500 Command Not Implemented, Try Again" =cut sub disable_command { # shorten & uppercase it so it matches in handle_client my $cmd = unpack('A4',uc($_[1])); if ( defined($_[2]) ) { $_[0]->{disabled}{$cmd} = $_[2]; } else { $_[0]->{disabled}{$cmd} = "500 Command Not Implemented, Try Again"; } } =item handle_client() Takes the result of $server->client() and takes care of parsing the user input. This should be quite close to being rfc1861 compliant. If you specified Timeout to be something other than 0 in new(), SIGARLM will be used to set a timeout. If you use this, make sure to take signals into account when writing your code. fork()'ing before calling handle_client is a good way to avoid interrupting code that shouldn't be interrupted. =cut sub handle_client ($ $) { my( $self, $client ) = @_; my $page = {}; # store the stuff the user gives us in this hash my @pgrs = (); # store the list of pagers # each pager is an array ref [ $pager_id, $pin ] my @retvals = (); # build up a list of return values my $errors = 0; # count the errors for maximum errors my $timeout = 0; local(%SIG); # enable timeouts if user requested passed Timeout to new() if ( $self->{'Timeout'} ) { $SIG{ALRM} = sub { $self->{CB}{write_log}->( 'debug', "client timeout" ); $client->command( "421 Timeout, Goodbye" ); $client->shutdown(2); $timeout = 1; }; alarm( $self->{'Timeout'} ); } # let the client know we're ready for them $client->command( "220 SNPP Gateway Ready" ); $self->{CB}{write_log}->( 'debug', "client connected" ); # loop until timeout or client quits while ( $timeout == 0 && (my $input = $client->getline()) ) { # clean \n\r's out of input, then split it up by whitespace $input =~ s/[\r\n]+//gs; my @cmd = split( /\s+/, $input ); # uppercase and truncate the command shifted from @cmd to 4 characters my $user_cmd = unpack('A4',uc(shift(@cmd))); if ( length($user_cmd) != 4 ) { # FIXME: put in correct full text from RFC document $client->command( "550 Error, Invalid Command" ); } $self->{CB}{write_log}->( 'debug', "processing command '$user_cmd @cmd'" ); # //////////////////////////////////////////////////////////////////// # # BEGIN COMMANDS PARSING # # \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ # ######################################################################## # user disabled commands --------------------------------------------- # if ( exists($self->{disabled}{$user_cmd}) ) { $errors++; $client->command( $self->{disabled}{$user_cmd} ); } ######################################################################## # user custom commands ----------------------------------------------- # elsif ( exists($self->{custom}{$user_cmd}) ) { my ($cmdtxt,$cont) = $self->{custom}{$user_cmd}->( @cmd ); $client->command( $cmdtxt ); last if ( !$cont ); } ######################################################################## # 4.3 Level 1 Commands ################################################# ######################################################################## # 4.3.1 PAGEr --------------------------------------------- # # 4.5.2 PAGEr [Password/PIN] ------------------------------- # elsif ( $user_cmd eq 'PAGE' ) { my $valid_pgr_id = $self->{CB}{validate_pager_id}->($cmd[0]); my $valid_pin = $self->{CB}{validate_pager_pin}->($valid_pgr_id,$cmd[1]); if ( $valid_pgr_id && $valid_pin ) { push( @pgrs, [$valid_pgr_id,$valid_pin] ); $client->command( "250 Pager ID Accepted" ); } else { $errors++; $client->command( "550 Error, Invalid Pager ID" ); } } ######################################################################## # 4.3.2 MESSage --------------------------- # # 4.5.8 SUBJect ------------------------------------- # elsif ( $user_cmd =~ /(MESS|SUBJ)/ ) { my $key = $1; if ( $key && $key eq 'MESS' && defined($page->{mess}) ) { $errors++; $client->command( "503 ERROR, Message Already Entered" ); next; } if ( !defined($cmd[0]) || $cmd[0] eq '' ) { $errors++; $client->command( "550 ERROR, Invalid Message" ); next; } $page->{lc($key)} = join(' ', @cmd); $client->command( "250 Message OK" ); } ######################################################################## # 4.3.3 RESEt -------------------------------------------------------- # elsif ( $user_cmd eq 'RESE' ) { $page = {}; @pgrs = (); $client->command( "250 RESET OK" ); } ######################################################################## # 4.3.4 SEND --------------------------------------------------------- # elsif ( $user_cmd eq 'SEND' ) { if ( @pgrs == 0 ) { $errors++; $client->command( "503 Error, Pager ID needed" ); next; } if ( !exists($page->{mess}) ) { $errors++; $client->command( "503 Error, Pager ID or Message Incomplete" ); next; } my $res = undef; for ( my $i=0; $i<@pgrs; $i++ ) { if ( !exists($page->{alert}) ) { $page->{alert} = 0 } if ( !exists($page->{hold}) ) { $page->{hold} = 0 } # call the callback subroutine with the data # the default callback just pushes the data onto @retvals $res = $self->{CB}{process_page}->( $pgrs[$i], $page, \@retvals ); } if ( $res && exists($page->{twoway}) ) { # this callback generates the two numbers for identifying a page my @tags = $self->{CB}{create_id_and_pin}->( \@pgrs, $page ); $client->command( "960 @tags OK, Message QUEUED for Delivery" ); } elsif ( $res ) { $client->command( "250 Message Sent Successfully" ); } else { $client->command( "554 Error, failed" ); next; } # RESEt @pgrs = (); $page = {}; } ######################################################################## elsif ( $user_cmd eq 'QUIT' ) { $client->command( "221 OK, Goodbye" ); last; } ######################################################################## # 4.3.6 HELP (optional) ---------------------------------------------- # elsif ( $user_cmd eq 'HELP' ) { { no warnings; # so we can use while () { $client->command( $_ ) } $client->command( "250 End of Help Information" ); } } ######################################################################## ## 4.4 Level 2 - Minimum Extensions #################################### ######################################################################## # 4.4.1 DATA --------------------------------------------------------- # elsif ( $user_cmd eq 'DATA' ) { $client->command( "354 Begin Input; End with '.'" ); my $buffer = join( '', @{ $client->read_until_dot() } ); if ( !defined($buffer) || !length($buffer) ) { $errors++; $client->command( "550 Error, Blank Message" ); } else { $buffer =~ s/[\r\n]+/\n/gs; $page->{mess} = $buffer; $client->command( "250 Message OK" ); } } ######################################################################## ## 4.5 Level 2 - Optional Extensions ################################### ######################################################################## # 4.5.4 ALERt ---------------------------------------- # elsif ( $user_cmd eq 'ALER' ) { if ( defined($cmd[0]) && ($cmd[0] == 1 || $cmd[0] == 0) ) { $page->{alert} = $cmd[0]; $client->command( "250 OK, Alert Override Accepted" ); } else { $errors++; $client->command( "550 Error, Invalid Alert Parameter" ); } } ######################################################################## # 4.5.6 HOLDuntil [+/-GMTdifference] ------------------ # # non-rfc to accept 4-digit years is also accepted ---- # elsif ( $user_cmd eq 'HOLD' ) { if ( defined($cmd[0]) && $cmd[0] !~ /[^0-9]/ && (length($cmd[0]) == 12 || length($cmd[0]) == 14) ) { $page->{hold} = $cmd[0]; if ( $cmd[1] =~ /([+-]\d+)/ ) { $page->{hold_gmt_diff} = $1; } $client->command( "250 Delayed Messaging Selected" ); } else { $errors++; $client->command( "550 Error, Invalid Delivery Date/Time" ); } } ######################################################################## ## 4.6 Level 3 - Two-Way Extensions #################################### ######################################################################## # 4.6.1 2WAY --------------------------------------------------------- # elsif ( $user_cmd eq '2WAY' ) { if ( exists($page->{mess}) || @pgrs > 0 ) { $errors++; $client->command( "550 Error, Standard Transaction Already Underway, use RESEt" ); next; } $page->{twoway} = 1; $client->command( "250 OK, Beginning 2-Way Transaction" ); } ######################################################################## # 4.6.2 PING --------------------------------------- # # FIXME: what the heck should this do by default? elsif ( $user_cmd eq 'PING' ) { $client->command( "250 OK, Cannot access device status" ); } ######################################################################## # 4.6.7 MCREsponse <2-byte_Code> Response_Text (not implemented) ----- # elsif ( $user_cmd eq 'MCRE' ) { if ( !exists($page->{twoway}) ) { $errors++; $client->command( "550 MCResponses Not Enabled" ); } elsif ( $cmd[0] !~ /[^0-9]/ && length($cmd[0]) < 3 && length($cmd[1]) >= 1 && length($cmd[1]) < 16 ) { if ( exists($page->{responses}{$cmd[0]}) ) { $client->command( "502 Error! Would Duplicate Previously Entered MCResponse" ); next; } $page->{responses}{shift @cmd} = join(' ',@cmd); $client->command( "250 Response Added to Transaction" ); } else { $errors++; $client->command( "554 Error, failed" ); } } ######################################################################## # UNKNOWN/UNDEFINED COMMANDS ----------------------------------------- # # -------------------------------------------------------------------- # # 4.5.1 LOGIn [password] (not implemented) ----------------- # # 4.5.3 LEVEl (not implemented) ----------------- # # 4.5.5 COVErage (not implemented) ----------------- # # 4.5.7 CALLerid (not implemented) ----------------- # # 4.6.3 EXPTag (not implemented) ----------------- # # 4.6.5 ACKRead <0|1> (not implemented) ----------------- # # 4.6.6 RTYPe (not implemented) ----------------- # # MSTA --------------------------------------------------------------- # # KTAG (not implemented) ----------------- # ######################################################################## else { $errors++; $client->command( "500 Command Not Implemented, Try Again" ); } # //////////////////////////////////////////////////////////////////// # # END COMMANDS PARSING # # \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ # # check the number of errors if ( $self->{MaxErrors} && $errors >= $self->{MaxErrors} ) { $client->command( "421 Too Many Errors, Goodbye (terminate connection)" ); last; } # reset the alarm on input if ( $self->{Timeout} ) { alarm(0); alarm( $self->{Timeout} ); } } # while() # turn off the alarm if ( $self->{Timeout} ) { alarm(0); } # disconnect if we're still connected if ( $client->connected() ) { $client->shutdown(2) } return @retvals; } =item forked_server() Creates a server in a forked process. The return value is an array (or arrayref depending on context) containing a read-only pipe and the pid of the new process. Pages completed will be written to the pipe as a semicolon delimited array. my($pipe,$pid) = $server->forked_server(); my $line = $pipe->getline(); chomp( $line ); my( $pgr, $pgr, %pagedata ) = split( /;/, $line ); =cut # when testing, pass in an integer argument to limit the number of clients # the server will process before exiting sub forked_server { my( $self, $count_arg ) = @_; my $count = -1; if ( $count_arg ) { $count = $count_arg } my @pids = (); # pids to merge before exit # create a pipe for communication from child back to this process our( $rp, $wp ) = ( IO::Handle->new(), IO::Handle->new() ); pipe( $rp, $wp ) || die "could not create READ/WRITE pipes"; $wp->autoflush(1); # declare our callback subroutine for process_page # has it's own ugly serialization that should probably be replaced # with Storable or Dumper sub write_to_pipe { my( $pgr, $page, $results ) = @_; my( @parts, @resps ) = (); if ( my $href = delete($page->{responses}) ) { while ( my($k,$v) = each(%$href) ) { $v =~ s/;/\%semicolon%/g; $k = "responses[$k]"; push( @resps, $k, $v ); } } while ( my($k,$v) = each(%$page) ) { if ( !defined($v) ) { $v = '' } push( @parts, $k, $v ); } if ( !defined($pgr->[1]) ) { $pgr->[1] = '1' } my $out = join( ';', @$pgr, @parts, @resps ); $out =~ s/[\r\n]+//gs; # make sure there aren't any unexpected newlines # send the page semicolon delimited down the pipe flock( $wp, LOCK_EX ); $wp->print( "$out\n" ); flock( $wp, LOCK_UN ); } # fork a child process to act as a server my $pid = fork(); if ( $pid ) { $wp->close(); return wantarray ? ($rp,$pid) : [$rp,$pid]; } else { $rp->close(); # replace the page callback with our own subroutine $self->callback( 'process_page', \&write_to_pipe ); while ( !$count_arg || $count > 0 ) { # attempt reap child processes on every loop for ( my $i=0; $i<@pids; $i++ ) { my $pid = waitpid( $pids[$i], 0 ); if ( $pid < 1 ) { splice( @pids, $i, 1 ); } } # get a client socket handle my $client = $self->client(); $count--; # fork again so we can handle simultaneous connections my $pid = fork(); # parent process goes back to top of loop if ( $pid ) { push( @pids, $pid ); next; } $self->handle_client( $client ); exit 0; } $wp->close(); exit 0; } } =back =head1 AUTHOR Al Tobey Some ideas from Sendpage::SNPPServer Kees Cook http://outflux.net/ =head1 TODO Add more hooks for callbacks Implement the following level 2 and level 3 commands 4.5.1 LOGIn [password] 4.5.3 LEVEl 4.5.5 COVErage 4.5.7 CALLerid 4.6.3 EXPTag 4.6.5 ACKRead <0|1> 4.6.6 RTYPe =head1 SEE ALSO Net::Cmd Socket =cut 1; # FIXME: update this from the RFC __DATA__ 214 214 Level 1 commands: 214 214 PAGEr 214 MESSage 214 RESEt 214 SEND 214 QUIT 214 HELPinfo 214 214 Level 2 commands: 214 214 DATA 214 LOGIn 214 ALERt > 214 HOLDuntil [+/-GMTdifference] 214 CALLerid 214 SUBJect 214 214 Level 3 commands: 214 214 2WAY 214 ACKRead <0|1> 214 RType 214 MCREsponse <2-byte_code> 214 MSTAtus 214 Net-SNPP-1.17/lib/Net/SNPP.pm0100644000033500000000000003423710035314216014376 0ustar tobeyaroot# Net::SNPP.pm # # Copyright (c) 1995-2001 Graham Barr. # Copyright (c) 2001 Derek J. Balling . # All rights reserved. This program is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. # package Net::SNPP; require 5.001; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); use Socket 1.3; use Carp; use IO::Socket; use Net::Cmd; use Net::Config; $VERSION = "1.17"; # $Id: SNPP.pm,v 1.9 2004/01/27 22:18:32 tobeya Exp $ @ISA = qw(Net::Cmd IO::Socket::INET); @EXPORT = (qw(CMD_2WAYERROR CMD_2WAYOK CMD_2WAYQUEUED), @Net::Cmd::EXPORT); sub CMD_2WAYERROR () { 7 } sub CMD_2WAYOK () { 8 } sub CMD_2WAYQUEUED () { 9 } sub new { my $self = shift; my $type = ref($self) || $self; my $host = shift if @_ % 2; my %arg = @_; my $hosts = defined $host ? [ $host ] : $NetConfig{snpp_hosts}; my $obj; my $h; foreach $h (@{$hosts}) { $obj = $type->SUPER::new(PeerAddr => ($host = $h), PeerPort => $arg{Port} || 'snpp(444)', Proto => 'tcp', Timeout => defined $arg{Timeout} ? $arg{Timeout} : 120 ) and last; } return undef unless defined $obj; ${*$obj}{'net_snpp_host'} = $host; $obj->autoflush(1); $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); unless ($obj->response() == CMD_OK) { $obj->close(); return undef; } $obj; } ## ## User interface methods ## sub pager_id { @_ == 2 or croak 'usage: $snpp->pager_id( PAGER_ID )'; shift->_PAGE(@_); } sub content { @_ == 2 or croak 'usage: $snpp->content( MESSAGE )'; shift->_MESS(@_); } sub send { my $me = shift; if(@_) { my %arg = @_; if(exists $arg{Pager}) { my $pagers = ref($arg{Pager}) ? $arg{Pager} : [ $arg{Pager} ]; my $pager; foreach $pager (@$pagers) { $me->_PAGE($pager) || return 0 } } $me->_MESS($arg{Message}) || return 0 if(exists $arg{Message}); $me->hold($arg{Hold}) || return 0 if(exists $arg{Hold}); $me->hold($arg{HoldLocal},1) || return 0 if(exists $arg{HoldLocal}); $me->_COVE($arg{Coverage}) || return 0 if(exists $arg{Coverage}); $me->_ALER($arg{Alert} ? 1 : 0) || return 0 if(exists $arg{Alert}); $me->service_level($arg{ServiceLevel}) || return 0 if(exists $arg{ServiceLevel}); } $me->_SEND(); } sub data { my $me = shift; my $ok = $me->_DATA() && $me->datasend(@_); return $ok unless($ok && @_); $me->dataend; } sub login { @_ == 2 || @_ == 3 or croak 'usage: $snpp->login( USER [, PASSWORD ])'; shift->_LOGI(@_); } sub help { @_ == 1 or croak 'usage: $snpp->help()'; my $me = shift; return $me->_HELP() ? $me->message : undef; } sub xwho { @_ == 1 or croak 'usage: $snpp->xwho()'; my $me = shift; $me->_XWHO or return undef; my(%hash,$line); my @msg = $me->message; pop @msg; # Remove command complete line foreach $line (@msg) { $line =~ /^\s*(\S+)\s*(.*)/ and $hash{$1} = $2; } \%hash; } sub service_level { @_ == 2 or croak 'usage: $snpp->service_level( LEVEL )'; my $me = shift; my $level = int(shift); if($level < 0 || $level > 11) { $me->set_status(550,"Invalid Service Level"); return 0; } $me->_LEVE($level); } sub alert { @_ == 1 || @_ == 2 or croak 'usage: $snpp->alert( VALUE )'; my $me = shift; my $value = (@_ == 1 || shift) ? 1 : 0; $me->_ALER($value); } sub coverage { @_ == 1 or croak 'usage: $snpp->coverage( AREA )'; shift->_COVE(@_); } sub hold { @_ == 2 || @_ == 3 or croak 'usage: $snpp->hold( TIME [, LOCAL ] )'; my $me = shift; my $time = shift; my $local = (shift) ? "" : " +0000"; my @g = reverse((gmtime($time))[0..5]); $g[1] += 1; $g[0] %= 100; $me->_HOLD( sprintf("%02d%02d%02d%02d%02d%02d%s",@g,$local)); } sub caller_id { @_ == 2 or croak 'usage: $snpp->caller_id( CALLER_ID )'; shift->_CALL(@_); } sub subject { @_ == 2 or croak 'usage: $snpp->subject( SUBJECT )'; shift->_SUBJ(@_); } sub site { @_ == 2 or croak 'usage: $snpp->site( CMD )'; shift->_SITE(@_); } sub two_way { @_ == 1 or croak 'usage: $snpp->two_way()'; shift->_2WAY(); } sub ping { @_ == 2 or croak 'usage: $snpp->ping( PAGER_ID )'; shift->_PING(@_); } sub noqueue { @_ == 1 or croak 'usage: $snpp->noqueue()'; shift->_NOQU(); } sub expire_time { @_ == 2 or croak 'usage: $snpp->expire_time( HOURS )'; shift->_EXPT(@_); } sub read_ack { @_ == 2 or croak 'usage: $snpp->read_ack( TRUEFALSE )'; shift->_ACKR(@_); } # 4.6.7 MCREsponse <2-byte_Code> Response_Text sub message_response { @_ == 3 or croak 'usage: $snpp->message_response( INT, RESPONSE )'; shift->_MCRE(@_); } # 4.6.10 MSTAtus sub message_status { @_ == 3 or croak 'usage: $snpp->message_status( Message_Tag, Pass_Code )'; my $me = shift; my @out = (); my $resp = $me->command("MSTA", @_)->response(); $out[4] = $me->code(); if ($resp == CMD_2WAYQUEUED || $resp == CMD_2WAYOK || $resp == CMD_2WAYERROR) { # 860 Delivered, Awaiting Read Confirmation # this regex doesn't count on every server putting the +/-GMT tag # on the timestamp my $msg = $me->message(); chomp( $msg ); #if ($msg =~ /^(\d+)\s+(\d+)(.*)\s+(.*)$/) if ($msg =~ /^\s*(\d+)\s+(\d+)([+-]?\d*)\s+(.*)$/) { splice(@out, 0, 4, ($1,$2,$3,$4)); } else { $me->debug_print( undef, "server reply for MCRE '$msg' did not match regex" ); } } return wantarray ? @out : \@out; } # 4.6.9 SEND (Level 3) sub send_two_way { @_ == 1 or croak 'usage: $snpp->send_two_way()'; my $me = shift; my @out = (); $out[3] = $me->command("SEND")->response(); # rfc1861 specifies that a 2way SEND can return 8xx or 9xx when successful # i.e. # 860 Delivered, Awaiting Read Ack # 960 OK, Message QUEUED for Delivery if ($out[3] == CMD_2WAYQUEUED || $out[3] == CMD_2WAYOK) { $me->message() =~ m/^(\d+)\s+(\d+)\s*(.*)$/; splice(@out, 0, 3, ($1,$2,$3)); } return wantarray ? @out : \@out; } sub reset { @_ == 1 or croak 'usage: $snpp->reset()'; shift->_RESE(); } sub reply_type { @_ == 2 or croak 'usage: $snpp->reply_type( TYPE_CODE )'; shift->_RTYP(uc (@_)); } sub quit { @_ == 1 or croak 'usage: $snpp->quit()'; my $snpp = shift; $snpp->_QUIT; $snpp->close; } ## ## IO/perl methods ## sub DESTROY { my $snpp = shift; defined(fileno($snpp)) && $snpp->quit; delete ${*$snpp}{'net_snpp_host'}; } ## ## Over-ride methods (Net::Cmd) ## sub debug_text { $_[2] =~ s/^((logi|page)\s+\S+\s+)\S+/$1 xxxx/io; $_[2]; } sub parse_response { return () unless $_[1] =~ s/^(\d\d\d)(.?)//o; my($code,$more) = ($1, $2 eq "-"); $more ||= $code == 214; ($code,$more); } ## ## RFC1861 commands ## # Level 1 sub _PAGE { shift->command("PAGE", @_)->response() == CMD_OK } sub _MESS { shift->command("MESS", @_)->response() == CMD_OK } sub _RESE { shift->command("RESE")->response() == CMD_OK } # level 3 SEND returns 8xx or 9xx for successful responses sub _SEND { shift->command("SEND")->response() == CMD_OK } sub _QUIT { shift->command("QUIT")->response() == CMD_OK } sub _HELP { shift->command("HELP")->response() == CMD_OK } sub _DATA { shift->command("DATA")->response() == CMD_MORE } sub _SITE { shift->command("SITE",@_)->response() == CMD_OK } # Level 2 sub _LOGI { shift->command("LOGI", @_)->response() == CMD_OK } sub _LEVE { shift->command("LEVE", @_)->response() == CMD_OK } sub _ALER { shift->command("ALER", @_)->response() == CMD_OK } sub _COVE { shift->command("COVE", @_)->response() == CMD_OK } sub _HOLD { shift->command("HOLD", @_)->response() == CMD_OK } sub _CALL { shift->command("CALL", @_)->response() == CMD_OK } sub _SUBJ { shift->command("SUBJ", @_)->response() == CMD_OK } # Level 3 sub _2WAY { shift->command("2WAY")->response() == CMD_OK } sub _PING { shift->command("PING", @_)->response() == CMD_OK } sub _ACKR { shift->command("ACKR", @_)->response() == CMD_OK } sub _EXPT { shift->command("EXPT", @_)->response() == CMD_OK } sub _KTAG { shift->command("KTAG", @_)->response() == CMD_OK } sub _MCRE { shift->command("MCRE", @_)->response() == CMD_OK } # MSTA here is not RFC compliant (returns 8xx or 9xx on success) sub _MSTA { shift->command("MSTA", @_)->response() == CMD_OK } sub _NOQU { shift->command("NOQU")->response() == CMD_OK } sub _RTYP { shift->command("RTYP", @_)->response() == CMD_OK } # NonStandard sub _XWHO { shift->command("XWHO")->response() == CMD_OK } 1; __END__ =head1 NAME Net::SNPP - Simple Network Pager Protocol Client =head1 SYNOPSIS use Net::SNPP; # Constructors $snpp = Net::SNPP->new('snpphost'); $snpp = Net::SNPP->new('snpphost', Timeout => 60); =head1 NOTE This module is in a maintenance mode, as I no longer have significant access to SNPP servers to test with. However, to the best of the present maintainer's knowledge, the module works just fine and has been used in many a production environment. =head1 DESCRIPTION This module implements a client interface to the SNPP protocol, enabling a perl5 application to talk to SNPP servers. This documentation assumes that you are familiar with the SNPP protocol described in RFC1861. A new Net::SNPP object must be created with the I method. Once this has been done, all SNPP commands are accessed through this object. =head1 EXAMPLES This example will send a pager message in one hour saying "Your lunch is ready" #!/usr/local/bin/perl -w use Net::SNPP; $snpp = Net::SNPP->new('snpphost'); $snpp->send( Pager => $some_pager_number, Message => "Your lunch is ready", Alert => 1, Hold => time + 3600, # lunch ready in 1 hour :-) ) || die $snpp->message; $snpp->quit; =head1 CONSTRUCTOR =over 4 =item new ( [ HOST, ] [ OPTIONS ] ) This is the constructor for a new Net::SNPP object. C is the name of the remote host to which a SNPP connection is required. If C is not given, then the C specified in C will be used. C are passed in a hash like fashion, using key and value pairs. Possible options are: B - Maximum time, in seconds, to wait for a response from the SNPP server (default: 120) B - Enable debugging information Example: $snpp = Net::SNPP->new('snpphost', Debug => 1, ); =back =head1 METHODS Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method states that it returns a value, failure will be returned as I or an empty list. =over 4 =item reset () =item help () Request help text from the server. Returns the text or undef upon failure =item quit () Send the QUIT command to the remote SNPP server and close the socket connection. =item site ( CMD ) Send a SITE command to the remote SNPP server. site() take a single argument which is the command string to send to the SNPP server. =item ping ( PAGER_ID ) Determine if the remote SNPP server is able to contact a given pager ID. (Level 3 command) =item noqueue () Instruct the SNPP server not to queue the two-way request. (Level 3 command) =item expire_time ( HOURS ) Cause the paging request to be canceled if it has not been sent in the specified number of hours. (Level 3 command) =item read_ack ( TRUEFALSE ) Enable and disable the read acknowledgement notification sent by the pager. (Level 3 command) =item reply_type ( TYPE_CODE ) Change the type of reply that the page will send back. Valid options are: NONE, YESNO, SIMREPLY, MULTICHOICE, and TEXT. (Level 3 command) =item message_response ( INT TEXT ) (Level 3) Create message responses to deliver with the message. INT is a 2-byte number. The total number of definable responses may be limited by your server. Some server may need you to call reply_type() before specifying responses. =item message_status ( MSGID MSGID ) (Level 3) Get the message status from the remote server. Use the Message_Tag and Pass_Code from send_two_way() as the arguments to this method, and if your server supports it, you should be able to retrieve the status of a 2-way message. An array/arraref is returned with the following 5 elements: [0] Sequence [1] Date&Time [2] +/- GMT (if provided by server) [3] server-specific response text [4] numeric response code from server (i.e. 860 or 960) =item send_two_way () (Level 3) Use this method instead of send() when working in Level 3 of the SNPP protocol. Before using this method, you have to build up your page using the other methods in the module, then use this at the very end to "submit" your page. An array/arrayref will be returned with the following 4 elements: [0] Message_Tag [1] Pass_Code [2] server-specific response text [3] numeric response code from server (i.e. 860 or 960) NOTE: This is only the SEND command - you have to build the page using various methods from this module before calling this method. =back =head1 2WAY EXAMPLES use Net::SNPP; my $snpp = Net::SNPP->new( "snpp.provider.com" ); $snpp->two_way(); $snpp->pager_id( 5555555555 ); $snpp->data( "The sky is falling!\nThe sky is falling!" ); $snpp->message_response( 1, "Don't Panic" ); $snpp->message_response( 2, "Panic!" ); my @result = $snpp->send_two_way(); $snpp->quit(); printf "Use these two numbers: \"%s %s\" to check message status.\n", $result[0], $result[1]; __END__ use Net::SNPP; my $snpp = Net::SNPP->new( "snpp.provider.com" ); my @status = $snpp->message_status( $ARGV[0], $ARGV[1] ); $snpp->quit; printf "User responded with: %s\n", $status[3]; =head1 EXPORTS C exports all that C exports, plus three more subroutines that can bu used to compare against the result of C. These are :- C, C, and C. =head1 SEE ALSO L RFC1861 =head1 AUTHOR Derek J. Balling ( original version by Graham Barr ) Al Tobey (since Oct 2003) =head1 COPYRIGHT Copyright (c) 1995-2001 Graham Barr. (c) 2001-2003 Derek J. Balling. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =for html
I<$Id: SNPP.pm,v 1.9 2004/01/27 22:18:32 tobeya Exp $> =cut Net-SNPP-1.17/bin/0040755000033500000000000000000010035314231012523 5ustar tobeyarootNet-SNPP-1.17/bin/send_two_way.pl0100644000033500000000000000145107737032566015607 0ustar tobeyaroot#!/usr/local/bin/perl -w use strict; use Net::SNPP; my $pager_number = shift(@ARGV); my $message = join(' ', @ARGV); die "I need a pager number and a message or this exercise is pointless." if ( !$pager_number || !$message ); # change this to the address for your provider's SNPP server #my $snpp = Net::SNPP->new( 'snpp.nextel.com' ); my $snpp = Net::SNPP->new( 'localhost', Port => 11444 ) || die "could not connect to SNPP server"; #$snpp->debug(10); $snpp->two_way(); $snpp->pager_id( $pager_number ); $snpp->data( $message ); $snpp->message_response( 1, "Acknowledge" ); $snpp->message_response( 2, "Decline" ); $snpp->message_response( 3, "Escalate" ); my @msg = $snpp->send_two_way(); $snpp->quit(); print "Check message status with these two numbers: '$msg[0] $msg[1]'\n"; exit 0; Net-SNPP-1.17/bin/check_two_way.pl0100644000033500000000000000125207737032641015724 0ustar tobeyaroot#!/usr/local/bin/perl -w use strict; use Net::SNPP; die "I need two arguments!" if ( @ARGV != 2 ); # should be two arguments that are digits my( $message_tag, $message_pin ) = @ARGV; #my $snpp_server = Net::SNPP->new( 'snpp.nextel.com' ); my $snpp_server = Net::SNPP->new( 'localhost', Port => 11444 ) || die "could not connect to SNPP server!"; #$snpp_server->debug(10); my @status = $snpp_server->message_status( $message_tag, $message_pin ); print <quit(); exit 0; Net-SNPP-1.17/bin/snppd.pl0100644000033500000000000000176210004551214014207 0ustar tobeyaroot#!/usr/local/bin/perl -w use strict; use lib qw( ../lib ); # for testing use Net::SNPP::Server; use Sys::Syslog qw(:DEFAULT setlogsock); setlogsock('unix'); openlog( "snppd.pl", 'pid,cons,ndelay,nowait', 'daemon' ) or die "could not openlog(): $!"; my $server = Net::SNPP::Server->new( Port => 11444, Timeout => 60 ); sub write_log_syslog { syslog( shift, join(' ',@_) ); } sub fake_MSTA { return "960 1 20031002100000+6 Message Queued; Awaiting Delivery"; } $server->callback( 'write_log', \&write_log_syslog ); # lie about MSTA requests and say they're all OK $server->custom_command( 'MSTA', \&fake_MSTA ); my( $pipe, $pid ) = $server->forked_server(); while ( my $result = $pipe->getline() ) { chomp( $result ); my( $pin, $pin_passwd, %page ) = split( /;/, $result ); # put your own data storage/forwarding logic here print "got page for pin $pin with message '$page{mess}'\n"; } $pipe->close(); closelog(); # reap the server process waitpid( $pid, 1 ); exit 0; Net-SNPP-1.17/META.yml0100644000033500000000000000052410035314231013222 0ustar tobeyaroot# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Net-SNPP version: 1.17 version_from: lib/Net/SNPP.pm installdirs: site requires: Net::Cmd: 0.01 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Net-SNPP-1.17/t/0040755000033500000000000000000010035314231012216 5ustar tobeyarootNet-SNPP-1.17/t/server.t0100644000033500000000000000360210005337551013716 0ustar tobeyaroot#!/usr/local/bin/perl -w $|++; use strict; use Test::More; use IO::File; use lib qw( ../lib ); use vars qw( $port @pids ); BEGIN { plan tests => 15 } $port = 20444; # arguments for use in tests my %args = ( Pager => 5555555555, Message => "The sky is falling!", Alert => 1, Hold => time + 3 ); use_ok( 'Net::SNPP::Server' ); use_ok( 'Net::SNPP' ); ok( my $server = Net::SNPP::Server->new( Port => $port ), "created a server" ); # disable logging from server (comment next line out to turn it on) $server->callback( 'write_log', sub { } ); my( $rp, $pid ) = $server->forked_server(1); push( @pids, $pid ); diag( "test server up and running on $port" ); diag( "attempting to connect to server using Net::SNPP" ); ok( my $snppclient = Net::SNPP->new( 'localhost', Port => $port ), "connected to server using Net::SNPP client" ); # uncomment the following to turn on Net::SNPP debugging # $snppclient->debug( 10 ); # test $snppclient->ping(); ok( $snppclient->ping( $args{Pager} ), "client->ping()" ); ok( $snppclient->send( %args ), "client->send()" ); ok( $snppclient->reset(), "client->reset()" ); diag "testing 2way capabilities (level 3)"; ok( $snppclient->two_way(), "client->two_way()" ); ok( $snppclient->pager_id( $args{Pager} ), "client->pager_id( $args{Pager} )" ); ok( $snppclient->data(<data(<message_response( 1, "Test1" ), "client->message_response(1, 'Test1')" ); ok( $snppclient->message_response( 2, "Test2" ), "client->message_response(2, 'Test2')" ); ok( $snppclient->message_response( 3, "Test3" ), "client->message_response(3, 'Test3')" ); ok( $snppclient->message_response( 4, "Test4" ), "client->message_response(4, 'Test4')" ); ok( $snppclient->quit(), "client->quit()" ); foreach my $pid ( @pids ) { kill( 2, $pid ); waitpid( $pid, 1 ); } exit 0; Net-SNPP-1.17/t/use.t0100755000033500000000000000015407520037654013217 0ustar tobeyaroot#!/usr/bin/env perl -w use strict; use Test; BEGIN { plan tests => 1 } use Net::SNPP; ok(1); exit; __END__ Net-SNPP-1.17/MANIFEST0100644000033500000000000000036307762214550013123 0ustar tobeyarootlib/Net/SNPP.pm lib/Net/SNPP/Server.pm lib/Net/SNPP/HylaFAX.pm Makefile.PL README MANIFEST t/use.t t/server.t META.yml Module meta-data (added by MakeMaker) bin/snppd.pl bin/check_two_way.pl bin/send_two_way.pl Net-SNPP-1.17/Makefile.PL0100755000033500000000000000033107337523606013745 0ustar tobeyaroot# This -*- perl -*- script makes the Makefile use 5.005; use ExtUtils::MakeMaker; WriteMakefile( VERSION_FROM => 'lib/Net/SNPP.pm', NAME => 'Net::SNPP', PREREQ_PM => { 'Net::Cmd' => 0.01 }, ); Net-SNPP-1.17/README0100755000033500000000000000331510035313773012647 0ustar tobeyarootNet::SNPP was previously part of the libnet distribution. But has now been separated out to a distribution of its own. As of October 2, 2003, maintainership of this module has been taken over by Al Tobey . NEWS I will be working to make Net::SNPP cover the complete rfc1861 specification while adding tests for all of it. I need feedback from people who use this to see what the impact of interface changes would be. I also would appreciate some test scenarios or code snippets that you use so that I can try not to break things for you. If anything breaks in >=1.15 releases, you can blame me and be sure to send all of your flames to me. CHANGES April 9, 2004: The message_response method in SNPP.pm was fixed to return server codes properly. Also, a few things in Server.pm were fixed up and documented better. Oct 2, 2003: Added bin/ directory with an snppd for testing, and two utilites for sending and checking SNPP messages. Added methods to SNPP.pm for more RFC-compliant sending/checking of 2-way (level 3) messages. INSTALLATION Installation is the same as any other MakeMaker packaged distribution from CPAN. perl Makefile.PL make make install If you are on a machine where Makemaker does not run, or you do not have a copy of make, then you can simply copy the contents of the lib directory into your perl installation library directory. However you will need to have Net::Cmd from libnet installed COPYRIGHT © 1995-2001 Graham Barr. All rights reserved. © 2001-2003 Derek J. Balling. All rights reserved. © 2003-2004 Al Tobey. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Share and Enjoy!