This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Initial integration of libnet-1.0703.
[perl5.git] / 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