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
CommitLineData
406c51ee
JH
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
5use 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.
16my $origdir = cwd;
17chdir dirname($0);
18my $file = basename($0, '.PL');
19$file .= '.com' if $^O eq 'VMS';
20
21open OUT,">$file" or die "Can't create $file: $!";
22
23print "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
28print 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
36print OUT <<'!NO!SUBS!';
37
a6fb92f1
JH
38=head1 NAME
39
40libnetcfg - configure libnet
41
42=head1 DESCRIPTION
43
44The libnetcfg utility can be be used to configure the libnet.
45Starting from perl 5.8 libnet is part of the standard Perl
46distribution, but the libnetcfg can be be used for any libnet
47installation.
48
49=head1 USAGE
50
51Without 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
70It tells where the old configuration file was found (if found).
71
72The C<-h> option will show a usage message.
73
74To change the configuration you will need to use either the C<-c> or
75the C<-d> options.
76
77The default name of the old configuration file is by default
78"libnet.cfg", unless otherwise specified using the -i option, and it
79is searched from your module path, C<-i oldfile>.
80
81The default name of new configuration file is "libnet.cfg", and by
82default it is written to the current directory, unless otherwise
83specified using the -o option, C<-o newfile>.
84
85=head1 SEE ALSO
86
87L<Net::Config>, L<Net::libnetFAQ>
88
89=head1 AUTHORS
90
91Graham Barr, the original Configure script of libnet.
92
93Jarkko Hietaniemi, conversion into libnet cfg for inclusion into Perl 5.8.
94
95=cut
96
406c51ee
JH
97# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
98
99use strict;
100use IO::File;
101use Getopt::Std;
102use ExtUtils::MakeMaker qw(prompt);
a6fb92f1 103use File::Spec;
406c51ee 104
a6fb92f1 105use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
406c51ee
JH
106
107##
108##
109##
110
111my %cfg = ();
112my @cfg = ();
113
a6fb92f1 114my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
406c51ee
JH
115
116##
117##
118##
119
120sub valid_host
121{
122 my $h = shift;
123
124 defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
125}
126
127##
128##
129##
130
131sub 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
156sub 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
176sub 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
201sub 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
223EDQ
224 }
225
226 length $host
227 ? $host
228 : undef;
229}
230
231##
232##
233##
234
235sub 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
250sub get_netmask ($$)
251{
252 my($prompt,$def) = @_;
253
254 chomp($prompt);
255
256 my %list;
257 @list{@$def} = ();
258
259MASK:
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
309sub 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
a6fb92f1
JH
331getopts('dcho:i:');
332
333$libnet_cfg_in = "libnet.cfg"
334 unless(defined($libnet_cfg_in = $opt_i));
406c51ee 335
a6fb92f1
JH
336$libnet_cfg_out = "libnet.cfg"
337 unless(defined($libnet_cfg_out = $opt_o));
406c51ee
JH
338
339my %oldcfg = ();
340
341$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
a6fb92f1 342if( -f $libnet_cfg_in )
406c51ee 343 {
a6fb92f1 344 %oldcfg = ( %{ do $libnet_cfg_in } );
406c51ee
JH
345 }
346elsif (eval { require Net::Config })
347 {
348 $have_old = 1;
349 %oldcfg = %Net::Config::NetConfig;
350 }
351
352map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
353
a6fb92f1
JH
354#---------------------------------------------------------------------------
355
356if ($opt_h) {
357 print <<EOU;
358$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
359Without 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
367The default name of the old configuration file is by default
368"libnet.cfg", unless otherwise specified using the -i option, and it
369is searched from your module path.
370
371The default name of new configuration file is "libnet.cfg", and by
372default it is written to the current directory, unless otherwise
373specified using the -o option.
374
375EOU
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
406c51ee
JH
407$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
408$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
409
410#---------------------------------------------------------------------------
411
412if($have_old && !$opt_d)
413 {
414 $msg = <<EDQ;
415
416Ah, I see you already have installed libnet before.
417
418Do you want to modify/update your configuration (y|n) ?
419EDQ
420
421 $opt_d = 1
422 unless get_bool($msg,0);
423 }
424
425#---------------------------------------------------------------------------
426
427$msg = <<EDQ;
428
429This script will prompt you to enter hostnames that can be used as
430defaults for some of the modules in the libnet distribution.
431
432To ensure that you do not enter an invalid hostname, I can perform a
433lookup on each hostname you enter. If your internet connection is via
434a dialup line then you may not want me to perform these lookups, as
435it will require you to be on-line.
436
437Do you want me to perform hostname lookups (y|n) ?
438EDQ
439
440$cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
441
442print <<EDQ unless $cfg{'test_exist'};
443
444*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
445
446OK I will not check if the hostnames you give are valid
447so be very cafeful
448
449*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
450EDQ
451
452
453#---------------------------------------------------------------------------
454
455print <<EDQ;
456
457The following questions all require a list of host names, separated
458with spaces. If you do not have a host available for any of the
459services, then enter a single space, followed by <CR>. To accept the
460default, hit <CR>
461
462EDQ
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
525Do you have a firewall/ftp proxy between your machine and the internet
526
527If you use a SOCKS firewall answer no
528
529(y|n) ?
530EDQ
531
532if(get_bool($msg,0)) {
533
534 $msg = <<'EDQ';
535What series of FTP commands do you need to send to your
536firewall to connect to an external host.
537
538user/pass => external user & password
539fwuser/fwpass => firewall user & password
540
5410) None
5421) -----------------------
543 USER user@remote.host
544 PASS pass
5452) -----------------------
546 USER fwuser
547 PASS fwpass
548 USER user@remote.host
549 PASS pass
5503) -----------------------
551 USER fwuser
552 PASS fwpass
553 SITE remote.site
554 USER user
555 PASS pass
5564) -----------------------
557 USER fwuser
558 PASS fwpass
559 OPEN remote.site
560 USER user
561 PASS pass
5625) -----------------------
563 USER user@fwuser@remote.site
564 PASS pass@fwpass
5656) -----------------------
566 USER fwuser@remote.site
567 PASS fwpass
568 USER user
569 PASS pass
5707) -----------------------
571 USER user@remote.host
572 PASS pass
573 AUTH fwuser
574 RESP fwpass
575
576Choice:
577EDQ
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}
585else {
586 delete $cfg{'ftp_firewall'};
587}
588
589
590#---------------------------------------------------------------------------
591
592if (defined $cfg{'ftp_firewall'})
593 {
594 print <<EDQ;
595
596By default Net::FTP assumes that it only needs to use a firewall if it
597cannot resolve the name of the host given. This only works if your DNS
598system is setup to only resolve internal hostnames. If this is not the
599case and your DNS will resolve external hostnames, then another method
600is needed. Net::Config can do this if you provide the netmasks that
601describe your internal network. Each netmask should be entered in the
602form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
603
604EDQ
605$def = [];
606if(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
613print "
614Enter one netmask at each prompt, prefix with a - to remove a netmask
615from the list, enter a '*' to clear the whole list, an '=' to show the
616current 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
643print <<EDQ;
644
645Normally when FTP needs a data connection the client tells the server
646a port to connect to, and the server initiates a connection to the client.
647
648Some setups, in particular firewall setups, can/do not work using this
649protocol. In these situations the client must make the connection to the
650server, this is called a passive transfer.
651EDQ
652
653if (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}
663else {
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
684If you specified some default hosts above, it is possible for me to
685do some basic tests when you run `make test'
686
687This will cause `make test' to be quite a bit slower and, if your
688internet connection is via dialup, will require you to be on-line
689unless the hosts are local.
690
691Do you want me to run these tests (y|n) ?
692EDQ
693
694$cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
695
696#---------------------------------------------------------------------------
697
698$msg = <<EDQ;
699
700To allow Net::FTP to be tested I will need a hostname. This host
701should allow anonymous access and have a /pub directory
702
703What host can I use :
704EDQ
705
706$cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
707 if $cfg{'test_hosts'};
708
709
710print "\n";
711
712#---------------------------------------------------------------------------
713
a6fb92f1
JH
714my $fh = IO::File->new($libnet_cfg_out, "w") or
715 die "Cannot create `$libnet_cfg_out': $!";
406c51ee 716
a6fb92f1 717print "Writing $libnet_cfg_out\n";
406c51ee
JH
718
719print $fh "{\n";
720
721my $key;
722foreach $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
745print $fh "}\n";
746
747$fh->close;
748
749############################################################################
750############################################################################
751
752exit 0;
753!NO!SUBS!
754
755close OUT or die "Can't close $file: $!";
756chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
757exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
758chdir $origdir;