PageRenderTime 50ms CodeModel.GetById 5ms app.highlight 41ms RepoModel.GetById 1ms app.codeStats 0ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/site/lib/net/SNPP.pm

#
Perl | 414 lines | 278 code | 114 blank | 22 comment | 64 complexity | ef3f2f672b0084ad7e33c3703c23040c MD5 | raw file
  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
  7package Net::SNPP;
  8
  9require 5.001;
 10
 11use strict;
 12use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
 13use Socket 1.3;
 14use Carp;
 15use IO::Socket;
 16use Net::Cmd;
 17use 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
 23sub CMD_2WAYERROR  () { 7 }
 24sub CMD_2WAYOK     () { 8 }
 25sub CMD_2WAYQUEUED () { 9 }
 26
 27sub 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
 70sub pager_id
 71{
 72 @_ == 2 or croak 'usage: $snpp->pager_id( PAGER_ID )';
 73 shift->_PAGE(@_);
 74}
 75
 76sub content
 77{
 78 @_ == 2 or croak 'usage: $snpp->content( MESSAGE )';
 79 shift->_MESS(@_);
 80}
 81
 82sub 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
122sub 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
134sub login
135{
136 @_ == 2 || @_ == 3 or croak 'usage: $snpp->login( USER [, PASSWORD ])';
137 shift->_LOGI(@_);
138}
139
140sub help
141{
142 @_ == 1 or croak 'usage: $snpp->help()';
143 my $me = shift;
144
145 return $me->_HELP() ? $me->message
146		     : undef;
147}
148
149sub 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
167sub 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
182sub 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
191sub coverage
192{
193 @_ == 1 or croak 'usage: $snpp->coverage( AREA )';
194 shift->_COVE(@_);
195}
196
197sub 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
211sub caller_id
212{
213 @_ == 2 or croak 'usage: $snpp->caller_id( CALLER_ID )';
214 shift->_CALL(@_);
215}
216
217sub subject
218{
219 @_ == 2 or croak 'usage: $snpp->subject( SUBJECT )';
220 shift->_SUBJ(@_);
221}
222
223sub two_way
224{
225 @_ == 1 or croak 'usage: $snpp->two_way()';
226 shift->_2WAY();
227}
228
229sub 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
242sub DESTROY
243{
244 my $snpp = shift;
245 defined(fileno($snpp)) && $snpp->quit
246}
247
248##
249## Over-ride methods (Net::Cmd)
250##
251
252sub debug_text
253{
254 $_[2] =~ s/^((logi|page)\s+\S+\s+)\S+/$1 xxxx/io;
255 $_[2];
256}
257
258sub 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
275sub _PAGE { shift->command("PAGE", @_)->response()  == CMD_OK }   
276sub _MESS { shift->command("MESS", @_)->response()  == CMD_OK }   
277sub _RESE { shift->command("RESE")->response()  == CMD_OK }   
278sub _SEND { shift->command("SEND")->response()  == CMD_OK }   
279sub _QUIT { shift->command("QUIT")->response()  == CMD_OK }   
280sub _HELP { shift->command("HELP")->response()  == CMD_OK }   
281sub _DATA { shift->command("DATA")->response()  == CMD_MORE }   
282sub _SITE { shift->command("SITE",@_) }   
283
284# Level 2
285
286sub _LOGI { shift->command("LOGI", @_)->response()  == CMD_OK }   
287sub _LEVE { shift->command("LEVE", @_)->response()  == CMD_OK }   
288sub _ALER { shift->command("ALER", @_)->response()  == CMD_OK }   
289sub _COVE { shift->command("COVE", @_)->response()  == CMD_OK }   
290sub _HOLD { shift->command("HOLD", @_)->response()  == CMD_OK }   
291sub _CALL { shift->command("CALL", @_)->response()  == CMD_OK }   
292sub _SUBJ { shift->command("SUBJ", @_)->response()  == CMD_OK }   
293
294# NonStandard
295
296sub _XWHO { shift->command("XWHO")->response()  == CMD_OK }   
297
2981;
299__END__
300
301=head1 NAME
302
303Net::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
315This module is not complete, yet !
316
317=head1 DESCRIPTION
318
319This module implements a client interface to the SNPP protocol, enabling
320a perl5 application to talk to SNPP servers. This documentation assumes
321that you are familiar with the SNPP protocol described in RFC1861.
322
323A new Net::SNPP object must be created with the I<new> method. Once
324this has been done, all SNPP commands are accessed through this object.
325
326=head1 EXAMPLES
327
328This 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
350This is the constructor for a new Net::SNPP object. C<HOST> is the
351name of the remote host to which a SNPP connection is required.
352
353If C<HOST> is not given, then the C<SNPP_Host> specified in C<Net::Config>
354will be used.
355
356C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
357Possible options are:
358
359B<Timeout> - Maximum time, in seconds, to wait for a response from the
360SNPP server (default: 120)
361
362B<Debug> - Enable debugging information
363
364
365Example:
366
367
368    $snpp = Net::SNPP->new('snpphost',
369			   Debug => 1,
370			  );
371
372=head1 METHODS
373
374Unless otherwise stated all methods return either a I<true> or I<false>
375value, with I<true> meaning that the operation was a success. When a method
376states that it returns a value, failure will be returned as I<undef> or an
377empty list.
378
379=over 4
380
381=item reset ()
382
383=item help ()
384
385Request help text from the server. Returns the text or undef upon failure
386
387=item quit ()
388
389Send the QUIT command to the remote SNPP server and close the socket connection.
390
391=back
392
393=head1 EXPORTS
394
395C<Net::SNPP> exports all that C<Net::CMD> exports, plus three more subroutines
396that can bu used to compare against the result of C<status>. These are :-
397C<CMD_2WAYERROR>, C<CMD_2WAYOK>, and C<CMD_2WAYQUEUED>.
398
399=head1 SEE ALSO
400
401L<Net::Cmd>
402RFC1861
403
404=head1 AUTHOR
405
406Graham Barr <gbarr@pobox.com>
407
408=head1 COPYRIGHT
409
410Copyright (c) 1995-1997 Graham Barr. All rights reserved.
411This program is free software; you can redistribute it and/or modify
412it under the same terms as Perl itself.
413
414=cut