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