[perl5.git] / utils / libnetcfg.PL

#!/usr/local/bin/perl

use Config;
use File::Basename qw(&basename &dirname);
use Cwd;

# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
my $origdir = cwd;
chdir dirname($0);
my $file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';

open OUT, ">", $file or die "Can't create $file: $!";

print "Extracting $file (with variable substitutions)\n";

# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.

print OUT <<"!GROK!THIS!";
$Config{startperl}
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	if \$running_under_some_shell;
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.

print OUT <<'!NO!SUBS!';

=head1 NAME

libnetcfg - configure libnet

=head1 DESCRIPTION

The libnetcfg utility can be used to configure the libnet.
Starting from perl 5.8 libnet is part of the standard Perl
distribution, but the libnetcfg can be used for any libnet
installation.

=head1 USAGE

Without arguments libnetcfg displays the current configuration.

    $ libnetcfg
    # old config ./libnet.cfg
    daytime_hosts        ntp1.none.such
    ftp_int_passive      0
    ftp_testhost         ftp.funet.fi
    inet_domain          none.such
    nntp_hosts           nntp.none.such
    ph_hosts             
    pop3_hosts           pop.none.such
    smtp_hosts           smtp.none.such
    snpp_hosts           
    test_exist           1
    test_hosts           1
    time_hosts           ntp.none.such
    # libnetcfg -h for help
    $ 

It tells where the old configuration file was found (if found).

The C<-h> option will show a usage message.

To change the configuration you will need to use either the C<-c> or
the C<-d> options.

The default name of the old configuration file is by default
"libnet.cfg", unless otherwise specified using the -i option,
C<-i oldfile>, and it is searched first from the current directory,
and then from your module path.

The default name of the new configuration file is "libnet.cfg", and by
default it is written to the current directory, unless otherwise
specified using the -o option, C<-o newfile>.

=head1 SEE ALSO

L<Net::Config>, L<libnetFAQ>

=head1 AUTHORS

Graham Barr, the original Configure script of libnet.

Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.

=cut

# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $

BEGIN { pop @INC if $INC[-1] eq '.' }
use strict;
use IO::File;
use Getopt::Std;
use ExtUtils::MakeMaker qw(prompt);
use File::Spec;

use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);

##
##
##

my %cfg = ();
my @cfg = ();

my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);

##
##
##

sub valid_host
{
 my $h = shift;

 defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
}

##
##
##

sub test_hostnames (\@)
{
 my $hlist = shift;
 my @h = ();
 my $host;
 my $err = 0;

 foreach $host (@$hlist)
  {
   if(valid_host($host))
    {
     push(@h, $host);
     next;
    }
   warn "Bad hostname: '$host'\n";
   $err++;
  }
 @$hlist = @h;
 $err ? join(" ",@h) : undef;
}

##
##
##

sub Prompt
{
 my($prompt,$def) = @_;

 $def = "" unless defined $def;

 chomp($prompt);

 if($opt_d)
  {
   print $prompt,," [",$def,"]\n";
   return $def;
  }
 prompt($prompt,$def);
}

##
##
##

sub get_host_list
{
 my($prompt,$def) = @_;

 $def = join(" ",@$def) if ref($def);

 my @hosts;

 do
  {
   my $ans = Prompt($prompt,$def);

   $ans =~ s/(\A\s+|\s+\Z)//g;

   @hosts = split(/\s+/, $ans);
  }
 while(@hosts && defined($def = test_hostnames(@hosts)));

 \@hosts;
}

##
##
##

sub get_hostname
{
 my($prompt,$def) = @_;

 my $host;

 while(1)
  {
   my $ans = Prompt($prompt,$def);
   $host = ($ans =~ /(\S*)/)[0];
   last
	if(!length($host) || valid_host($host));

   $def =""
	if $def eq $host;

   print <<"EDQ";

*** ERROR:
    Hostname '$host' does not seem to exist, please enter again
    or a single space to clear any default

EDQ
  }

 length $host
	? $host
	: undef;
}

##
##
##

sub get_bool ($$)
{
 my($prompt,$def) = @_;

 chomp($prompt);

 my $val = Prompt($prompt,$def ? "yes" : "no");

 $val =~ /^y/i ? 1 : 0;
}

##
##
##

sub get_netmask ($$)
{
 my($prompt,$def) = @_;

 chomp($prompt);

 my %list;
 @list{@$def} = ();

MASK:
 while(1) {
   my $bad = 0;
   my $ans = Prompt($prompt) or last;

   if($ans eq '*') {
     %list = ();
     next;
   }

   if($ans eq '=') {
     print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
     next;
   }

   unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
     warn "Bad netmask '$ans'\n";
     next;
   }

   my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0);
   if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
     warn "Bad netmask '$ans'\n";
     next MASK;
   }
   foreach my $byte (@ip) {
     if ( $byte > 255 ) {
       warn "Bad netmask '$ans'\n";
       next MASK;
     }
   } 

   my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits); 

   if ($remove) {
     delete $list{$mask};
   }
   else {
     $list{$mask} = 1;
   }

  }

 [ keys %list ];
}

