+++ /dev/null
-#
-# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com> and
-# Alex Hristov <hristov@slb.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::PH;
-
-require 5.001;
-
-use strict;
-use vars qw(@ISA $VERSION);
-use Carp;
-
-use Socket 1.3;
-use IO::Socket;
-use Net::Cmd;
-use Net::Config;
-
-$VERSION = "2.20"; # $Id: //depot/libnet/Net/PH.pm#7$
-@ISA = qw(Exporter Net::Cmd IO::Socket::INET);
-
-sub new
-{
- my $pkg = shift;
- my $host = shift if @_ % 2;
- my %arg = @_;
- my $hosts = defined $host ? [ $host ] : $NetConfig{ph_hosts};
- my $ph;
-
- my $h;
- foreach $h (@{$hosts})
- {
- $ph = $pkg->SUPER::new(PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'csnet-ns(105)',
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- ) and last;
- }
-
- return undef
- unless defined $ph;
-
- ${*$ph}{'net_ph_host'} = $host;
-
- $ph->autoflush(1);
-
- $ph->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- $ph;
-}
-
-sub status
-{
- my $ph = shift;
-
- $ph->command('status')->response;
- $ph->code;
-}
-
-sub login
-{
- my $ph = shift;
- my($user,$pass,$encrypted) = @_;
- my $resp;
-
- $resp = $ph->command("login",$user)->response;
-
- if(defined($pass) && $resp == CMD_MORE)
- {
- if($encrypted)
- {
- my $challenge_str = $ph->message;
- chomp($challenge_str);
- Net::PH::crypt::crypt_start($pass);
- my $cryptstr = Net::PH::crypt::encryptit($challenge_str);
-
- $ph->command("answer", $cryptstr);
- }
- else
- {
- $ph->command("clear", $pass);
- }
- $resp = $ph->response;
- }
-
- $resp == CMD_OK;
-}
-
-sub logout
-{
- my $ph = shift;
-
- $ph->command("logout")->response == CMD_OK;
-}
-
-sub id
-{
- my $ph = shift;
- my $id = @_ ? shift : $<;
-
- $ph->command("id",$id)->response == CMD_OK;
-}
-
-sub siteinfo
-{
- my $ph = shift;
-
- $ph->command("siteinfo");
-
- my $ln;
- my %resp;
- my $cur_num = 0;
-
- while(defined($ln = $ph->getline))
- {
- $ph->debug_print(0,$ln)
- if ($ph->debug & 2);
- chomp($ln);
- my($code,$num,$tag,$data);
-
- if($ln =~ /^-(\d+):(\d+):(?:\s*([^:]+):)?\s*(.*)/o)
- {
- ($code,$num,$tag,$data) = ($1, $2, $3 || "",$4);
- $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result";
- }
- else
- {
- $ph->set_status($ph->parse_response($ln));
- return \%resp;
- }
- }
-
- return undef;
-}
-
-sub query
-{
- my $ph = shift;
- my $search = shift;
-
- my($k,$v);
-
- my @args = ('query', _arg_hash($search));
-
- push(@args,'return',_arg_list( shift ))
- if @_;
-
- unless($ph->command(@args)->response == CMD_INFO)
- {
- return $ph->code == 501
- ? []
- : undef;
- }
-
- my $ln;
- my @resp;
- my $cur_num = 0;
-
- my($last_tag);
-
- while(defined($ln = $ph->getline))
- {
- $ph->debug_print(0,$ln)
- if ($ph->debug & 2);
- chomp($ln);
- my($code,$idx,$num,$tag,$data);
-
- if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o)
- {
- ($code,$idx,$tag,$data) = ($1,$2,$3,$4);
- my $num = $idx - 1;
-
- $resp[$num] ||= {};
-
- $tag = $last_tag
- unless(length($tag));
-
- $last_tag = $tag;
-
- if(exists($resp[$num]->{$tag}))
- {
- $resp[$num]->{$tag}->[3] .= "\n" . $data;
- }
- else
- {
- $resp[$num]->{$tag} = bless [$code, $idx, $tag, $data], "Net::PH::Result";
- }
- }
- else
- {
- $ph->set_status($ph->parse_response($ln));
- return \@resp;
- }
- }
-
- return undef;
-}
-
-sub change
-{
- my $ph = shift;
- my $search = shift;
- my $make = shift;
-
- $ph->command(
- "change", _arg_hash($search),
- "make", _arg_hash($make)
- )->response == CMD_OK;
-}
-
-sub _arg_hash
-{
- my $hash = shift;
-
- return $hash
- unless(ref($hash));
-
- my($k,$v);
- my @r;
-
- while(($k,$v) = each %$hash)
- {
- my $a = $v;
- $a =~ s/\n/\\n/sog;
- $a =~ s/\t/\\t/sog;
- $a = '"' . $a . '"'
- if $a =~ /\W/;
- $a = '""'
- unless length $a;
-
- push(@r, "$k=$a");
- }
- join(" ", @r);
-}
-
-sub _arg_list
-{
- my $arr = shift;
-
- return $arr
- unless(ref($arr));
-
- my $v;
- my @r;
-
- foreach $v (@$arr)
- {
- my $a = $v;
- $a =~ s/\n/\\n/sog;
- $a =~ s/\t/\\t/sog;
- $a = '"' . $a . '"'
- if $a =~ /\W/;
- push(@r, $a);
- }
-
- join(" ",@r);
-}
-
-sub add
-{
- my $ph = shift;
- my $arg = @_ > 1 ? { @_ } : shift;
-
- $ph->command('add', _arg_hash($arg))->response == CMD_OK;
-}
-
-sub delete
-{
- my $ph = shift;
- my $arg = @_ > 1 ? { @_ } : shift;
-
- $ph->command('delete', _arg_hash($arg))->response == CMD_OK;
-}
-
-sub force
-{
- my $ph = shift;
- my $search = shift;
- my $force = shift;
-
- $ph->command(
- "change", _arg_hash($search),
- "force", _arg_hash($force)
- )->response == CMD_OK;
-}
-
-
-sub fields
-{
- my $ph = shift;
-
- $ph->command("fields", _arg_list(\@_));
-
- my $ln;
- my %resp;
- my $cur_num = 0;
- my @tags = ();
-
- while(defined($ln = $ph->getline))
- {
- $ph->debug_print(0,$ln)
- if ($ph->debug & 2);
- chomp($ln);
-
- my($code,$num,$tag,$data,$last_tag);
-
- if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o)
- {
- ($code,$num,$tag,$data) = ($1,$2,$3,$4);
-
- $tag = $last_tag
- unless(length($tag));
-
- $last_tag = $tag;
-
- if(exists $resp{$tag})
- {
- $resp{$tag}->[3] .= "\n" . $data;
- }
- else
- {
- $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result";
- push @tags, $tag;
- }
- }
- else
- {
- $ph->set_status($ph->parse_response($ln));
- return wantarray ? (\%resp, \@tags) : \%resp;
- }
- }
-
- return;
-}
-
-sub quit
-{
- my $ph = shift;
-
- $ph->close
- if $ph->command("quit")->response == CMD_OK;
-}
-
-##
-## Net::Cmd overrides
-##
-
-sub parse_response
-{
- return ()
- unless $_[1] =~ s/^(-?)(\d\d\d):?//o;
- ($2, $1 eq "-");
-}
-
-sub debug_text { $_[2] =~ /^(clear)/i ? "$1 ....\n" : $_[2]; }
-
-package Net::PH::Result;
-
-sub code { shift->[0] }
-sub value { shift->[1] }
-sub field { shift->[2] }
-sub text { shift->[3] }
-
-package Net::PH::crypt;
-
-# The code in this package is based upon 'cryptit.c', Copyright (C) 1988 by
-# Steven Dorner, and Paul Pomes, and the University of Illinois Board
-# of Trustees, and by CSNET.
-
-use integer;
-use strict;
-
-sub ROTORSZ () { 256 }
-sub MASK () { 255 }
-
-my(@t1,@t2,@t3,$n1,$n2);
-
-sub crypt_start {
- my $pass = shift;
- $n1 = 0;
- $n2 = 0;
- crypt_init($pass);
-}
-
-sub crypt_init {
- my $pw = shift;
- my $i;
-
- @t2 = @t3 = (0) x ROTORSZ;
-
- my $buf = crypt($pw,$pw);
- return -1 unless length($buf) > 0;
- $buf = substr($buf . "\0" x 13,0,13);
- my @buf = map { ord $_ } split(//, $buf);
-
-
- my $seed = 123;
- for($i = 0 ; $i < 13 ; $i++) {
- $seed = $seed * $buf[$i] + $i;
- }
- @t1 = (0 .. ROTORSZ-1);
-
- for($i = 0 ; $i < ROTORSZ ; $i++) {
- $seed = 5 * $seed + $buf[$i % 13];
- my $random = $seed % 65521;
- my $k = ROTORSZ - 1 - $i;
- my $ic = ($random & MASK) % ($k + 1);
- $random >>= 8;
- @t1[$k,$ic] = @t1[$ic,$k];
- next if $t3[$k] != 0;
- $ic = ($random & MASK) % $k;
- while($t3[$ic] != 0) {
- $ic = ($ic + 1) % $k;
- }
- $t3[$k] = $ic;
- $t3[$ic] = $k;
- }
- for($i = 0 ; $i < ROTORSZ ; $i++) {
- $t2[$t1[$i] & MASK] = $i
- }
-}
-
-sub encode {
- my $sp = shift;
- my $ch;
- my $n = scalar(@$sp);
- my @out = ($n);
- my $i;
-
- for($i = 0 ; $i < $n ; ) {
- my($f0,$f1,$f2) = splice(@$sp,0,3);
- push(@out,
- $f0 >> 2,
- ($f0 << 4) & 060 | ($f1 >> 4) & 017,
- ($f1 << 2) & 074 | ($f2 >> 6) & 03,
- $f2 & 077);
- $i += 3;
- }
- join("", map { chr((($_ & 077) + 35) & 0xff) } @out); # ord('#') == 35
-}
-
-sub encryptit {
- my $from = shift;
- my @from = map { ord $_ } split(//, $from);
- my @sp = ();
- my $ch;
- while(defined($ch = shift @from)) {
- push(@sp,
- $t2[($t3[($t1[($ch + $n1) & MASK] + $n2) & MASK] - $n2) & MASK] - $n1);
-
- $n1++;
- if($n1 == ROTORSZ) {
- $n1 = 0;
- $n2++;
- $n2 = 0 if $n2 == ROTORSZ;
- }
- }
- encode(\@sp);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::PH - CCSO Nameserver Client class
-
-=head1 SYNOPSIS
-
- use Net::PH;
-
- $ph = Net::PH->new("some.host.name",
- Port => 105,
- Timeout => 120,
- Debug => 0);
-
- if($ph) {
- $q = $ph->query({ field1 => "value1" },
- [qw(name address pobox)]);
-
- if($q) {
- }
- }
-
- # Alternative syntax
-
- if($ph) {
- $q = $ph->query('field1=value1',
- 'name address pobox');
-
- if($q) {
- }
- }
-
-=head1 DESCRIPTION
-
-C<Net::PH> is a class implementing a simple Nameserver/PH client in Perl
-as described in the CCSO Nameserver -- Server-Client Protocol. Like other
-modules in the Net:: family the C<Net::PH> object inherits methods from
-C<Net::Cmd>.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ])
-
- $ph = Net::PH->new("some.host.name",
- Port => 105,
- Timeout => 120,
- Debug => 0
- );
-
-This is the constructor for a new Net::PH object. C<HOST> is the
-name of the remote host to which a PH connection is required.
-
-If C<HOST> is not given, then the C<SNPP_Host> specified in C<Net::Config>
-will be used.
-
-C<OPTIONS> is an optional list of named options which are passed in
-a hash like fashion, using key and value pairs. Possible options are:-
-
-B<Port> - Port number to connect to on remote host.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-Nameserver, a value of zero will cause all IO operations to block.
-(default: 120)
-
-B<Debug> - Enable the printing of debugging information to STDERR
-
-=back
-
-=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 query( SEARCH [, RETURN ] )
-
- $q = $ph->query({ name => $myname },
- [qw(name email schedule)]);
-
- foreach $handle (@{$q}) {
- foreach $field (keys %{$handle}) {
- $c = ${$handle}{$field}->code;
- $v = ${$handle}{$field}->value;
- $f = ${$handle}{$field}->field;
- $t = ${$handle}{$field}->text;
- print "field:[$field] [$c][$v][$f][$t]\n" ;
- }
- }
-
-
-
-Search the database and return fields from all matching entries.
-
-The C<SEARCH> argument is a reference to a HASH which contains field/value
-pairs which will be passed to the Nameserver as the search criteria.
-
-C<RETURN> is optional, but if given it should be a reference to a list which
-contains field names to be returned.
-
-The alternative syntax is to pass strings instead of references, for example
-
- $q = $ph->query('name=myname',
- 'name email schedule');
-
-The C<SEARCH> argument is a string that is passed to the Nameserver as the
-search criteria. The strings being passed should B<not> contain any carriage
-returns, or else the query command might fail or return invalid data.
-
-C<RETURN> is optional, but if given it should be a string which will
-contain field names to be returned.
-
-Each match from the server will be returned as a HASH where the keys are the
-field names and the values are C<Net::PH:Result> objects (I<code>, I<value>,
-I<field>, I<text>).
-
-Returns a reference to an ARRAY which contains references to HASHs, one
-per match from the server.
-
-=item change( SEARCH , MAKE )
-
- $r = $ph->change({ email => "*.domain.name" },
- { schedule => "busy");
-
-Change field values for matching entries.
-
-The C<SEARCH> argument is a reference to a HASH which contains field/value
-pairs which will be passed to the Nameserver as the search criteria.
-
-The C<MAKE> argument is a reference to a HASH which contains field/value
-pairs which will be passed to the Nameserver that
-will set new values to designated fields.
-
-The alternative syntax is to pass strings instead of references, for example
-
- $r = $ph->change('email="*.domain.name"',
- 'schedule="busy"');
-
-The C<SEARCH> argument is a string to be passed to the Nameserver as the
-search criteria. The strings being passed should B<not> contain any carriage
-returns, or else the query command might fail or return invalid data.
-
-
-The C<MAKE> argument is a string to be passed to the Nameserver that
-will set new values to designated fields.
-
-Upon success all entries that match the search criteria will have
-the field values, given in the Make argument, changed.
-
-=item login( USER, PASS [, ENCRYPT ])
-
- $r = $ph->login('username','password',1);
-
-Enter login mode using C<USER> and C<PASS>. If C<ENCRYPT> is given and
-is I<true> then the password will be used to encrypt a challenge text
-string provided by the server, and the encrypted string will be sent back
-to the server. If C<ENCRYPT> is not given, or I<false> then the password
-will be sent in clear text (I<this is not recommended>)
-
-=item logout()
-
- $r = $ph->logout();
-
-Exit login mode and return to anonymous mode.
-
-=item fields( [ FIELD_LIST ] )
-
- $fields = $ph->fields();
- foreach $field (keys %{$fields}) {
- $c = ${$fields}{$field}->code;
- $v = ${$fields}{$field}->value;
- $f = ${$fields}{$field}->field;
- $t = ${$fields}{$field}->text;
- print "field:[$field] [$c][$v][$f][$t]\n";
- }
-
-In a scalar context, returns a reference to a HASH. The keys of the HASH are
-the field names and the values are C<Net::PH:Result> objects (I<code>,
-I<value>, I<field>, I<text>).
-
-In an array context, returns a two element array. The first element is a
-reference to a HASH as above, the second element is a reference to an array
-which contains the tag names in the order that they were returned from the
-server.
-
-C<FIELD_LIST> is a string that lists the fields for which info will be
-returned.
-
-=item add( FIELD_VALUES )
-
- $r = $ph->add( { name => $name, phone => $phone });
-
-This method is used to add new entries to the Nameserver database. You
-must successfully call L<login> before this method can be used.
-
-B<Note> that this method adds new entries to the database. To modify
-an existing entry use L<change>.
-
-C<FIELD_VALUES> is a reference to a HASH which contains field/value
-pairs which will be passed to the Nameserver and will be used to
-initialize the new entry.
-
-The alternative syntax is to pass a string instead of a reference, for example
-
- $r = $ph->add('name=myname phone=myphone');
-
-C<FIELD_VALUES> is a string that consists of field/value pairs which the
-new entry will contain. The strings being passed should B<not> contain any
-carriage returns, or else the query command might fail or return invalid data.
-
-
-=item delete( FIELD_VALUES )
-
- $r = $ph->delete('name=myname phone=myphone');
-
-This method is used to delete existing entries from the Nameserver database.
-You must successfully call L<login> before this method can be used.
-
-B<Note> that this method deletes entries to the database. To modify
-an existing entry use L<change>.
-
-C<FIELD_VALUES> is a string that serves as the search criteria for the
-records to be deleted. Any entry in the database which matches this search
-criteria will be deleted.
-
-=item id( [ ID ] )
-
- $r = $ph->id('709');
-
-Sends C<ID> to the Nameserver, which will enter this into its
-logs. If C<ID> is not given then the UID of the user running the
-process will be sent.
-
-=item status()
-
-Returns the current status of the Nameserver.
-
-=item siteinfo()
-
- $siteinfo = $ph->siteinfo();
- foreach $field (keys %{$siteinfo}) {
- $c = ${$siteinfo}{$field}->code;
- $v = ${$siteinfo}{$field}->value;
- $f = ${$siteinfo}{$field}->field;
- $t = ${$siteinfo}{$field}->text;
- print "field:[$field] [$c][$v][$f][$t]\n";
- }
-
-Returns a reference to a HASH containing information about the server's
-site. The keys of the HASH are the field names and values are
-C<Net::PH:Result> objects (I<code>, I<value>, I<field>, I<text>).
-
-=item quit()
-
- $r = $ph->quit();
-
-Quit the connection
-
-=back
-
-=head1 Q&A
-
-How do I get the values of a Net::PH::Result object?
-
- foreach $handle (@{$q}) {
- foreach $field (keys %{$handle}) {
- $my_code = ${$q}{$field}->code;
- $my_value = ${$q}{$field}->value;
- $my_field = ${$q}{$field}->field;
- $my_text = ${$q}{$field}->text;
- }
- }
-
-How do I get a count of the returned matches to my query?
-
- $my_count = scalar(@{$query_result});
-
-How do I get the status code and message of the last C<$ph> command?
-
- $status_code = $ph->code;
- $status_message = $ph->message;
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHORS
-
-Graham Barr <gbarr@pobox.com>
-Alex Hristov <hristov@slb.com>
-
-=head1 ACKNOWLEDGMENTS
-
-Password encryption code ported to perl by Broc Seib <bseib@purdue.edu>,
-Purdue University Computing Center.
-
-Otis Gospodnetic <otisg@panther.middlebury.edu> suggested
-passing parameters as string constants. Some queries cannot be
-executed when passing parameters as string references.
-
- Example: query first_name last_name email="*.domain"
-
-=head1 COPYRIGHT
-
-The encryption code is based upon cryptit.c, Copyright (C) 1988 by
-Steven Dorner, and Paul Pomes, and the University of Illinois Board
-of Trustees, and by CSNET.
-
-All other code is Copyright (c) 1996-1997 Graham Barr <gbarr@pobox.com>
-and Alex Hristov <hristov@slb.com>. All rights reserved. This program is
-free software; you can redistribute it and/or modify it under the same
-terms as Perl itself.
-
-=cut
+++ /dev/null
-# 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
https://perl5.git.perl.org / perl5.git / commitdiff