UCD.pm: if at first you don't succeed, croak?

[p5sagit/p5-mst-13.2.git] / lib / Net / SNPP.pm

# Net::SNPP.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. 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<new> 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<HOST> is the
name of the remote host to which a SNPP connection is required.

If C<HOST> is not given, then the C<SNPP_Host> specified in C<Net::Config>
will be used.

C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:

B<Timeout> - Maximum time, in seconds, to wait for a response from the
SNPP server (default: 120)

B<Debug> - Enable debugging information


Example:


    $snpp = Net::SNPP->new('snpphost',
			   Debug => 1,
			  );

=head1 METHODS

Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> 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<Net::SNPP> exports all that C<Net::CMD> exports, plus three more subroutines
that can bu used to compare against the result of C<status>. These are :-
C<CMD_2WAYERROR>, C<CMD_2WAYOK>, and C<CMD_2WAYQUEUED>.

=head1 SEE ALSO

L<Net::Cmd>
RFC1861

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=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