home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Archived / Updates / Perl / libwww_for_perl_109 / site_perl / Configure < prev    next >
Text File  |  1997-11-05  |  11KB  |  540 lines
  1. #!/usr/local/bin/perl
  2. #
  3. # $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
  4.  
  5. use strict;
  6. use IO::File;
  7. use Getopt::Std;
  8. use ExtUtils::MakeMaker qw(prompt);
  9.  
  10. use vars qw($opt_d $opt_o);
  11.  
  12. ##
  13. ##
  14. ##
  15.  
  16. my %cfg = ();
  17. my @cfg = ();
  18.  
  19. my($config_pm,$msg,$ans,$def,$have_old);
  20.  
  21. ##
  22. ##
  23. ##
  24.  
  25. sub valid_host
  26. {
  27.  my $h = shift;
  28.  
  29.  defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
  30. }
  31.  
  32. ##
  33. ##
  34. ##
  35.  
  36. sub test_hostnames (\@)
  37. {
  38.  my $hlist = shift;
  39.  my @h = ();
  40.  my $host;
  41.  my $err = 0;
  42.  
  43.  foreach $host (@$hlist)
  44.   {
  45.    if(valid_host($host))
  46.     {
  47.      push(@h, $host);
  48.      next;
  49.     }
  50.    warn "Bad hostname: '$host'\n";
  51.    $err++;
  52.   }
  53.  @$hlist = @h;
  54.  $err ? join(" ",@h) : undef;
  55. }
  56.  
  57. ##
  58. ##
  59. ##
  60.  
  61. sub Prompt
  62. {
  63.  my($prompt,$def) = @_;
  64.  
  65.  $def = "" unless defined $def;
  66.  
  67.  chomp($prompt);
  68.  
  69.  if($opt_d)
  70.   {
  71.    print $prompt,," [",$def,"]\n";
  72.    return $def;
  73.   }
  74.  prompt($prompt,$def);
  75. }
  76.  
  77. ##
  78. ##
  79. ##
  80.  
  81. sub get_host_list
  82. {
  83.  my($prompt,$def) = @_;
  84.  
  85.  $def = join(" ",@$def) if ref($def);
  86.  
  87.  my @hosts;
  88.  
  89.  do
  90.   {
  91.    my $ans = Prompt($prompt,$def);
  92.  
  93.    $ans =~ s/(\A\s+|\s+\Z)//g;
  94.  
  95.    @hosts = split(/\s+/, $ans);
  96.   }
  97.  while(@hosts && defined($def = test_hostnames(@hosts)));
  98.  
  99.  \@hosts;
  100. }
  101.  
  102. ##
  103. ##
  104. ##
  105.  
  106. sub get_hostname
  107. {
  108.  my($prompt,$def) = @_;
  109.  
  110.  my $host;
  111.  
  112.  while(1)
  113.   {
  114.    my $ans = Prompt($prompt,$def);
  115.    $host = ($ans =~ /(\S*)/)[0];
  116.    last
  117.     if(!length($host) || valid_host($host));
  118.  
  119.    $def =""
  120.     if $def eq $host;
  121.  
  122.    print <<"EDQ";
  123.  
  124. *** ERROR:
  125.     Hostname `$host' does not seem to exist, please enter again
  126.     or a single space to clear any default
  127.  
  128. EDQ
  129.   }
  130.  
  131.  length $host
  132.     ? $host
  133.     : undef;
  134. }
  135.  
  136. ##
  137. ##
  138. ##
  139.  
  140. sub get_bool ($$)
  141. {
  142.  my($prompt,$def) = @_;
  143.  
  144.  chomp($prompt);
  145.  
  146.  my $val = Prompt($prompt,$def ? "yes" : "no");
  147.  
  148.  $val =~ /^y/i ? 1 : 0;
  149. }
  150.  
  151. ##
  152. ##
  153. ##
  154.  
  155. sub default_hostname
  156. {
  157.  my $host;
  158.  my @host;
  159.  
  160.  foreach $host (@_)
  161.   {
  162.    if(defined($host) && valid_host($host))
  163.     {
  164.      return $host
  165.     unless wantarray;
  166.      push(@host,$host);
  167.     }
  168.   }
  169.  
  170.  return wantarray ? @host : undef;
  171. }
  172.  
  173. ##
  174. ##
  175. ##
  176.  
  177. getopts('do:');
  178.  
  179. $config_pm = "libnet.cfg"
  180.     unless(defined($config_pm = $opt_o));
  181.  
  182. $have_old = -f $config_pm
  183.     ? require $config_pm
  184.     : eval { require Net::Config };
  185.  
  186. my %oldcfg = ();
  187.  
  188. %oldcfg = %Net::Config::NetConfig
  189.     if $have_old;
  190.  
  191. map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
  192.  
  193. $oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
  194. $oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
  195.  
  196. #---------------------------------------------------------------------------
  197.  
  198. if(!-f $config_pm && $have_old && !$opt_d)
  199.  {
  200.   $msg = <<EDQ;
  201.  
  202. Ah, I see you already have installed libnet before.
  203.  
  204. Do you want to modify/update your configuration (y|n) ?
  205. EDQ
  206.  
  207.  $opt_d = 1
  208.     unless get_bool($msg,0);
  209.  }
  210.  
  211. #---------------------------------------------------------------------------
  212.  
  213. $msg = <<EDQ;
  214.  
  215. This script will prompt you to enter hostnames that can be used as
  216. defaults for some of the modules in the libnet distribution.
  217.  
  218. To ensure that you do not enter an invalid hostname, I can perform a
  219. lookup on each hostname you enter. If your internet connection is via
  220. a dialup line then you may not want me to perform these lookups, as
  221. it will require you to be on-line.
  222.  
  223. Do you want me to perform hostname lookups (y|n) ?
  224. EDQ
  225.  
  226. $cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
  227.  
  228. print <<EDQ unless $cfg{'test_exist'};
  229.  
  230. *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
  231.  
  232. OK I will not check if the hostnames you give are valid
  233. so be very cafeful
  234.  
  235. *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
  236. EDQ
  237.  
  238.  
  239. #---------------------------------------------------------------------------
  240.  
  241. print <<EDQ;
  242.  
  243. The following questions all require a list of host names, separated
  244. with spaces. If you do not have a host available for any of the
  245. services, then enter a single space, followed by <CR>. To accept the
  246. default, hit <CR>
  247.  
  248. EDQ
  249.  
  250. $msg = 'Enter a list of available NNTP hosts :';
  251.  
  252. $def = $oldcfg{'nntp_hosts'} ||
  253.     [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
  254.  
  255. $cfg{'nntp_hosts'} = get_host_list($msg,$def);
  256.  
  257. #---------------------------------------------------------------------------
  258.  
  259. $msg = 'Enter a list of available SMTP hosts :';
  260.  
  261. $def = $oldcfg{'smtp_hosts'} ||
  262.     [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
  263.  
  264. $cfg{'smtp_hosts'} = get_host_list($msg,$def);
  265.  
  266. #---------------------------------------------------------------------------
  267.  
  268. $msg = 'Enter a list of available POP3 hosts :';
  269.  
  270. $def = $oldcfg{'pop3_hosts'} || [];
  271.  
  272. $cfg{'pop3_hosts'} = get_host_list($msg,$def);
  273.  
  274. #---------------------------------------------------------------------------
  275.  
  276. $msg = 'Enter a list of available SNPP hosts :';
  277.  
  278. $def = $oldcfg{'snpp_hosts'} || [];
  279.  
  280. $cfg{'snpp_hosts'} = get_host_list($msg,$def);
  281.  
  282. #---------------------------------------------------------------------------
  283.  
  284. $msg = 'Enter a list of available PH Hosts   :'  ;
  285.  
  286. $def = $oldcfg{'ph_hosts'} ||
  287.     [ default_hostname('dirserv') ];
  288.  
  289. $cfg{'ph_hosts'}   =  get_host_list($msg,$def);
  290.  
  291. #---------------------------------------------------------------------------
  292.  
  293. $msg = 'Enter a list of available TIME Hosts   :'  ;
  294.  
  295. $def = $oldcfg{'time_hosts'} || [];
  296.  
  297. $cfg{'time_hosts'} = get_host_list($msg,$def);
  298.  
  299. #---------------------------------------------------------------------------
  300.  
  301. $msg = 'Enter a list of available DAYTIME Hosts   :'  ;
  302.  
  303. $def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
  304.  
  305. $cfg{'daytime_hosts'} = get_host_list($msg,$def);
  306.  
  307. #---------------------------------------------------------------------------
  308.  
  309. $msg = <<EDQ;
  310.  
  311. Some companies access the internet via a firewall machine, and all
  312. FTP access must be dove via this machine.
  313.  
  314. If to gain FTP access to a machine beyond a firewall, you have to use
  315. a FTP proxy machine and login as username\@remote.host then enter
  316. the name of that gateway here.
  317.  
  318. FTP proxy hostname :
  319. EDQ
  320.  
  321. $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
  322.  
  323. $cfg{'ftp_firewall'} = get_hostname($msg,$def);
  324.  
  325. #---------------------------------------------------------------------------
  326.  
  327. ###$msg =<<EDQ;
  328. ###
  329. ###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
  330. ###then enter a list of hostames
  331. ###
  332. ###Enter a list of available SOCKS hosts :
  333. ###EDQ
  334. ###
  335. ###$def = $cfg{'socks_hosts'} ||
  336. ###    [ default_hostname($ENV{SOCKS5_SERVER},
  337. ###               $ENV{SOCKS_SERVER},
  338. ###               $ENV{SOCKS4_SERVER}) ];
  339. ###
  340. ###$cfg{'socks_hosts'}   =  get_host_list($msg,$def);
  341.  
  342. #---------------------------------------------------------------------------
  343.  
  344. print <<EDQ;
  345.  
  346. Normally when FTP needs a data connection the client tells the server
  347. a port to connect to, and the server initiates a connection to the client.
  348.  
  349. Some setups, in particular firewall setups, can/do not work using this
  350. protocol. In these situations the client must make the connection to the
  351. server, this is called a passive transfer.
  352. EDQ
  353.  
  354. $msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
  355.  
  356. $def = $oldcfg{'ftp_ext_passive'} || 0;
  357.  
  358. $cfg{'ftp_ext_passive'} = get_bool($msg,$def);
  359.  
  360.  
  361. $def = $oldcfg{'ftp_int_passive'} || 0;
  362.  
  363. $msg = "\nShould all other FTP connections be passive (y|n) ?";
  364.  
  365. $cfg{'ftp_int_passive'} = get_bool($msg,$def);
  366.  
  367.  
  368. #---------------------------------------------------------------------------
  369.  
  370. $def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
  371.  
  372. $ans = Prompt("\nWhat is your local internet domain name :",$def);
  373.  
  374. $cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
  375.  
  376. #---------------------------------------------------------------------------
  377.  
  378. $msg = <<EDQ;
  379.  
  380. If you specified some default hosts above, it is possible for me to
  381. do some basic tests when you run `make test'
  382.  
  383. This will cause `make test' to be quite a bit slower and, if your
  384. internet connection is via dialup, will require you to be on-line
  385. unless the hosts are local.
  386.  
  387. Do you want me to run these tests (y|n) ?
  388. EDQ
  389.  
  390. $cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
  391.  
  392. #---------------------------------------------------------------------------
  393.  
  394. $msg = <<EDQ;
  395.  
  396. To allow Net::FTP to be tested I will need a hostname. This host
  397. should allow anonymous access and have a /pub directory
  398.  
  399. What host can I use :
  400. EDQ
  401.  
  402. $cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
  403.     if $cfg{'test_hosts'};
  404.  
  405.  
  406. print "\n";
  407.  
  408. #---------------------------------------------------------------------------
  409.  
  410. my @old = ();
  411.  
  412. if($have_old && exists $INC{$config_pm}) {
  413.     my $fh = IO::File->new($INC{$config_pm}, "r");
  414.     @old = $fh->getlines;
  415.     while(@old) {
  416.     last if(shift(@old) =~ /^%NetConfig/);
  417.     }
  418.     while(@old) {
  419.     last if(pop(@old) =~ /^\s*\);/);
  420.     }
  421.     pop @old
  422.     while(@old && $old[-1] !~ /[^\w\n]/);
  423.     $old[-1] =~ s/,?\s*\n/,\n/
  424.     if @old;
  425.     $fh->close;
  426. }
  427.  
  428. my $fh = IO::File->new($config_pm, "w") or
  429.     die "Cannot create `$config_pm': $!";
  430.  
  431. print "Writing $config_pm\n";
  432.  
  433. $fh->print(<DATA>,
  434.        "\%NetConfig = (\n",
  435.         @old);
  436.  
  437. my $key;
  438. foreach $key (keys %cfg) {
  439.     my $val = $cfg{$key};
  440.     if(!defined($val)) {
  441.     $val = "undef";
  442.     }
  443.     elsif(ref($val)) {
  444.     $val = '[' . join(",",
  445.         map {
  446.         my $v = "undef";
  447.         if(defined $_) {
  448.             ($v = $_) =~ s/'/\'/sog;
  449.             $v = "'" . $v . "'";
  450.         }
  451.         $v;
  452.         } @$val ) . ']';
  453.     }
  454.     else {
  455.     $val =~ s/'/\'/sog;
  456.     $val = "'" . $val . "'";
  457.     }
  458.     $fh->print("\t",$key," => ",$val,",\n");
  459. }
  460.  
  461. $fh->print(");\n1;\n");
  462.  
  463. $fh->close;
  464.  
  465. ############################################################################
  466. ############################################################################
  467.  
  468. exit 0;
  469.  
  470. __DATA__
  471. package Net::Config;
  472.  
  473. require Exporter;
  474. use vars qw(@ISA @EXPORT %NetConfig);
  475. use strict;
  476.  
  477. @EXPORT = qw(%NetConfig);
  478. @ISA = qw(Exporter);
  479.  
  480. sub set
  481. {
  482.  my $pkg = shift if @_ % 2;
  483.  my %cfg = @_;
  484.  
  485.  return unless @_;
  486.  
  487.  # Only require these modules if we need to
  488.  require Data::Dumper;
  489.  require IO::File;
  490.  require Carp;
  491.  require File::Copy;
  492.     
  493.  my $mod = $INC{'Net/Config.pm'} or
  494.     Carp::croak("Can't find myself");
  495.  
  496.  my $bak = $mod . "~";
  497.  
  498.  print "Updating $mod...\n";
  499.  
  500.  File::Copy::copy($mod,$bak) or
  501.     Carp::croak("Cannot create backup file $bak: $!");
  502.  
  503.  print "...backup at $bak\n";
  504.  
  505.  my $old = new IO::File $bak,"r" or
  506.     Carp::croak("Can't open $bak: $!");
  507.  
  508.  my $new = new IO::File $mod,"w" or
  509.     Carp::croak("Can't open $mod: $!");
  510.  
  511.  # If we fail below, then we must restore from backup
  512.  local $SIG{'__DIE__'} = sub {
  513.         print "Restoring $mod from backup!!\n";
  514.         unlink $mod;
  515.         rename $bak, $mod;
  516.         print "Done.\n";
  517.         exit 1;
  518.        };
  519.  
  520.  %NetConfig = (%NetConfig, %cfg);
  521.  
  522.  while (<$old>)
  523.   {
  524.    last if /^%NetConfig/;
  525.    $new->print($_);
  526.   }
  527.  
  528.  $new->print ( Data::Dumper->Dump([\%NetConfig],['*NetConfig']) );
  529.  
  530.  $new->print("\n1;\n");
  531.  
  532.  close $old;
  533.  close $new;
  534. }
  535.  
  536. # WARNING  WARNING  WARNING  WARNING  WARNING  WARNING  WARNING
  537. # WARNING  WARNING  WARNING  WARNING  WARNING  WARNING  WARNING
  538. #
  539. # Below this line is auto-generated, *ANY* changes will be lost
  540.