utils/libnetcfg.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5 use Cwd;
   6
   7 # List explicitly here the variables you want Configure to
   8 # generate.  Metaconfig only looks for shell variables, so you
   9 # have to mention them as if they were shell variables, not
  10 # %Config entries.  Thus you write
  11 #  $startperl
  12 # to ensure Configure will look for $Config{startperl}.
  13
  14 # This forces PL files to create target in same directory as PL file.
  15 # This is so that make depend always knows where to find PL derivatives.
  16 my $origdir = cwd;
  17 chdir dirname($0);
  18 my $file = basename($0, '.PL');
  19 $file .= '.com' if $^O eq 'VMS';
  20
  21 open OUT,">$file" or die "Can't create $file: $!";
  22
  23 print "Extracting $file (with variable substitutions)\n";
  24
  25 # In this section, perl variables will be expanded during extraction.
  26 # You can use $Config{...} to use Configure variables.
  27
  28 print OUT <<"!GROK!THIS!";
  29 $Config{startperl}
  30     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  31         if \$running_under_some_shell;
  32 !GROK!THIS!
  33
  34 # In the following, perl variables are not expanded during extraction.
  35
  36 print OUT <<'!NO!SUBS!';
  37
  38 =head1 NAME
  39
  40 libnetcfg - configure libnet
  41
  42 =head1 DESCRIPTION
  43
  44 The libnetcfg utility can be used to configure the libnet.
  45 Starting from perl 5.8 libnet is part of the standard Perl
  46 distribution, but the libnetcfg can be used for any libnet
  47 installation.
  48
  49 =head1 USAGE
  50
  51 Without arguments libnetcfg displays the current configuration.
  52
  53     $ libnetcfg
  54     # old config ./libnet.cfg
  55     daytime_hosts        ntp1.none.such
  56     ftp_int_passive      0
  57     ftp_testhost         ftp.funet.fi
  58     inet_domain          none.such
  59     nntp_hosts           nntp.none.such
  60     ph_hosts
  61     pop3_hosts           pop.none.such
  62     smtp_hosts           smtp.none.such
  63     snpp_hosts
  64     test_exist           1
  65     test_hosts           1
  66     time_hosts           ntp.none.such
  67     # libnetcfg -h for help
  68     $
  69
  70 It tells where the old configuration file was found (if found).
  71
  72 The C<-h> option will show a usage message.
  73
  74 To change the configuration you will need to use either the C<-c> or
  75 the C<-d> options.
  76
  77 The default name of the old configuration file is by default
  78 "libnet.cfg", unless otherwise specified using the -i option,
  79 C<-i oldfile>, and it is searched first from the current directory,
  80 and then from your module path.
  81
  82 The default name of the new configuration file is "libnet.cfg", and by
  83 default it is written to the current directory, unless otherwise
  84 specified using the -o option, C<-o newfile>.
  85
  86 =head1 SEE ALSO
  87
  88 L<Net::Config>, L<Net::libnetFAQ>
  89
  90 =head1 AUTHORS
  91
  92 Graham Barr, the original Configure script of libnet.
  93
  94 Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
  95
  96 =cut
  97
  98 # $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
  99
 100 use strict;
 101 use IO::File;
 102 use Getopt::Std;
 103 use ExtUtils::MakeMaker qw(prompt);
 104 use File::Spec;
 105
 106 use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
 107
 108 ##
 109 ##
 110 ##
 111
 112 my %cfg = ();
 113 my @cfg = ();
 114
 115 my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
 116
 117 ##
 118 ##
 119 ##
 120
 121 sub valid_host
 122 {
 123  my $h = shift;
 124
 125  defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
 126 }
 127
 128 ##
 129 ##
 130 ##
 131
 132 sub test_hostnames (\@)
 133 {
 134  my $hlist = shift;
 135  my @h = ();
 136  my $host;
 137  my $err = 0;
 138
 139  foreach $host (@$hlist)
 140   {
 141    if(valid_host($host))
 142     {
 143      push(@h, $host);
 144      next;
 145     }
 146    warn "Bad hostname: '$host'\n";
 147    $err++;
 148   }
 149  @$hlist = @h;
 150  $err ? join(" ",@h) : undef;
 151 }
 152
 153 ##
 154 ##
 155 ##
 156
 157 sub Prompt
 158 {
 159  my($prompt,$def) = @_;
 160
 161  $def = "" unless defined $def;
 162
 163  chomp($prompt);
 164
 165  if($opt_d)
 166   {
 167    print $prompt,," [",$def,"]\n";
 168    return $def;
 169   }
 170  prompt($prompt,$def);
 171 }
 172
 173 ##
 174 ##
 175 ##
 176
 177 sub get_host_list
 178 {
 179  my($prompt,$def) = @_;
 180
 181  $def = join(" ",@$def) if ref($def);
 182
 183  my @hosts;
 184
 185  do
 186   {
 187    my $ans = Prompt($prompt,$def);
 188
 189    $ans =~ s/(\A\s+|\s+\Z)//g;
 190
 191    @hosts = split(/\s+/, $ans);
 192   }
 193  while(@hosts && defined($def = test_hostnames(@hosts)));
 194
 195  \@hosts;
 196 }
 197
 198 ##
 199 ##
 200 ##
 201
 202 sub get_hostname
 203 {
 204  my($prompt,$def) = @_;
 205
 206  my $host;
 207
 208  while(1)
 209   {
 210    my $ans = Prompt($prompt,$def);
 211    $host = ($ans =~ /(\S*)/)[0];
 212    last
 213         if(!length($host) || valid_host($host));
 214
 215    $def =""
 216         if $def eq $host;
 217
 218    print <<"EDQ";
 219
 220 *** ERROR:
 221     Hostname '$host' does not seem to exist, please enter again
 222     or a single space to clear any default
 223
 224 EDQ
 225   }
 226
 227  length $host
 228         ? $host
 229         : undef;
 230 }
 231
 232 ##
 233 ##
 234 ##
 235
 236 sub get_bool ($$)
 237 {
 238  my($prompt,$def) = @_;
 239
 240  chomp($prompt);
 241
 242  my $val = Prompt($prompt,$def ? "yes" : "no");
 243
 244  $val =~ /^y/i ? 1 : 0;
 245 }
 246
 247 ##
 248 ##
 249 ##
 250
 251 sub get_netmask ($$)
 252 {
 253  my($prompt,$def) = @_;
 254
 255  chomp($prompt);
 256
 257  my %list;
 258  @list{@$def} = ();
 259
 260 MASK:
 261  while(1) {
 262    my $bad = 0;
 263    my $ans = Prompt($prompt) or last;
 264
 265    if($ans eq '*') {
 266      %list = ();
 267      next;
 268    }
 269
 270    if($ans eq '=') {
 271      print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
 272      next;
 273    }
 274
 275    unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
 276      warn "Bad netmask '$ans'\n";
 277      next;
 278    }
 279
 280    my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0);
 281    if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
 282      warn "Bad netmask '$ans'\n";
 283      next MASK;
 284    }
 285    foreach my $byte (@ip) {
 286      if ( $byte > 255 ) {
 287        warn "Bad netmask '$ans'\n";
 288        next MASK;
 289      }
 290    }
 291
 292    my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits);
 293
 294    if ($remove) {
 295      delete $list{$mask};
 296    }
 297    else {
 298      $list{$mask} = 1;
 299    }
 300
 301   }
 302
 303  [ keys %list ];
 304 }
 305
 306 ##
 307 ##
 308 ##
 309
 310 sub default_hostname
 311 {
 312  my $host;
 313  my @host;
 314
 315  foreach $host (@_)
 316   {
 317    if(defined($host) && valid_host($host))
 318     {
 319      return $host
 320         unless wantarray;
 321      push(@host,$host);
 322     }
 323   }
 324
 325  return wantarray ? @host : undef;
 326 }
 327
 328 ##
 329 ##
 330 ##
 331
 332 getopts('dcho:i:');
 333
 334 $libnet_cfg_in = "libnet.cfg"
 335         unless(defined($libnet_cfg_in  = $opt_i));
 336
 337 $libnet_cfg_out = "libnet.cfg"
 338         unless(defined($libnet_cfg_out = $opt_o));
 339
 340 my %oldcfg = ();
 341
 342 $Net::Config::CONFIGURE = 1; # Suppress load of user overrides
 343 if( -f $libnet_cfg_in )
 344  {
 345   %oldcfg = ( %{ do $libnet_cfg_in } );
 346  }
 347 elsif (eval { require Net::Config })
 348  {
 349   $have_old = 1;
 350   %oldcfg = %Net::Config::NetConfig;
 351  }
 352
 353 map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
 354
 355 #---------------------------------------------------------------------------
 356
 357 if ($opt_h) {
 358  print <<EOU;
 359 $0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
 360 Without options, the old configuration is shown.
 361
 362    -c change the configuration
 363    -d use defaults from the old config (implies -c, non-interactive)
 364    -i use a specific file as the old config file
 365    -o use a specific file as the new config file
 366    -h show this help
 367
 368 The default name of the old configuration file is by default
 369 "libnet.cfg", unless otherwise specified using the -i option,
 370 C<-i oldfile>, and it is searched first from the current directory,
 371 and then from your module path.
 372
 373 The default name of the new configuration file is "libnet.cfg", and by
 374 default it is written to the current directory, unless otherwise
 375 specified using the -o option.
 376
 377 EOU
 378  exit(0);
 379 }
 380
 381 #---------------------------------------------------------------------------
 382
 383 {
 384    my $oldcfgfile;
 385    my @inc;
 386    push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
 387    push @inc, $ENV{PERLLIB}  if exists $ENV{PERLLIB};
 388    push @inc, @INC;
 389    for (@inc) {
 390     my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
 391     if (-f $trycfgfile && -r $trycfgfile) {
 392      $oldcfgfile = $trycfgfile;
 393      last;
 394     }
 395    }
 396    print "# old config $oldcfgfile\n" if defined $oldcfgfile;
 397    for (sort keys %oldcfg) {
 398         printf "%-20s %s\n", $_,
 399                ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
 400    }
 401    unless ($opt_c || $opt_d) {
 402     print "# $0 -h for help\n";
 403     exit(0);
 404    }
 405 }
 406
 407 #---------------------------------------------------------------------------
 408
 409 $oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
 410 $oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
 411
 412 #---------------------------------------------------------------------------
 413
 414 if($have_old && !$opt_d)
 415  {
 416   $msg = <<EDQ;
 417
 418 Ah, I see you already have installed libnet before.
 419
 420 Do you want to modify/update your configuration (y|n) ?
 421 EDQ
 422
 423  $opt_d = 1
 424         unless get_bool($msg,0);
 425  }
 426
 427 #---------------------------------------------------------------------------
 428
 429 $msg = <<EDQ;
 430
 431 This script will prompt you to enter hostnames that can be used as
 432 defaults for some of the modules in the libnet distribution.
 433
 434 To ensure that you do not enter an invalid hostname, I can perform a
 435 lookup on each hostname you enter. If your internet connection is via
 436 a dialup line then you may not want me to perform these lookups, as
 437 it will require you to be on-line.
 438
 439 Do you want me to perform hostname lookups (y|n) ?
 440 EDQ
 441
 442 $cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
 443
 444 print <<EDQ unless $cfg{'test_exist'};
 445
 446 *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
 447
 448 OK I will not check if the hostnames you give are valid
 449 so be very cafeful
 450
 451 *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
 452 EDQ
 453
 454
 455 #---------------------------------------------------------------------------
 456
 457 print <<EDQ;
 458
 459 The following questions all require a list of host names, separated
 460 with spaces. If you do not have a host available for any of the
 461 services, then enter a single space, followed by <CR>. To accept the
 462 default, hit <CR>
 463
 464 EDQ
 465
 466 $msg = 'Enter a list of available NNTP hosts :';
 467
 468 $def = $oldcfg{'nntp_hosts'} ||
 469         [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
 470
 471 $cfg{'nntp_hosts'} = get_host_list($msg,$def);
 472
 473 #---------------------------------------------------------------------------
 474
 475 $msg = 'Enter a list of available SMTP hosts :';
 476
 477 $def = $oldcfg{'smtp_hosts'} ||
 478         [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
 479
 480 $cfg{'smtp_hosts'} = get_host_list($msg,$def);
 481
 482 #---------------------------------------------------------------------------
 483
 484 $msg = 'Enter a list of available POP3 hosts :';
 485
 486 $def = $oldcfg{'pop3_hosts'} || [];
 487
 488 $cfg{'pop3_hosts'} = get_host_list($msg,$def);
 489
 490 #---------------------------------------------------------------------------
 491
 492 $msg = 'Enter a list of available SNPP hosts :';
 493
 494 $def = $oldcfg{'snpp_hosts'} || [];
 495
 496 $cfg{'snpp_hosts'} = get_host_list($msg,$def);
 497
 498 #---------------------------------------------------------------------------
 499
 500 $msg = 'Enter a list of available PH Hosts   :'  ;
 501
 502 $def = $oldcfg{'ph_hosts'} ||
 503         [ default_hostname('dirserv') ];
 504
 505 $cfg{'ph_hosts'}   =  get_host_list($msg,$def);
 506
 507 #---------------------------------------------------------------------------
 508
 509 $msg = 'Enter a list of available TIME Hosts   :'  ;
 510
 511 $def = $oldcfg{'time_hosts'} || [];
 512
 513 $cfg{'time_hosts'} = get_host_list($msg,$def);
 514
 515 #---------------------------------------------------------------------------
 516
 517 $msg = 'Enter a list of available DAYTIME Hosts   :'  ;
 518
 519 $def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
 520
 521 $cfg{'daytime_hosts'} = get_host_list($msg,$def);
 522
 523 #---------------------------------------------------------------------------
 524
 525 $msg = <<EDQ;
 526
 527 Do you have a firewall/ftp proxy  between your machine and the internet
 528
 529 If you use a SOCKS firewall answer no
 530
 531 (y|n) ?
 532 EDQ
 533
 534 if(get_bool($msg,0)) {
 535
 536   $msg = <<'EDQ';
 537 What series of FTP commands do you need to send to your
 538 firewall to connect to an external host.
 539
 540 user/pass     => external user & password
 541 fwuser/fwpass => firewall user & password
 542
 543 0) None
 544 1) -----------------------
 545      USER user@remote.host
 546      PASS pass
 547 2) -----------------------
 548      USER fwuser
 549      PASS fwpass
 550      USER user@remote.host
 551      PASS pass
 552 3) -----------------------
 553      USER fwuser
 554      PASS fwpass
 555      SITE remote.site
 556      USER user
 557      PASS pass
 558 4) -----------------------
 559      USER fwuser
 560      PASS fwpass
 561      OPEN remote.site
 562      USER user
 563      PASS pass
 564 5) -----------------------
 565      USER user@fwuser@remote.site
 566      PASS pass@fwpass
 567 6) -----------------------
 568      USER fwuser@remote.site
 569      PASS fwpass
 570      USER user
 571      PASS pass
 572 7) -----------------------
 573      USER user@remote.host
 574      PASS pass
 575      AUTH fwuser
 576      RESP fwpass
 577
 578 Choice:
 579 EDQ
 580  $def = exists $oldcfg{'ftp_firewall_type'}  ? $oldcfg{'ftp_firewall_type'} : 1;
 581  $ans = Prompt($msg,$def);
 582  $cfg{'ftp_firewall_type'} = 0+$ans;
 583  $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
 584
 585  $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
 586 }
 587 else {
 588  delete $cfg{'ftp_firewall'};
 589 }
 590
 591
 592 #---------------------------------------------------------------------------
 593
 594 if (defined $cfg{'ftp_firewall'})
 595  {
 596   print <<EDQ;
 597
 598 By default Net::FTP assumes that it only needs to use a firewall if it
 599 cannot resolve the name of the host given. This only works if your DNS
 600 system is setup to only resolve internal hostnames. If this is not the
 601 case and your DNS will resolve external hostnames, then another method
 602 is needed. Net::Config can do this if you provide the netmasks that
 603 describe your internal network. Each netmask should be entered in the
 604 form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
 605
 606 EDQ
 607 $def = [];
 608 if(ref($oldcfg{'local_netmask'}))
 609  {
 610   $def = $oldcfg{'local_netmask'};
 611    print "Your current netmasks are :\n\n\t",
 612         join("\n\t",@{$def}),"\n\n";
 613  }
 614
 615 print "
 616 Enter one netmask at each prompt, prefix with a - to remove a netmask
 617 from the list, enter a '*' to clear the whole list, an '=' to show the
 618 current list and an empty line to continue with Configure.
 619
 620 ";
 621
 622   my $mask = get_netmask("netmask :",$def);
 623   $cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
 624  }
 625
 626 #---------------------------------------------------------------------------
 627
 628 ###$msg =<<EDQ;
 629 ###
 630 ###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
 631 ###then enter a list of hostames
 632 ###
 633 ###Enter a list of available SOCKS hosts :
 634 ###EDQ
 635 ###
 636 ###$def = $cfg{'socks_hosts'} ||
 637 ###     [ default_hostname($ENV{SOCKS5_SERVER},
 638 ###                        $ENV{SOCKS_SERVER},
 639 ###                        $ENV{SOCKS4_SERVER}) ];
 640 ###
 641 ###$cfg{'socks_hosts'}   =  get_host_list($msg,$def);
 642
 643 #---------------------------------------------------------------------------
 644
 645 print <<EDQ;
 646
 647 Normally when FTP needs a data connection the client tells the server
 648 a port to connect to, and the server initiates a connection to the client.
 649
 650 Some setups, in particular firewall setups, can/do not work using this
 651 protocol. In these situations the client must make the connection to the
 652 server, this is called a passive transfer.
 653 EDQ
 654
 655 if (defined $cfg{'ftp_firewall'}) {
 656   $msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
 657
 658   $def = $oldcfg{'ftp_ext_passive'} || 0;
 659
 660   $cfg{'ftp_ext_passive'} = get_bool($msg,$def);
 661
 662   $msg = "\nShould all other FTP connections be passive (y|n) ?";
 663
 664 }
 665 else {
 666   $msg = "\nShould all FTP connections be passive (y|n) ?";
 667 }
 668
 669 $def = $oldcfg{'ftp_int_passive'} || 0;
 670
 671 $cfg{'ftp_int_passive'} = get_bool($msg,$def);
 672
 673
 674 #---------------------------------------------------------------------------
 675
 676 $def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
 677
 678 $ans = Prompt("\nWhat is your local internet domain name :",$def);
 679
 680 $cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
 681
 682 #---------------------------------------------------------------------------
 683
 684 $msg = <<EDQ;
 685
 686 If you specified some default hosts above, it is possible for me to
 687 do some basic tests when you run 'make test'
 688
 689 This will cause 'make test' to be quite a bit slower and, if your
 690 internet connection is via dialup, will require you to be on-line
 691 unless the hosts are local.
 692
 693 Do you want me to run these tests (y|n) ?
 694 EDQ
 695
 696 $cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
 697
 698 #---------------------------------------------------------------------------
 699
 700 $msg = <<EDQ;
 701
 702 To allow Net::FTP to be tested I will need a hostname. This host
 703 should allow anonymous access and have a /pub directory
 704
 705 What host can I use :
 706 EDQ
 707
 708 $cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
 709         if $cfg{'test_hosts'};
 710
 711
 712 print "\n";
 713
 714 #---------------------------------------------------------------------------
 715
 716 my $fh = IO::File->new($libnet_cfg_out, "w") or
 717         die "Cannot create '$libnet_cfg_out': $!";
 718
 719 print "Writing $libnet_cfg_out\n";
 720
 721 print $fh "{\n";
 722
 723 my $key;
 724 foreach $key (keys %cfg) {
 725     my $val = $cfg{$key};
 726     if(!defined($val)) {
 727         $val = "undef";
 728     }
 729     elsif(ref($val)) {
 730         $val = '[' . join(",",
 731             map {
 732                 my $v = "undef";
 733                 if(defined $_) {
 734                     ($v = $_) =~ s/'/\'/sog;
 735                     $v = "'" . $v . "'";
 736                 }
 737                 $v;
 738             } @$val ) . ']';
 739     }
 740     else {
 741         $val =~ s/'/\'/sog;
 742         $val = "'" . $val . "'" if $val =~ /\D/;
 743     }
 744     print $fh "\t'",$key,"' => ",$val,",\n";
 745 }
 746
 747 print $fh "}\n";
 748
 749 $fh->close;
 750
 751 ############################################################################
 752 ############################################################################
 753
 754 exit 0;
 755 !NO!SUBS!
 756
 757 close OUT or die "Can't close $file: $!";
 758 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 759 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 760 chdir $origdir;