diff -r 22486c9c7b15 -r 378360dbbdba releasing/cbrtools/perl/Net/SNPP.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/releasing/cbrtools/perl/Net/SNPP.pm Wed Jun 30 11:35:58 2010 +0800 @@ -0,0 +1,414 @@ +# Net::SNPP.pm +# +# Copyright (c) 1995-1997 Graham Barr . 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.11"; # $Id:$ +@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 two_way +{ + @_ == 1 or croak 'usage: $snpp->two_way()'; + shift->_2WAY(); +} + +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 +} + +## +## 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 } +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",@_) } + +# 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 } + +# 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 not complete, yet ! + +=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, + ); + +=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. + +=back + +=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 + +Graham Barr + +=head1 COPYRIGHT + +Copyright (c) 1995-1997 Graham Barr. All rights reserved. +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut