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