2 # Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com> and
3 # Alex Hristov <hristov@slb.com>. All rights reserved. This program is free
4 # software; you can redistribute it and/or modify it under the same terms
12 use vars qw(@ISA $VERSION);
20 $VERSION = "2.20"; # $Id: //depot/libnet/Net/PH.pm#7$
21 @ISA = qw(Exporter Net::Cmd IO::Socket::INET);
26 my $host = shift if @_ % 2;
28 my $hosts = defined $host ? [ $host ] : $NetConfig{ph_hosts};
32 foreach $h (@{$hosts})
34 $ph = $pkg->SUPER::new(PeerAddr => ($host = $h),
35 PeerPort => $arg{Port} || 'csnet-ns(105)',
37 Timeout => defined $arg{Timeout}
46 ${*$ph}{'net_ph_host'} = $host;
50 $ph->debug(exists $arg{Debug} ? $arg{Debug} : undef);
59 $ph->command('status')->response;
66 my($user,$pass,$encrypted) = @_;
69 $resp = $ph->command("login",$user)->response;
71 if(defined($pass) && $resp == CMD_MORE)
75 my $challenge_str = $ph->message;
76 chomp($challenge_str);
77 Net::PH::crypt::crypt_start($pass);
78 my $cryptstr = Net::PH::crypt::encryptit($challenge_str);
80 $ph->command("answer", $cryptstr);
84 $ph->command("clear", $pass);
86 $resp = $ph->response;
96 $ph->command("logout")->response == CMD_OK;
102 my $id = @_ ? shift : $<;
104 $ph->command("id",$id)->response == CMD_OK;
111 $ph->command("siteinfo");
117 while(defined($ln = $ph->getline))
119 $ph->debug_print(0,$ln)
122 my($code,$num,$tag,$data);
124 if($ln =~ /^-(\d+):(\d+):(?:\s*([^:]+):)?\s*(.*)/o)
126 ($code,$num,$tag,$data) = ($1, $2, $3 || "",$4);
127 $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result";
131 $ph->set_status($ph->parse_response($ln));
146 my @args = ('query', _arg_hash($search));
148 push(@args,'return',_arg_list( shift ))
151 unless($ph->command(@args)->response == CMD_INFO)
153 return $ph->code == 501
164 while(defined($ln = $ph->getline))
166 $ph->debug_print(0,$ln)
169 my($code,$idx,$num,$tag,$data);
171 if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o)
173 ($code,$idx,$tag,$data) = ($1,$2,$3,$4);
179 unless(length($tag));
183 if(exists($resp[$num]->{$tag}))
185 $resp[$num]->{$tag}->[3] .= "\n" . $data;
189 $resp[$num]->{$tag} = bless [$code, $idx, $tag, $data], "Net::PH::Result";
194 $ph->set_status($ph->parse_response($ln));
209 "change", _arg_hash($search),
210 "make", _arg_hash($make)
211 )->response == CMD_OK;
224 while(($k,$v) = each %$hash)
265 my $arg = @_ > 1 ? { @_ } : shift;
267 $ph->command('add', _arg_hash($arg))->response == CMD_OK;
273 my $arg = @_ > 1 ? { @_ } : shift;
275 $ph->command('delete', _arg_hash($arg))->response == CMD_OK;
285 "change", _arg_hash($search),
286 "force", _arg_hash($force)
287 )->response == CMD_OK;
295 $ph->command("fields", _arg_list(\@_));
302 while(defined($ln = $ph->getline))
304 $ph->debug_print(0,$ln)
308 my($code,$num,$tag,$data,$last_tag);
310 if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o)
312 ($code,$num,$tag,$data) = ($1,$2,$3,$4);
315 unless(length($tag));
319 if(exists $resp{$tag})
321 $resp{$tag}->[3] .= "\n" . $data;
325 $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result";
331 $ph->set_status($ph->parse_response($ln));
332 return wantarray ? (\%resp, \@tags) : \%resp;
344 if $ph->command("quit")->response == CMD_OK;
348 ## Net::Cmd overrides
354 unless $_[1] =~ s/^(-?)(\d\d\d):?//o;
358 sub debug_text { $_[2] =~ /^(clear)/i ? "$1 ....\n" : $_[2]; }
360 package Net::PH::Result;
362 sub code { shift->[0] }
363 sub value { shift->[1] }
364 sub field { shift->[2] }
365 sub text { shift->[3] }
367 package Net::PH::crypt;
369 # The code in this package is based upon 'cryptit.c', Copyright (C) 1988 by
370 # Steven Dorner, and Paul Pomes, and the University of Illinois Board
371 # of Trustees, and by CSNET.
376 sub ROTORSZ () { 256 }
379 my(@t1,@t2,@t3,$n1,$n2);
392 @t2 = @t3 = (0) x ROTORSZ;
394 my $buf = crypt($pw,$pw);
395 return -1 unless length($buf) > 0;
396 $buf = substr($buf . "\0" x 13,0,13);
397 my @buf = map { ord $_ } split(//, $buf);
401 for($i = 0 ; $i < 13 ; $i++) {
402 $seed = $seed * $buf[$i] + $i;
404 @t1 = (0 .. ROTORSZ-1);
406 for($i = 0 ; $i < ROTORSZ ; $i++) {
407 $seed = 5 * $seed + $buf[$i % 13];
408 my $random = $seed % 65521;
409 my $k = ROTORSZ - 1 - $i;
410 my $ic = ($random & MASK) % ($k + 1);
412 @t1[$k,$ic] = @t1[$ic,$k];
413 next if $t3[$k] != 0;
414 $ic = ($random & MASK) % $k;
415 while($t3[$ic] != 0) {
416 $ic = ($ic + 1) % $k;
421 for($i = 0 ; $i < ROTORSZ ; $i++) {
422 $t2[$t1[$i] & MASK] = $i
429 my $n = scalar(@$sp);
433 for($i = 0 ; $i < $n ; ) {
434 my($f0,$f1,$f2) = splice(@$sp,0,3);
437 ($f0 << 4) & 060 | ($f1 >> 4) & 017,
438 ($f1 << 2) & 074 | ($f2 >> 6) & 03,
442 join("", map { chr((($_ & 077) + 35) & 0xff) } @out); # ord('#') == 35
447 my @from = map { ord $_ } split(//, $from);
450 while(defined($ch = shift @from)) {
452 $t2[($t3[($t1[($ch + $n1) & MASK] + $n2) & MASK] - $n2) & MASK] - $n1);
458 $n2 = 0 if $n2 == ROTORSZ;
470 Net::PH - CCSO Nameserver Client class
476 $ph = Net::PH->new("some.host.name",
482 $q = $ph->query({ field1 => "value1" },
483 [qw(name address pobox)]);
492 $q = $ph->query('field1=value1',
493 'name address pobox');
501 C<Net::PH> is a class implementing a simple Nameserver/PH client in Perl
502 as described in the CCSO Nameserver -- Server-Client Protocol. Like other
503 modules in the Net:: family the C<Net::PH> object inherits methods from
510 =item new ( [ HOST ] [, OPTIONS ])
512 $ph = Net::PH->new("some.host.name",
518 This is the constructor for a new Net::PH object. C<HOST> is the
519 name of the remote host to which a PH connection is required.
521 If C<HOST> is not given, then the C<SNPP_Host> specified in C<Net::Config>
524 C<OPTIONS> is an optional list of named options which are passed in
525 a hash like fashion, using key and value pairs. Possible options are:-
527 B<Port> - Port number to connect to on remote host.
529 B<Timeout> - Maximum time, in seconds, to wait for a response from the
530 Nameserver, a value of zero will cause all IO operations to block.
533 B<Debug> - Enable the printing of debugging information to STDERR
539 Unless otherwise stated all methods return either a I<true> or I<false>
540 value, with I<true> meaning that the operation was a success. When a method
541 states that it returns a value, failure will be returned as I<undef> or an
546 =item query( SEARCH [, RETURN ] )
548 $q = $ph->query({ name => $myname },
549 [qw(name email schedule)]);
551 foreach $handle (@{$q}) {
552 foreach $field (keys %{$handle}) {
553 $c = ${$handle}{$field}->code;
554 $v = ${$handle}{$field}->value;
555 $f = ${$handle}{$field}->field;
556 $t = ${$handle}{$field}->text;
557 print "field:[$field] [$c][$v][$f][$t]\n" ;
563 Search the database and return fields from all matching entries.
565 The C<SEARCH> argument is a reference to a HASH which contains field/value
566 pairs which will be passed to the Nameserver as the search criteria.
568 C<RETURN> is optional, but if given it should be a reference to a list which
569 contains field names to be returned.
571 The alternative syntax is to pass strings instead of references, for example
573 $q = $ph->query('name=myname',
574 'name email schedule');
576 The C<SEARCH> argument is a string that is passed to the Nameserver as the
577 search criteria. The strings being passed should B<not> contain any carriage
578 returns, or else the query command might fail or return invalid data.
580 C<RETURN> is optional, but if given it should be a string which will
581 contain field names to be returned.
583 Each match from the server will be returned as a HASH where the keys are the
584 field names and the values are C<Net::PH:Result> objects (I<code>, I<value>,
587 Returns a reference to an ARRAY which contains references to HASHs, one
588 per match from the server.
590 =item change( SEARCH , MAKE )
592 $r = $ph->change({ email => "*.domain.name" },
593 { schedule => "busy");
595 Change field values for matching entries.
597 The C<SEARCH> argument is a reference to a HASH which contains field/value
598 pairs which will be passed to the Nameserver as the search criteria.
600 The C<MAKE> argument is a reference to a HASH which contains field/value
601 pairs which will be passed to the Nameserver that
602 will set new values to designated fields.
604 The alternative syntax is to pass strings instead of references, for example
606 $r = $ph->change('email="*.domain.name"',
609 The C<SEARCH> argument is a string to be passed to the Nameserver as the
610 search criteria. The strings being passed should B<not> contain any carriage
611 returns, or else the query command might fail or return invalid data.
614 The C<MAKE> argument is a string to be passed to the Nameserver that
615 will set new values to designated fields.
617 Upon success all entries that match the search criteria will have
618 the field values, given in the Make argument, changed.
620 =item login( USER, PASS [, ENCRYPT ])
622 $r = $ph->login('username','password',1);
624 Enter login mode using C<USER> and C<PASS>. If C<ENCRYPT> is given and
625 is I<true> then the password will be used to encrypt a challenge text
626 string provided by the server, and the encrypted string will be sent back
627 to the server. If C<ENCRYPT> is not given, or I<false> then the password
628 will be sent in clear text (I<this is not recommended>)
634 Exit login mode and return to anonymous mode.
636 =item fields( [ FIELD_LIST ] )
638 $fields = $ph->fields();
639 foreach $field (keys %{$fields}) {
640 $c = ${$fields}{$field}->code;
641 $v = ${$fields}{$field}->value;
642 $f = ${$fields}{$field}->field;
643 $t = ${$fields}{$field}->text;
644 print "field:[$field] [$c][$v][$f][$t]\n";
647 In a scalar context, returns a reference to a HASH. The keys of the HASH are
648 the field names and the values are C<Net::PH:Result> objects (I<code>,
649 I<value>, I<field>, I<text>).
651 In an array context, returns a two element array. The first element is a
652 reference to a HASH as above, the second element is a reference to an array
653 which contains the tag names in the order that they were returned from the
656 C<FIELD_LIST> is a string that lists the fields for which info will be
659 =item add( FIELD_VALUES )
661 $r = $ph->add( { name => $name, phone => $phone });
663 This method is used to add new entries to the Nameserver database. You
664 must successfully call L<login> before this method can be used.
666 B<Note> that this method adds new entries to the database. To modify
667 an existing entry use L<change>.
669 C<FIELD_VALUES> is a reference to a HASH which contains field/value
670 pairs which will be passed to the Nameserver and will be used to
671 initialize the new entry.
673 The alternative syntax is to pass a string instead of a reference, for example
675 $r = $ph->add('name=myname phone=myphone');
677 C<FIELD_VALUES> is a string that consists of field/value pairs which the
678 new entry will contain. The strings being passed should B<not> contain any
679 carriage returns, or else the query command might fail or return invalid data.
682 =item delete( FIELD_VALUES )
684 $r = $ph->delete('name=myname phone=myphone');
686 This method is used to delete existing entries from the Nameserver database.
687 You must successfully call L<login> before this method can be used.
689 B<Note> that this method deletes entries to the database. To modify
690 an existing entry use L<change>.
692 C<FIELD_VALUES> is a string that serves as the search criteria for the
693 records to be deleted. Any entry in the database which matches this search
694 criteria will be deleted.
700 Sends C<ID> to the Nameserver, which will enter this into its
701 logs. If C<ID> is not given then the UID of the user running the
702 process will be sent.
706 Returns the current status of the Nameserver.
710 $siteinfo = $ph->siteinfo();
711 foreach $field (keys %{$siteinfo}) {
712 $c = ${$siteinfo}{$field}->code;
713 $v = ${$siteinfo}{$field}->value;
714 $f = ${$siteinfo}{$field}->field;
715 $t = ${$siteinfo}{$field}->text;
716 print "field:[$field] [$c][$v][$f][$t]\n";
719 Returns a reference to a HASH containing information about the server's
720 site. The keys of the HASH are the field names and values are
721 C<Net::PH:Result> objects (I<code>, I<value>, I<field>, I<text>).
733 How do I get the values of a Net::PH::Result object?
735 foreach $handle (@{$q}) {
736 foreach $field (keys %{$handle}) {
737 $my_code = ${$q}{$field}->code;
738 $my_value = ${$q}{$field}->value;
739 $my_field = ${$q}{$field}->field;
740 $my_text = ${$q}{$field}->text;
744 How do I get a count of the returned matches to my query?
746 $my_count = scalar(@{$query_result});
748 How do I get the status code and message of the last C<$ph> command?
750 $status_code = $ph->code;
751 $status_message = $ph->message;
759 Graham Barr <gbarr@pobox.com>
760 Alex Hristov <hristov@slb.com>
762 =head1 ACKNOWLEDGMENTS
764 Password encryption code ported to perl by Broc Seib <bseib@purdue.edu>,
765 Purdue University Computing Center.
767 Otis Gospodnetic <otisg@panther.middlebury.edu> suggested
768 passing parameters as string constants. Some queries cannot be
769 executed when passing parameters as string references.
771 Example: query first_name last_name email="*.domain"
775 The encryption code is based upon cryptit.c, Copyright (C) 1988 by
776 Steven Dorner, and Paul Pomes, and the University of Illinois Board
777 of Trustees, and by CSNET.
779 All other code is Copyright (c) 1996-1997 Graham Barr <gbarr@pobox.com>
780 and Alex Hristov <hristov@slb.com>. All rights reserved. This program is
781 free software; you can redistribute it and/or modify it under the same
782 terms as Perl itself.