From: Jarkko Hietaniemi Date: Wed, 4 Jul 2001 14:10:38 +0000 (+0000) Subject: Remove DummyInetd, PH, and SNPP from the libnet, as per X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=54a2e5a8812e407952e539932c3f3087045174b0;p=p5sagit%2Fp5-mst-13.2.git Remove DummyInetd, PH, and SNPP from the libnet, as per Graham's request. p4raw-id: //depot/perl@11138 --- diff --git a/MANIFEST b/MANIFEST index 915dba8..1fcb0bf 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1004,7 +1004,6 @@ lib/Net/demos/smtp.self libnet lib/Net/demos/snpp libnet lib/Net/demos/time libnet lib/Net/Domain.pm libnet -lib/Net/DummyInetd.pm libnet lib/Net/FTP.pm libnet lib/Net/FTP/A.pm libnet lib/Net/FTP/dataconn.pm libnet @@ -1020,7 +1019,6 @@ lib/Net/netent.pm By-name interface to Perl's builtin getnet* lib/Net/netent.t See if Net::netent works lib/Net/Netrc.pm libnet lib/Net/NNTP.pm libnet -lib/Net/PH.pm libnet lib/Net/Ping.pm Hello, anybody home? lib/Net/POP3.pm libnet lib/Net/protoent.pm By-name interface to Perl's builtin getproto* @@ -1030,7 +1028,6 @@ lib/Net/README.libnet libnet lib/Net/servent.pm By-name interface to Perl's builtin getserv* lib/Net/servent.t See if Net::servtent works lib/Net/SMTP.pm libnet -lib/Net/SNPP.pm libnet lib/Net/t/ftp.t libnet lib/Net/t/hostname.t libnet lib/Net/t/nntp.t libnet diff --git a/lib/Net/DummyInetd.pm b/lib/Net/DummyInetd.pm deleted file mode 100644 index 2ffddf7..0000000 --- a/lib/Net/DummyInetd.pm +++ /dev/null @@ -1,148 +0,0 @@ -# Net::DummyInetd.pm -# -# 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. - -package Net::DummyInetd; - -require 5.002; - -use IO::Handle; -use IO::Socket; -use strict; -use vars qw($VERSION); -use Carp; - -$VERSION = do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r}; - - -sub _process -{ - my $listen = shift; - my @cmd = @_; - my $vec = ''; - my $r; - - vec($vec,fileno($listen),1) = 1; - - while(select($r=$vec,undef,undef,undef)) - { - my $sock = $listen->accept; - my $pid; - - if($pid = fork()) - { - sleep 1; - close($sock); - } - elsif(defined $pid) - { - my $x = IO::Handle->new_from_fd($sock,"r"); - open(STDIN,"<&=".fileno($x)) || die "$! $@"; - close($x); - - my $y = IO::Handle->new_from_fd($sock,"w"); - open(STDOUT,">&=".fileno($y)) || die "$! $@"; - close($y); - - close($sock); - exec(@cmd) || carp "$! $@"; - } - else - { - close($sock); - carp $!; - } - } - exit -1; -} - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - - my $listen = IO::Socket::INET->new(Listen => 5, Proto => 'tcp'); - my $pid; - - return bless [ $listen->sockport, $pid ] - if($pid = fork()); - - _process($listen,@_); -} - -sub port -{ - my $self = shift; - $self->[0]; -} - -sub DESTROY -{ - my $self = shift; - kill 9, $self->[1]; -} - -1; - -__END__ - -=head1 NAME - -Net::DummyInetd - A dummy Inetd server - -=head1 SYNOPSIS - - use Net::DummyInetd; - use Net::SMTP; - - $inetd = new Net::DummyInetd qw(/usr/lib/sendmail -ba -bs); - - $smtp = Net::SMTP->new('localhost', Port => $inetd->port); - -=head1 DESCRIPTION - -C is just what its name says, it is a dummy inetd server. -Creation of a C will cause a child process to be spawned off -which will listen to a socket. When a connection arrives on this socket -the specified command is fork'd and exec'd with STDIN and STDOUT file -descriptors duplicated to the new socket. - -This package was added as an example of how to use C to connect -to a C process, which is not the default, via SIDIN and STDOUT. -A C package will be available in the next release of C - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( CMD ) - -Creates a new object and spawns a child process which listens to a socket. -C is a list, which will be passed to C when a new process needs -to be created. - -=back - -=head1 METHODS - -=over 4 - -=item port - -Returns the port number on which the I object is listening - -=back - -=head1 AUTHOR - -Graham Barr - -=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 diff --git a/lib/Net/PH.pm b/lib/Net/PH.pm deleted file mode 100644 index d245b5c..0000000 --- a/lib/Net/PH.pm +++ /dev/null @@ -1,784 +0,0 @@ -# -# Copyright (c) 1995-1997 Graham Barr and -# Alex Hristov . 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 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 object inherits methods from -C. - -=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 is the -name of the remote host to which a PH connection is required. - -If C is not given, then the C specified in C -will be used. - -C 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 number to connect to on remote host. - -B - 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 - Enable the printing of debugging information to STDERR - -=back - -=head1 METHODS - -Unless otherwise stated all methods return either a I or I -value, with I meaning that the operation was a success. When a method -states that it returns a value, failure will be returned as I 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 argument is a reference to a HASH which contains field/value -pairs which will be passed to the Nameserver as the search criteria. - -C 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 argument is a string that is passed to the Nameserver as the -search criteria. The strings being passed should B contain any carriage -returns, or else the query command might fail or return invalid data. - -C 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 objects (I, I, -I, I). - -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 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 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 argument is a string to be passed to the Nameserver as the -search criteria. The strings being passed should B contain any carriage -returns, or else the query command might fail or return invalid data. - - -The C 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 and C. If C is given and -is I 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 is not given, or I then the password -will be sent in clear text (I) - -=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 objects (I, -I, I, I). - -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 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 before this method can be used. - -B that this method adds new entries to the database. To modify -an existing entry use L. - -C 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 is a string that consists of field/value pairs which the -new entry will contain. The strings being passed should B 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 before this method can be used. - -B that this method deletes entries to the database. To modify -an existing entry use L. - -C 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 to the Nameserver, which will enter this into its -logs. If C 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 objects (I, I, I, I). - -=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 - -=head1 AUTHORS - -Graham Barr -Alex Hristov - -=head1 ACKNOWLEDGMENTS - -Password encryption code ported to perl by Broc Seib , -Purdue University Computing Center. - -Otis Gospodnetic 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 -and Alex Hristov . All rights reserved. This program is -free software; you can redistribute it and/or modify it under the same -terms as Perl itself. - -=cut diff --git a/lib/Net/SNPP.pm b/lib/Net/SNPP.pm deleted file mode 100644 index 60781b3..0000000 --- a/lib/Net/SNPP.pm +++ /dev/null @@ -1,414 +0,0 @@ -# Net::SNPP.pm -# -# 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. - -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 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 is the -name of the remote host to which a SNPP connection is required. - -If C is not given, then the C specified in C -will be used. - -C are passed in a hash like fashion, using key and value pairs. -Possible options are: - -B - Maximum time, in seconds, to wait for a response from the -SNPP server (default: 120) - -B - Enable debugging information - - -Example: - - - $snpp = Net::SNPP->new('snpphost', - Debug => 1, - ); - -=head1 METHODS - -Unless otherwise stated all methods return either a I or I -value, with I meaning that the operation was a success. When a method -states that it returns a value, failure will be returned as I 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 exports all that C exports, plus three more subroutines -that can bu used to compare against the result of C. These are :- -C, C, and C. - -=head1 SEE ALSO - -L -RFC1861 - -=head1 AUTHOR - -Graham Barr - -=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