##
##
##

sub default_hostname
{
 my $host;
 my @host;

 foreach $host (@_)
  {
   if(defined($host) && valid_host($host))
    {
     return $host
	unless wantarray;
     push(@host,$host);
    }
  }

 return wantarray ? @host : undef;
}

##
##
##

getopts('dcho:i:');

$libnet_cfg_in = "libnet.cfg"
	unless(defined($libnet_cfg_in  = $opt_i));

$libnet_cfg_out = "libnet.cfg"
	unless(defined($libnet_cfg_out = $opt_o));

my %oldcfg = ();

$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
if( -f $libnet_cfg_in )
 {
  %oldcfg = ( %{ do $libnet_cfg_in } );
 }
elsif (eval { require Net::Config }) 
 {
  $have_old = 1;
  %oldcfg = %Net::Config::NetConfig;
 }

map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;

#---------------------------------------------------------------------------

if ($opt_h) {
 print <<EOU;
$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
Without options, the old configuration is shown.

   -c change the configuration
   -d use defaults from the old config (implies -c, non-interactive)
   -i use a specific file as the old config file
   -o use a specific file as the new config file
   -h show this help

The default name of the old configuration file is by default
"libnet.cfg", unless otherwise specified using the -i option,
C<-i oldfile>, and it is searched first from the current directory,
and then from your module path.

The default name of the new configuration file is "libnet.cfg", and by
default it is written to the current directory, unless otherwise
specified using the -o option.

EOU
 exit(0);
}

#---------------------------------------------------------------------------

{
   my $oldcfgfile;
   my @inc;
   push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
   push @inc, $ENV{PERLLIB}  if exists $ENV{PERLLIB};
   push @inc, @INC;
   for (@inc) {
    my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
    if (-f $trycfgfile && -r $trycfgfile) {
     $oldcfgfile = $trycfgfile;
     last;
    }
   }
   print "# old config $oldcfgfile\n" if defined $oldcfgfile;
   for (sort keys %oldcfg) {
	printf "%-20s %s\n", $_,
               ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
   }
   unless ($opt_c || $opt_d) {
    print "# $0 -h for help\n";
    exit(0);
   }
}

#---------------------------------------------------------------------------

$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};

#---------------------------------------------------------------------------

if($have_old && !$opt_d)
 {
  $msg = <<EDQ;

Ah, I see you already have installed libnet before.

Do you want to modify/update your configuration (y|n) ?
EDQ

 $opt_d = 1
	unless get_bool($msg,0);
 }

#---------------------------------------------------------------------------

$msg = <<EDQ;

This script will prompt you to enter hostnames that can be used as
defaults for some of the modules in the libnet distribution.

To ensure that you do not enter an invalid hostname, I can perform a
lookup on each hostname you enter. If your internet connection is via
a dialup line then you may not want me to perform these lookups, as
it will require you to be on-line.

Do you want me to perform hostname lookups (y|n) ?
EDQ

$cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});

print <<EDQ unless $cfg{'test_exist'};

*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***

OK I will not check if the hostnames you give are valid
so be very cafeful

*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
EDQ


#---------------------------------------------------------------------------

print <<EDQ;

The following questions all require a list of host names, separated
with spaces. If you do not have a host available for any of the
services, then enter a single space, followed by <CR>. To accept the
default, hit <CR>

EDQ

$msg = 'Enter a list of available NNTP hosts :';

$def = $oldcfg{'nntp_hosts'} ||
	[ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];

$cfg{'nntp_hosts'} = get_host_list($msg,$def);

#---------------------------------------------------------------------------

$msg = 'Enter a list of available SMTP hosts :';

$def = $oldcfg{'smtp_hosts'} ||
	[ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];

$cfg{'smtp_hosts'} = get_host_list($msg,$def);

#---------------------------------------------------------------------------

$msg = 'Enter a list of available POP3 hosts :';

$def = $oldcfg{'pop3_hosts'} || [];

$cfg{'pop3_hosts'} = get_host_list($msg,$def);

#---------------------------------------------------------------------------

$msg = 'Enter a list of available SNPP hosts :';

$def = $oldcfg{'snpp_hosts'} || [];

$cfg{'snpp_hosts'} = get_host_list($msg,$def);

#---------------------------------------------------------------------------

$msg = 'Enter a list of available PH Hosts   :'  ;

$def = $oldcfg{'ph_hosts'} ||
	[ default_hostname('dirserv') ];

$cfg{'ph_hosts'}   =  get_host_list($msg,$def);

