This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Initial integration of libnet-1.0703.
[perl5.git] / lib / Net / PH.pm
1 #
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
5 # as Perl itself.
6
7 package Net::PH;
8
9 require 5.001;
10
11 use strict;
12 use vars qw(@ISA $VERSION);
13 use Carp;
14
15 use Socket 1.3;
16 use IO::Socket;
17 use Net::Cmd;
18 use Net::Config;
19
20 $VERSION = "2.20"; # $Id: //depot/libnet/Net/PH.pm#7$
21 @ISA     = qw(Exporter Net::Cmd IO::Socket::INET);
22
23 sub new
24 {
25  my $pkg  = shift;
26  my $host = shift if @_ % 2;
27  my %arg  = @_; 
28  my $hosts = defined $host ? [ $host ] : $NetConfig{ph_hosts};
29  my $ph;
30
31  my $h;
32  foreach $h (@{$hosts})
33   {
34    $ph = $pkg->SUPER::new(PeerAddr => ($host = $h), 
35                           PeerPort => $arg{Port} || 'csnet-ns(105)',
36                           Proto    => 'tcp',
37                           Timeout  => defined $arg{Timeout}
38                                         ? $arg{Timeout}
39                                         : 120
40                          ) and last;
41   }
42
43  return undef
44         unless defined $ph;
45
46  ${*$ph}{'net_ph_host'} = $host;
47
48  $ph->autoflush(1);
49
50  $ph->debug(exists $arg{Debug} ? $arg{Debug} : undef);
51
52  $ph;
53 }
54
55 sub status
56 {
57  my $ph = shift;
58
59  $ph->command('status')->response;
60  $ph->code;
61 }
62
63 sub login
64 {
65  my $ph = shift;
66  my($user,$pass,$encrypted) = @_;
67  my $resp;
68
69  $resp = $ph->command("login",$user)->response;
70
71  if(defined($pass) && $resp == CMD_MORE)
72   {
73    if($encrypted)
74     {
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);
79
80      $ph->command("answer", $cryptstr);
81     }
82    else
83     {
84      $ph->command("clear", $pass);
85     }
86    $resp = $ph->response;
87   }
88
89  $resp == CMD_OK;
90 }
91
92 sub logout
93 {
94  my $ph = shift;
95
96  $ph->command("logout")->response == CMD_OK;
97 }
98
99 sub id
100 {
101  my $ph = shift;
102  my $id = @_ ? shift : $<;
103
104  $ph->command("id",$id)->response == CMD_OK;
105 }
106
107 sub siteinfo
108 {
109  my $ph = shift;
110
111  $ph->command("siteinfo");
112
113  my $ln;
114  my %resp;
115  my $cur_num = 0;
116
117  while(defined($ln = $ph->getline))
118   {
119    $ph->debug_print(0,$ln)
120      if ($ph->debug & 2);
121    chomp($ln);
122    my($code,$num,$tag,$data);
123
124    if($ln =~ /^-(\d+):(\d+):(?:\s*([^:]+):)?\s*(.*)/o)
125     {
126      ($code,$num,$tag,$data) = ($1, $2, $3 || "",$4);
127      $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result";
128     }
129    else
130     {
131      $ph->set_status($ph->parse_response($ln));
132      return \%resp;
133     }
134   }
135
136  return undef;
137 }
138
139 sub query
140 {
141  my $ph = shift;
142  my $search = shift;
143
144  my($k,$v);
145
146  my @args = ('query', _arg_hash($search));
147
148  push(@args,'return',_arg_list( shift ))
149         if @_;
150
151  unless($ph->command(@args)->response == CMD_INFO)
152   {
153    return $ph->code == 501
154         ? []
155         : undef;
156   }
157
158  my $ln;
159  my @resp;
160  my $cur_num = 0;
161
162  my($last_tag);
163
164  while(defined($ln = $ph->getline))
165   {
166    $ph->debug_print(0,$ln)
167      if ($ph->debug & 2);
168    chomp($ln);
169    my($code,$idx,$num,$tag,$data);
170
171    if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o)
172     {
173      ($code,$idx,$tag,$data) = ($1,$2,$3,$4);
174      my $num = $idx - 1;
175
176      $resp[$num] ||= {};
177
178      $tag = $last_tag
179         unless(length($tag));
180
181      $last_tag = $tag;
182
183      if(exists($resp[$num]->{$tag}))
184       {
185        $resp[$num]->{$tag}->[3] .= "\n" . $data;
186       }
187      else
188       {
189        $resp[$num]->{$tag} = bless [$code, $idx, $tag, $data], "Net::PH::Result";
190       }
191     }
192    else
193     {
194      $ph->set_status($ph->parse_response($ln));
195      return \@resp;
196     }
197   }
198
199  return undef;
200 }
201
202 sub change
203 {
204  my $ph = shift;
205  my $search = shift;
206  my $make = shift;
207
208  $ph->command(
209         "change", _arg_hash($search),
210         "make",   _arg_hash($make)
211  )->response == CMD_OK;
212 }
213
214 sub _arg_hash
215 {
216  my $hash = shift;
217
218  return $hash
219         unless(ref($hash));
220
221  my($k,$v);
222  my @r;
223
224  while(($k,$v) = each %$hash)
225   {
226    my $a = $v;
227    $a =~ s/\n/\\n/sog;
228    $a =~ s/\t/\\t/sog;
229    $a = '"' . $a . '"'
230         if $a =~ /\W/;
231    $a = '""'
232         unless length $a;
233
234    push(@r, "$k=$a");   
235   }
236  join(" ", @r);
237 }
238
239 sub _arg_list
240 {
241  my $arr = shift;
242
243  return $arr
244         unless(ref($arr));
245
246  my $v;
247  my @r;
248
249  foreach $v (@$arr)
250   {
251    my $a = $v;
252    $a =~ s/\n/\\n/sog;
253    $a =~ s/\t/\\t/sog;
254    $a = '"' . $a . '"'
255         if $a =~ /\W/;
256    push(@r, $a);   
257   }
258
259  join(" ",@r);
260 }
261
262 sub add
263 {
264  my $ph = shift;
265  my $arg = @_ > 1 ? { @_ } : shift;
266
267  $ph->command('add', _arg_hash($arg))->response == CMD_OK;
268 }
269
270 sub delete
271 {
272  my $ph = shift;
273  my $arg = @_ > 1 ? { @_ } : shift;
274
275  $ph->command('delete', _arg_hash($arg))->response == CMD_OK;
276 }
277
278 sub force
279 {
280  my $ph = shift; 
281  my $search = shift;
282  my $force = shift;
283
284  $ph->command(
285         "change", _arg_hash($search),
286         "force",  _arg_hash($force)
287  )->response == CMD_OK;
288 }
289
290
291 sub fields
292 {
293  my $ph = shift;
294
295  $ph->command("fields", _arg_list(\@_));
296
297  my $ln;
298  my %resp;
299  my $cur_num = 0;
300  my @tags = ();
301  
302  while(defined($ln = $ph->getline))
303   {
304    $ph->debug_print(0,$ln)
305      if ($ph->debug & 2);
306    chomp($ln);
307
308    my($code,$num,$tag,$data,$last_tag);
309
310    if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o)
311     {
312      ($code,$num,$tag,$data) = ($1,$2,$3,$4);
313
314      $tag = $last_tag
315         unless(length($tag));
316
317      $last_tag = $tag;
318
319      if(exists $resp{$tag})
320       {
321        $resp{$tag}->[3] .= "\n" . $data;
322       }
323      else
324       {
325        $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result";
326        push @tags, $tag;
327       }
328     }
329    else
330     {
331      $ph->set_status($ph->parse_response($ln));
332      return wantarray ? (\%resp, \@tags) : \%resp;
333     }
334   }
335
336  return;
337 }
338
339 sub quit
340 {
341  my $ph = shift;
342
343  $ph->close
344         if $ph->command("quit")->response == CMD_OK;
345 }
346
347 ##
348 ## Net::Cmd overrides
349 ##
350
351 sub parse_response
352 {
353  return ()
354     unless $_[1] =~ s/^(-?)(\d\d\d):?//o;
355  ($2, $1 eq "-");
356 }
357
358 sub debug_text { $_[2] =~ /^(clear)/i ? "$1 ....\n" : $_[2]; }
359
360 package Net::PH::Result;
361
362 sub code  { shift->[0] }
363 sub value { shift->[1] }
364 sub field { shift->[2] }
365 sub text  { shift->[3] }
366
367 package Net::PH::crypt;
368
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.
372
373 use integer;
374 use strict;
375  
376 sub ROTORSZ () { 256 }
377 sub MASK () { 255 }
378
379 my(@t1,@t2,@t3,$n1,$n2);
380
381 sub crypt_start {
382     my $pass = shift;
383     $n1 = 0;
384     $n2 = 0;
385     crypt_init($pass);
386 }
387
388 sub crypt_init {
389     my $pw = shift;
390     my $i;
391
392     @t2 = @t3 = (0) x ROTORSZ;
393
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);
398
399
400     my $seed = 123;
401     for($i = 0 ; $i < 13 ; $i++) {
402         $seed = $seed * $buf[$i] + $i;
403     }
404     @t1 = (0 .. ROTORSZ-1);
405     
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);
411         $random >>= 8;
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;
417         }
418         $t3[$k] = $ic;
419         $t3[$ic] = $k;
420     }
421     for($i = 0 ; $i < ROTORSZ ; $i++) {
422         $t2[$t1[$i] & MASK] = $i
423     }
424 }
425
426 sub encode {
427     my $sp = shift;
428     my $ch;
429     my $n = scalar(@$sp);
430     my @out = ($n);
431     my $i;
432
433     for($i = 0 ; $i < $n ; ) {
434         my($f0,$f1,$f2) = splice(@$sp,0,3);
435         push(@out,
436             $f0 >> 2,
437             ($f0 << 4) & 060 | ($f1 >> 4) & 017,
438             ($f1 << 2) & 074 | ($f2 >> 6) & 03,
439             $f2 & 077);
440         $i += 3;
441    }
442    join("", map { chr((($_ & 077) + 35) & 0xff) } @out);  # ord('#') == 35
443 }
444
445 sub encryptit {
446     my $from = shift;
447     my @from = map { ord $_ } split(//, $from);
448     my @sp = ();
449     my $ch;
450     while(defined($ch = shift @from)) {
451         push(@sp,
452             $t2[($t3[($t1[($ch + $n1) & MASK] + $n2) & MASK] - $n2) & MASK] - $n1);
453
454         $n1++;
455         if($n1 == ROTORSZ) {
456             $n1 = 0;
457             $n2++;
458             $n2 = 0 if $n2 == ROTORSZ;
459         }
460     }
461     encode(\@sp);
462 }
463
464 1;
465
466 __END__
467
468 =head1 NAME
469
470 Net::PH - CCSO Nameserver Client class
471
472 =head1 SYNOPSIS
473
474     use Net::PH;
475     
476     $ph = Net::PH->new("some.host.name",
477                        Port    => 105,
478                        Timeout => 120,
479                        Debug   => 0);
480
481     if($ph) {
482         $q = $ph->query({ field1 => "value1" },
483                         [qw(name address pobox)]);
484     
485         if($q) {
486         }
487     }
488     
489     # Alternative syntax
490     
491     if($ph) {
492         $q = $ph->query('field1=value1',
493                         'name address pobox');
494     
495         if($q) {
496         }
497     }
498
499 =head1 DESCRIPTION
500
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
504 C<Net::Cmd>.
505
506 =head1 CONSTRUCTOR
507
508 =over 4
509
510 =item new ( [ HOST ] [, OPTIONS ])
511
512     $ph = Net::PH->new("some.host.name",
513                        Port    => 105,
514                        Timeout => 120,
515                        Debug   => 0
516                       );
517
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.
520
521 If C<HOST> is not given, then the C<SNPP_Host> specified in C<Net::Config>
522 will be used.
523
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:-
526
527 B<Port> - Port number to connect to on remote host.
528
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.
531 (default: 120)
532
533 B<Debug> - Enable the printing of debugging information to STDERR
534
535 =back
536
537 =head1 METHODS
538
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
542 empty list.
543
544 =over 4
545
546 =item query( SEARCH [, RETURN ] )
547
548     $q = $ph->query({ name => $myname },
549                     [qw(name email schedule)]);
550     
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" ;
558         }
559     }
560
561     
562
563 Search the database and return fields from all matching entries.
564
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.
567
568 C<RETURN> is optional, but if given it should be a reference to a list which
569 contains field names to be returned.
570
571 The alternative syntax is to pass strings instead of references, for example
572
573     $q = $ph->query('name=myname',
574                     'name email schedule');
575
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.
579
580 C<RETURN> is optional, but if given it should be a string which will
581 contain field names to be returned.
582
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>, 
585 I<field>, I<text>).
586
587 Returns a reference to an ARRAY which contains references to HASHs, one
588 per match from the server.
589
590 =item change( SEARCH , MAKE )
591
592     $r = $ph->change({ email => "*.domain.name" },
593                      { schedule => "busy");
594
595 Change field values for matching entries.
596
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.
599
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.
603
604 The alternative syntax is to pass strings instead of references, for example
605
606     $r = $ph->change('email="*.domain.name"',
607                      'schedule="busy"');
608
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.
612
613
614 The C<MAKE> argument is a string to be passed to the Nameserver that
615 will set new values to designated fields.
616
617 Upon success all entries that match the search criteria will have
618 the field values, given in the Make argument, changed.
619
620 =item login( USER, PASS [, ENCRYPT ])
621
622     $r = $ph->login('username','password',1);
623
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>)
629
630 =item logout()
631
632     $r = $ph->logout();
633
634 Exit login mode and return to anonymous mode.
635
636 =item fields( [ FIELD_LIST ] )
637
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";
645     }
646
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>).
650
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
654 server.
655
656 C<FIELD_LIST> is a string that lists the fields for which info will be
657 returned.
658
659 =item add( FIELD_VALUES )
660
661     $r = $ph->add( { name => $name, phone => $phone });
662
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.
665
666 B<Note> that this method adds new entries to the database. To modify
667 an existing entry use L<change>.
668
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.
672
673 The alternative syntax is to pass a string instead of a reference, for example
674
675     $r = $ph->add('name=myname phone=myphone');
676
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.
680
681
682 =item delete( FIELD_VALUES )
683
684     $r = $ph->delete('name=myname phone=myphone');
685
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.
688
689 B<Note> that this method deletes entries to the database. To modify
690 an existing entry use L<change>.
691
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.
695
696 =item id( [ ID ] )
697
698     $r = $ph->id('709');
699
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.
703
704 =item status()
705
706 Returns the current status of the Nameserver.
707
708 =item siteinfo()
709
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";
717     }
718
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>).
722
723 =item quit()
724
725     $r = $ph->quit();
726
727 Quit the connection
728
729 =back
730
731 =head1 Q&A
732
733 How do I get the values of a Net::PH::Result object?
734
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;
741         }
742     }
743
744 How do I get a count of the returned matches to my query?
745
746     $my_count = scalar(@{$query_result});
747
748 How do I get the status code and message of the last C<$ph> command?
749
750     $status_code    = $ph->code;
751     $status_message = $ph->message;
752
753 =head1 SEE ALSO
754
755 L<Net::Cmd>
756
757 =head1 AUTHORS
758
759 Graham Barr <gbarr@pobox.com>
760 Alex Hristov <hristov@slb.com>
761
762 =head1 ACKNOWLEDGMENTS
763
764 Password encryption code ported to perl by Broc Seib <bseib@purdue.edu>,
765 Purdue University Computing Center.
766
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.
770
771         Example: query first_name last_name email="*.domain"
772
773 =head1 COPYRIGHT
774
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.
778
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.
783
784 =cut