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