#---------------------------------------------------------------------------

$msg = 'Enter a list of available TIME Hosts   :'  ;

$def = $oldcfg{'time_hosts'} || [];

$cfg{'time_hosts'} = get_host_list($msg,$def);

#---------------------------------------------------------------------------

$msg = 'Enter a list of available DAYTIME Hosts   :'  ;

$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};

$cfg{'daytime_hosts'} = get_host_list($msg,$def);

#---------------------------------------------------------------------------

$msg = <<EDQ;

Do you have a firewall/ftp proxy  between your machine and the internet 

If you use a SOCKS firewall answer no

(y|n) ?
EDQ

if(get_bool($msg,0)) {

  $msg = <<'EDQ';
What series of FTP commands do you need to send to your
firewall to connect to an external host.

user/pass     => external user & password
fwuser/fwpass => firewall user & password

0) None
1) -----------------------
     USER user@remote.host
     PASS pass
2) -----------------------
     USER fwuser
     PASS fwpass
     USER user@remote.host
     PASS pass
3) -----------------------
     USER fwuser
     PASS fwpass
     SITE remote.site
     USER user
     PASS pass
4) -----------------------
     USER fwuser
     PASS fwpass
     OPEN remote.site
     USER user
     PASS pass
5) -----------------------
     USER user@fwuser@remote.site
     PASS pass@fwpass
6) -----------------------
     USER fwuser@remote.site
     PASS fwpass
     USER user
     PASS pass
7) -----------------------
     USER user@remote.host
     PASS pass
     AUTH fwuser
     RESP fwpass

Choice:
EDQ
 $def = exists $oldcfg{'ftp_firewall_type'}  ? $oldcfg{'ftp_firewall_type'} : 1;
 $ans = Prompt($msg,$def);
 $cfg{'ftp_firewall_type'} = 0+$ans;
 $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};

 $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
}
else {
 delete $cfg{'ftp_firewall'};
}


#---------------------------------------------------------------------------

if (defined $cfg{'ftp_firewall'})
 {
  print <<EDQ;

By default Net::FTP assumes that it only needs to use a firewall if it
cannot resolve the name of the host given. This only works if your DNS
system is setup to only resolve internal hostnames. If this is not the
case and your DNS will resolve external hostnames, then another method
is needed. Net::Config can do this if you provide the netmasks that
describe your internal network. Each netmask should be entered in the
form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24

EDQ
$def = [];
if(ref($oldcfg{'local_netmask'}))
 {
  $def = $oldcfg{'local_netmask'};
   print "Your current netmasks are :\n\n\t",
	join("\n\t",@{$def}),"\n\n";
 }

print "
Enter one netmask at each prompt, prefix with a - to remove a netmask
from the list, enter a '*' to clear the whole list, an '=' to show the
current list and an empty line to continue with Configure.

";

  my $mask = get_netmask("netmask :",$def);
  $cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
 }

#---------------------------------------------------------------------------

###$msg =<<EDQ;
###
###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
###then enter a list of hostames
###
###Enter a list of available SOCKS hosts :
###EDQ
###
###$def = $cfg{'socks_hosts'} ||
###	[ default_hostname($ENV{SOCKS5_SERVER},
###			   $ENV{SOCKS_SERVER},
###			   $ENV{SOCKS4_SERVER}) ];
###
###$cfg{'socks_hosts'}   =  get_host_list($msg,$def);

#---------------------------------------------------------------------------

print <<EDQ;

Normally when FTP needs a data connection the client tells the server
a port to connect to, and the server initiates a connection to the client.

Some setups, in particular firewall setups, can/do not work using this
protocol. In these situations the client must make the connection to the
server, this is called a passive transfer.
EDQ

if (defined $cfg{'ftp_firewall'}) {
  $msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";

  $def = $oldcfg{'ftp_ext_passive'} || 0;

  $cfg{'ftp_ext_passive'} = get_bool($msg,$def);

  $msg = "\nShould all other FTP connections be passive (y|n) ?";

}
else {
  $msg = "\nShould all FTP connections be passive (y|n) ?";
}

$def = $oldcfg{'ftp_int_passive'} || 0;

$cfg{'ftp_int_passive'} = get_bool($msg,$def);


#---------------------------------------------------------------------------

$def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};

$ans = Prompt("\nWhat is your local internet domain name :",$def);

$cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];

#---------------------------------------------------------------------------

$msg = <<EDQ;

If you specified some default hosts above, it is possible for me to
do some basic tests when you run 'make test'

This will cause 'make test' to be quite a bit slower and, if your
internet connection is via dialup, will require you to be on-line
unless the hosts are local.

Do you want me to run these tests (y|n) ?
EDQ

$cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});

#---------------------------------------------------------------------------

$msg = <<EDQ;

