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