lib/Net/SNPP.pm

   1 # Net::SNPP.pm
   2 #
   3 # Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
   4 # This program is free software; you can redistribute it and/or
   5 # modify it under the same terms as Perl itself.
   6
   7 package Net::SNPP;
   8
   9 require 5.001;
  10
  11 use strict;
  12 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  13 use Socket 1.3;
  14 use Carp;
  15 use IO::Socket;
  16 use Net::Cmd;
  17 use Net::Config;
  18
  19 $VERSION = "1.11"; # $Id:$
  20 @ISA     = qw(Net::Cmd IO::Socket::INET);
  21 @EXPORT  = (qw(CMD_2WAYERROR CMD_2WAYOK CMD_2WAYQUEUED), @Net::Cmd::EXPORT);
  22
  23 sub CMD_2WAYERROR  () { 7 }
  24 sub CMD_2WAYOK     () { 8 }
  25 sub CMD_2WAYQUEUED () { 9 }
  26
  27 sub new
  28 {
  29  my $self = shift;
  30  my $type = ref($self) || $self;
  31  my $host = shift if @_ % 2;
  32  my %arg  = @_;
  33  my $hosts = defined $host ? [ $host ] : $NetConfig{snpp_hosts};
  34  my $obj;
  35
  36  my $h;
  37  foreach $h (@{$hosts})
  38   {
  39    $obj = $type->SUPER::new(PeerAddr => ($host = $h),
  40                             PeerPort => $arg{Port} || 'snpp(444)',
  41                             Proto    => 'tcp',
  42                             Timeout  => defined $arg{Timeout}
  43                                                 ? $arg{Timeout}
  44                                                 : 120
  45                             ) and last;
  46   }
  47
  48  return undef
  49         unless defined $obj;
  50
  51  ${*$obj}{'net_snpp_host'} = $host;
  52
  53  $obj->autoflush(1);
  54
  55  $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
  56
  57  unless ($obj->response() == CMD_OK)
  58   {
  59    $obj->close();
  60    return undef;
  61   }
  62
  63  $obj;
  64 }
  65
  66 ##
  67 ## User interface methods
  68 ##
  69
  70 sub pager_id
  71 {
  72  @_ == 2 or croak 'usage: $snpp->pager_id( PAGER_ID )';
  73  shift->_PAGE(@_);
  74 }
  75
  76 sub content
  77 {
  78  @_ == 2 or croak 'usage: $snpp->content( MESSAGE )';
  79  shift->_MESS(@_);
  80 }
  81
  82 sub send
  83 {
  84  my $me = shift;
  85
  86  if(@_)
  87   {
  88    my %arg = @_;
  89
  90    if(exists $arg{Pager})
  91     {
  92      my $pagers = ref($arg{Pager}) ? $arg{Pager} : [ $arg{Pager} ];
  93      my $pager;
  94      foreach $pager (@$pagers)
  95       {
  96        $me->_PAGE($pager) || return 0
  97       }
  98     }
  99
 100    $me->_MESS($arg{Message}) || return 0
 101         if(exists $arg{Message});
 102
 103    $me->hold($arg{Hold}) || return 0
 104         if(exists $arg{Hold});
 105
 106    $me->hold($arg{HoldLocal},1) || return 0
 107         if(exists $arg{HoldLocal});
 108
 109    $me->_COVE($arg{Coverage}) || return 0
 110         if(exists $arg{Coverage});
 111
 112    $me->_ALER($arg{Alert} ? 1 : 0) || return 0
 113         if(exists $arg{Alert});
 114
 115    $me->service_level($arg{ServiceLevel}) || return 0
 116         if(exists $arg{ServiceLevel});
 117   }
 118
 119  $me->_SEND();
 120 }
 121
 122 sub data
 123 {
 124  my $me = shift;
 125
 126  my $ok = $me->_DATA() && $me->datasend(@_);
 127
 128  return $ok
 129         unless($ok && @_);
 130
 131  $me->dataend;
 132 }
 133
 134 sub login
 135 {
 136  @_ == 2 || @_ == 3 or croak 'usage: $snpp->login( USER [, PASSWORD ])';
 137  shift->_LOGI(@_);
 138 }
 139
 140 sub help
 141 {
 142  @_ == 1 or croak 'usage: $snpp->help()';
 143  my $me = shift;
 144
 145  return $me->_HELP() ? $me->message
 146                      : undef;
 147 }
 148
 149 sub xwho
 150 {
 151  @_ == 1 or croak 'usage: $snpp->xwho()';
 152  my $me = shift;
 153
 154  $me->_XWHO or return undef;
 155
 156  my(%hash,$line);
 157  my @msg = $me->message;
 158  pop @msg; # Remove command complete line
 159
 160  foreach $line (@msg) {
 161    $line =~ /^\s*(\S+)\s*(.*)/ and $hash{$1} = $2;
 162  }
 163
 164  \%hash;
 165 }
 166
 167 sub service_level
 168 {
 169  @_ == 2 or croak 'usage: $snpp->service_level( LEVEL )';
 170  my $me = shift;
 171  my $level = int(shift);
 172
 173  if($level < 0 || $level > 11)
 174   {
 175    $me->set_status(550,"Invalid Service Level");
 176    return 0;
 177   }
 178
 179  $me->_LEVE($level);
 180 }
 181
 182 sub alert
 183 {
 184  @_ == 1 || @_ == 2 or croak 'usage: $snpp->alert( VALUE )';
 185  my $me = shift;
 186  my $value  = (@_ == 1 || shift) ? 1 : 0;
 187
 188  $me->_ALER($value);
 189 }
 190
 191 sub coverage
 192 {
 193  @_ == 1 or croak 'usage: $snpp->coverage( AREA )';
 194  shift->_COVE(@_);
 195 }
 196
 197 sub hold
 198 {
 199  @_ == 2 || @_ == 3 or croak 'usage: $snpp->hold( TIME [, LOCAL ] )';
 200  my $me = shift;
 201  my $time = shift;
 202  my $local = (shift) ? "" : " +0000";
 203
 204  my @g = reverse((gmtime($time))[0..5]);
 205  $g[1] += 1;
 206  $g[0] %= 100;
 207
 208  $me->_HOLD( sprintf("%02d%02d%02d%02d%02d%02d%s",@g,$local));
 209 }
 210
 211 sub caller_id
 212 {
 213  @_ == 2 or croak 'usage: $snpp->caller_id( CALLER_ID )';
 214  shift->_CALL(@_);
 215 }
 216
 217 sub subject
 218 {
 219  @_ == 2 or croak 'usage: $snpp->subject( SUBJECT )';
 220  shift->_SUBJ(@_);
 221 }
 222
 223 sub two_way
 224 {
 225  @_ == 1 or croak 'usage: $snpp->two_way()';
 226  shift->_2WAY();
 227 }
 228
 229 sub quit
 230 {
 231  @_ == 1 or croak 'usage: $snpp->quit()';
 232  my $snpp = shift;
 233
 234  $snpp->_QUIT;
 235  $snpp->close;
 236 }
 237
 238 ##
 239 ## IO/perl methods
 240 ##
 241
 242 sub DESTROY
 243 {
 244  my $snpp = shift;
 245  defined(fileno($snpp)) && $snpp->quit
 246 }
 247
 248 ##
 249 ## Over-ride methods (Net::Cmd)
 250 ##
 251
 252 sub debug_text
 253 {
 254  $_[2] =~ s/^((logi|page)\s+\S+\s+)\S+/$1 xxxx/io;
 255  $_[2];
 256 }
 257
 258 sub parse_response
 259 {
 260  return ()
 261     unless $_[1] =~ s/^(\d\d\d)(.?)//o;
 262  my($code,$more) = ($1, $2 eq "-");
 263
 264  $more ||= $code == 214;
 265
 266  ($code,$more);
 267 }
 268
 269 ##
 270 ## RFC1861 commands
 271 ##
 272
 273 # Level 1
 274
 275 sub _PAGE { shift->command("PAGE", @_)->response()  == CMD_OK }
 276 sub _MESS { shift->command("MESS", @_)->response()  == CMD_OK }
 277 sub _RESE { shift->command("RESE")->response()  == CMD_OK }
 278 sub _SEND { shift->command("SEND")->response()  == CMD_OK }
 279 sub _QUIT { shift->command("QUIT")->response()  == CMD_OK }
 280 sub _HELP { shift->command("HELP")->response()  == CMD_OK }
 281 sub _DATA { shift->command("DATA")->response()  == CMD_MORE }
 282 sub _SITE { shift->command("SITE",@_) }
 283
 284 # Level 2
 285
 286 sub _LOGI { shift->command("LOGI", @_)->response()  == CMD_OK }
 287 sub _LEVE { shift->command("LEVE", @_)->response()  == CMD_OK }
 288 sub _ALER { shift->command("ALER", @_)->response()  == CMD_OK }
 289 sub _COVE { shift->command("COVE", @_)->response()  == CMD_OK }
 290 sub _HOLD { shift->command("HOLD", @_)->response()  == CMD_OK }
 291 sub _CALL { shift->command("CALL", @_)->response()  == CMD_OK }
 292 sub _SUBJ { shift->command("SUBJ", @_)->response()  == CMD_OK }
 293
 294 # NonStandard
 295
 296 sub _XWHO { shift->command("XWHO")->response()  == CMD_OK }
 297
 298 1;
 299 __END__
 300
 301 =head1 NAME
 302
 303 Net::SNPP - Simple Network Pager Protocol Client
 304
 305 =head1 SYNOPSIS
 306
 307     use Net::SNPP;
 308
 309     # Constructors
 310     $snpp = Net::SNPP->new('snpphost');
 311     $snpp = Net::SNPP->new('snpphost', Timeout => 60);
 312
 313 =head1 NOTE
 314
 315 This module is not complete, yet !
 316
 317 =head1 DESCRIPTION
 318
 319 This module implements a client interface to the SNPP protocol, enabling
 320 a perl5 application to talk to SNPP servers. This documentation assumes
 321 that you are familiar with the SNPP protocol described in RFC1861.
 322
 323 A new Net::SNPP object must be created with the I<new> method. Once
 324 this has been done, all SNPP commands are accessed through this object.
 325
 326 =head1 EXAMPLES
 327
 328 This example will send a pager message in one hour saying "Your lunch is ready"
 329
 330     #!/usr/local/bin/perl -w
 331
 332     use Net::SNPP;
 333
 334     $snpp = Net::SNPP->new('snpphost');
 335
 336     $snpp->send( Pager   => $some_pager_number,
 337                  Message => "Your lunch is ready",
 338                  Alert   => 1,
 339                  Hold    => time + 3600, # lunch ready in 1 hour :-)
 340                ) || die $snpp->message;
 341
 342     $snpp->quit;
 343
 344 =head1 CONSTRUCTOR
 345
 346 =over 4
 347
 348 =item new ( [ HOST, ] [ OPTIONS ] )
 349
 350 This is the constructor for a new Net::SNPP object. C<HOST> is the
 351 name of the remote host to which a SNPP connection is required.
 352
 353 If C<HOST> is not given, then the C<SNPP_Host> specified in C<Net::Config>
 354 will be used.
 355
 356 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
 357 Possible options are:
 358
 359 B<Timeout> - Maximum time, in seconds, to wait for a response from the
 360 SNPP server (default: 120)
 361
 362 B<Debug> - Enable debugging information
 363
 364
 365 Example:
 366
 367
 368     $snpp = Net::SNPP->new('snpphost',
 369                            Debug => 1,
 370                           );
 371
 372 =head1 METHODS
 373
 374 Unless otherwise stated all methods return either a I<true> or I<false>
 375 value, with I<true> meaning that the operation was a success. When a method
 376 states that it returns a value, failure will be returned as I<undef> or an
 377 empty list.
 378
 379 =over 4
 380
 381 =item reset ()
 382
 383 =item help ()
 384
 385 Request help text from the server. Returns the text or undef upon failure
 386
 387 =item quit ()
 388
 389 Send the QUIT command to the remote SNPP server and close the socket connection.
 390
 391 =back
 392
 393 =head1 EXPORTS
 394
 395 C<Net::SNPP> exports all that C<Net::CMD> exports, plus three more subroutines
 396 that can bu used to compare against the result of C<status>. These are :-
 397 C<CMD_2WAYERROR>, C<CMD_2WAYOK>, and C<CMD_2WAYQUEUED>.
 398
 399 =head1 SEE ALSO
 400
 401 L<Net::Cmd>
 402 RFC1861
 403
 404 =head1 AUTHOR
 405
 406 Graham Barr <gbarr@pobox.com>
 407
 408 =head1 COPYRIGHT
 409
 410 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
 411 This program is free software; you can redistribute it and/or modify
 412 it under the same terms as Perl itself.
 413
 414 =cut