To allow Net::FTP to be tested I will need a hostname. This host
should allow anonymous access and have a /pub directory

What host can I use :
EDQ

$cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
	if $cfg{'test_hosts'};


print "\n";

#---------------------------------------------------------------------------

my $fh = IO::File->new($libnet_cfg_out, "w") or
	die "Cannot create '$libnet_cfg_out': $!";

print "Writing $libnet_cfg_out\n";

print $fh "{\n";

my $key;
foreach $key (keys %cfg) {
    my $val = $cfg{$key};
    if(!defined($val)) {
	$val = "undef";
    }
    elsif(ref($val)) {
	$val = '[' . join(",",
	    map {
		my $v = "undef";
		if(defined $_) {
		    ($v = $_) =~ s/'/\'/sog;
		    $v = "'" . $v . "'";
		}
		$v;
	    } @$val ) . ']';
    }
    else {
	$val =~ s/'/\'/sog;
	$val = "'" . $val . "'" if $val =~ /\D/;
    }
    print $fh "\t'",$key,"' => ",$val,",\n";
}

print $fh "}\n";

$fh->close;

############################################################################
############################################################################

exit 0;
!NO!SUBS!

close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
chdir $origdir;
Commit	Line	Data
406c51ee JH	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
1ae6ead9	21	open OUT, ">", $file or die "Can't create $file: $!";
406c51ee JH	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
a6fb92f1 JH	38	=head1 NAME
	39
	40	libnetcfg - configure libnet
	41
	42	=head1 DESCRIPTION
	43
d1be9408	44	The libnetcfg utility can be used to configure the libnet.
a6fb92f1	45	Starting from perl 5.8 libnet is part of the standard Perl
d1be9408	46	distribution, but the libnetcfg can be used for any libnet
a6fb92f1 JH	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
3e9bebd5	67	# libnetcfg -h for help
a6fb92f1 JH	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
4f4a06fc JH	78	"libnet.cfg", unless otherwise specified using the -i option,
4f4a06fc JH	79	C<-i oldfile>, and it is searched first from the current directory,
02c98640	80	and then from your module path.
a6fb92f1	81
02c98640	82	The default name of the new configuration file is "libnet.cfg", and by
a6fb92f1 JH	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
b2ea1669	88	L<Net::Config>, L<libnetFAQ>
a6fb92f1 JH	89
	90	=head1 AUTHORS
	91
	92	Graham Barr, the original Configure script of libnet.
	93
02c98640	94	Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
a6fb92f1 JH	95
	96	=cut
	97
406c51ee JH	98	# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
406c51ee JH	99
cee96d52	100	BEGIN { pop @INC if $INC[-1] eq '.' }
406c51ee JH	101	use strict;
	102	use IO::File;
	103	use Getopt::Std;
	104	use ExtUtils::MakeMaker qw(prompt);
a6fb92f1	105	use File::Spec;
406c51ee	106
a6fb92f1	107	use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
406c51ee JH	108
	109	##
	110	##
	111	##
	112
	113	my %cfg = ();
	114	my @cfg = ();
	115
a6fb92f1	116	my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
406c51ee JH	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:
28fb188d	222	Hostname '$host' does not seem to exist, please enter again
406c51ee JH	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
a6fb92f1 JH	333	getopts('dcho:i:');
	334
	335	$libnet_cfg_in = "libnet.cfg"
	336	unless(defined($libnet_cfg_in = $opt_i));
406c51ee	337
a6fb92f1 JH	338	$libnet_cfg_out = "libnet.cfg"
a6fb92f1 JH	339	unless(defined($libnet_cfg_out = $opt_o));
406c51ee JH	340
	341	my %oldcfg = ();
	342
	343	$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
a6fb92f1	344	if( -f $libnet_cfg_in )
406c51ee	345	{
a6fb92f1	346	%oldcfg = ( %{ do $libnet_cfg_in } );
406c51ee JH	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
a6fb92f1 JH	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
4f4a06fc JH	370	"libnet.cfg", unless otherwise specified using the -i option,
4f4a06fc JH	371	C<-i oldfile>, and it is searched first from the current directory,
a6d05634	372	and then from your module path.
a6fb92f1	373
a6d05634	374	The default name of the new configuration file is "libnet.cfg", and by
a6fb92f1 JH	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
406c51ee JH	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
28fb188d	688	do some basic tests when you run 'make test'
406c51ee	689
28fb188d	690	This will cause 'make test' to be quite a bit slower and, if your
406c51ee JH	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
a6fb92f1	717	my $fh = IO::File->new($libnet_cfg_out, "w") or
28fb188d	718	die "Cannot create '$libnet_cfg_out': $!";
406c51ee	719
a6fb92f1	720	print "Writing $libnet_cfg_out\n";
406c51ee JH	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;