Remove unneeded pragma line from B/t/OptreeCheck.pm
[perl.git] / 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;