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