perlguts: add some background information on op slab internals
[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<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;