home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 February / PCWorld_2000-02_cd.bin / live / usr / lib / dpkg / methods / apt / setup < prev    next >
Text File  |  1999-07-08  |  8KB  |  287 lines
  1. #!/usr/bin/perl -w
  2. #                              -*- Mode: Perl -*- 
  3. # setup.pl --- 
  4. # Author           : Manoj Srivastava ( srivasta@tiamat.datasync.com ) 
  5. # Created On       : Wed Mar  4 15:11:47 1998
  6. # Created On Node  : tiamat.datasync.com
  7. # Last Modified By : Manoj Srivastava
  8. # Last Modified On : Tue May 19 11:25:32 1998
  9. # Last Machine Used: tiamat.datasync.com
  10. # Update Count     : 87
  11. # Status           : Unknown, Use with caution!
  12. # HISTORY          : 
  13. # Description      : 
  14. # This file is designed to go into /usr/lib/apt/methods/setup
  15. # 
  16.  
  17. #use strict;
  18. #use diagnostics;
  19. #printf STDERR "DEBUG: Arguments $ARGV[0];$ARGV[1];$ARGV[2];\n";
  20.  
  21.  
  22. # Handle the arguments
  23. my $vardir=$ARGV[0];
  24. my $method=$ARGV[1];
  25. my $option=$ARGV[2];
  26. my $config_file = '/etc/apt/sources.list';
  27.  
  28. my $boldon=`setterm -bold on`;
  29. my $boldoff=`setterm -bold off`;
  30.  
  31. my @known_types           = ('deb');
  32. my @known_access         = ('http', 'ftp', 'file');
  33. my @typical_distributions = ('stable', 'unstable', 'frozen', 'non-US');
  34. my @typical_components    = ('main', 'contrib', 'non-free');
  35.  
  36. my %known_access           = map {($_,$_)} @known_access;
  37. my %typical_distributions  = map {($_,$_)} @typical_distributions;
  38.  
  39. # Read the config file, creating source records
  40. sub read_config {
  41.   my %params = @_;
  42.   my @Config = ();
  43.   
  44.   die "Required parameter Filename Missing" unless
  45.     $params{'Filename'};
  46.   
  47.   open (CONFIG, "$params{'Filename'}") ||
  48.     die "Could not open $params{'Filename'}: $!";
  49.   while (<CONFIG>) {
  50.     chomp;
  51.     my $rec = {};
  52.     my ($type, $urn, $distribution, $components) = 
  53.       m/^\s*(\S+)\s+(\S+)\s+(\S+)\s*(?:\s+(\S.*))?$/o;
  54.     $rec->{'Type'}          = $type;
  55.     $rec->{'URN'}           = $urn;
  56.     $rec->{'Distribution'}  = $distribution;
  57.     $rec->{'Components'}    = $components;
  58.     push @Config, $rec;
  59.   }
  60.   close(CONFIG);
  61.   
  62.   return @Config;
  63. }
  64.  
  65. # write the config file; writing out the current set of source records
  66. sub write_config {
  67.   my %params = @_;
  68.   my $rec;
  69.   my %Seen = ();
  70.   
  71.   die "Required parameter Filename Missing" unless
  72.     $params{'Filename'};
  73.   die "Required parameter Config Missing" unless
  74.     $params{'Config'};
  75.   
  76.   open (CONFIG, ">$params{'Filename'}") ||
  77.     die "Could not open $params{'Filename'} for writing: $!";
  78.   for $rec (@{$params{'Config'}}) {
  79.         my $line = "$rec->{'Type'} $rec->{'URN'} $rec->{'Distribution'} ";
  80.     $line .= "$rec->{'Components'}" if $rec->{'Components'};
  81.     $line .= "\n";
  82.     print CONFIG $line unless $Seen{$line}++;
  83.   }
  84.   close(CONFIG);
  85. }
  86.  
  87. # write the config file; writing out the current set of source records
  88. sub print_config {
  89.   my %params = @_;
  90.   my $rec;
  91.   my %Seen = ();
  92.   
  93.   die "Required parameter Config Missing" unless
  94.     $params{'Config'};
  95.   
  96.   for $rec (@{$params{'Config'}}) {
  97.     next unless $rec;
  98.     
  99.     my $line = "$rec->{'Type'} " if $rec->{'Type'};
  100.     $line .= "$rec->{'URN'} " if $rec->{'URN'};
  101.     $line .= "$rec->{'Distribution'} " if $rec->{'Distribution'};
  102.     $line .= "$rec->{'Components'}" if $rec->{'Components'};
  103.     $line .= "\n";
  104.     print $line unless $Seen{$line}++;
  105.   }
  106. }
  107.  
  108. # Ask for and add a source record
  109. sub get_source {
  110.   my %params = @_;
  111.   my $rec = {};
  112.   my $answer;
  113.   my ($type, $urn, $distribution, $components);
  114.   
  115.   if ($params{'Default'}) {
  116.     ($type, $urn, $distribution, $components) = 
  117.       $params{'Default'} =~ m/^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S.*)$/o;
  118.   }
  119.  
  120.   $type         = 'deb';
  121.   $urn          = "http://http.us.debian.org/debian" unless $urn;
  122.   $distribution = "stable" unless $distribution;
  123.   $components   = "main contrib non-free" unless $components;
  124.  
  125.     
  126.   $rec->{'Type'} = 'deb';
  127.   $| = 1;
  128.  
  129.   my $done = 0;
  130.   
  131.   while (!$done) {
  132.     print "\n";
  133.     print "$boldon URL [$urn]: $boldoff";
  134.     
  135.     $answer=<STDIN>;
  136.     chomp ($answer);
  137.     $answer =~ s/\s*//og;
  138.     
  139.     if ($answer =~ /^\s*$/o) {
  140.       $rec->{'URN'} = $urn;
  141.       last;
  142.     }
  143.     else {
  144.       my ($scheme) = $answer =~ /^\s*([^:]+):/o;
  145.       if (! defined $known_access{$scheme}) {
  146.     print "Unknown access scheme $scheme in $answer\n";
  147.     print "    The available access methods known to me are\n";
  148.     print join (' ', @known_access), "\n";
  149.     print "\n";
  150.       }
  151.       else {
  152.     $rec->{'URN'} = $answer;
  153.     last;
  154.       }
  155.     }
  156.   }
  157.  
  158.   print "\n";
  159.   
  160.   print " Please give the distribution tag to get or a path to the\n";
  161.   print " package file ending in a /. The distribution\n";
  162.   print " tags are typically something like:$boldon ";
  163.   print join(' ', @typical_distributions), "$boldoff\n";
  164.   print "\n";
  165.   print "$boldon Distribution [$distribution]:$boldoff ";
  166.   $answer=<STDIN>;
  167.   chomp ($answer);
  168.   $answer =~ s/\s*//og;
  169.   
  170.   if ($answer =~ /^\s*$/o) {
  171.     $rec->{'Distribution'} = $distribution;
  172.     $rec->{'Components'}   = &get_components($components);
  173.   }
  174.   elsif ($answer =~ m|/$|o) {
  175.     $rec->{'Distribution'} = "$answer";
  176.     $rec->{'Components'}   = "";
  177.   }
  178.   else {
  179.     # A distribution tag, eh?
  180.     warn "$answer does not seem to be a typical distribution tag\n"
  181.       unless defined $typical_distributions{$answer};
  182.     
  183.     $rec->{'Distribution'} = "$answer";
  184.     $rec->{'Components'}   = &get_components($components);
  185.   }
  186.  
  187.   return $rec;
  188. }
  189.  
  190. sub get_components {
  191.   my $default = shift;
  192.   my $answer;
  193.   
  194.   print "\n";
  195.   print " Please give the components to get\n";
  196.   print " The components are typically something like:$boldon ";
  197.   print join(' ', @typical_components), "$boldoff\n";
  198.   print "\n";
  199.   print "$boldon Components [$default]:$boldoff ";
  200.   $answer=<STDIN>;
  201.   chomp ($answer);
  202.   $answer =~ s/\s+/ /og;
  203.   
  204.   if ($answer =~ /^\s*$/o) {
  205.     return $default;
  206.   }
  207.   else {
  208.     return $answer;
  209.   }
  210. }
  211.  
  212. sub get_sources {
  213.   my @Config = ();
  214.   my $done = 0;
  215.  
  216.   my @Oldconfig = ();
  217.   
  218.   if (-e $config_file) {
  219.     @Oldconfig = &read_config('Filename' => $config_file)
  220.   }
  221.  
  222.   print "\t$boldon Set up a list of distribution source locations $boldoff \n";
  223.   print "\n";
  224.  
  225.   print " Please give the base URL of the debian distribution.\n";
  226.   print " The access schemes I know about are:$boldon ";
  227.   print join (' ', @known_access), "$boldoff\n";
  228. #  print " The mirror scheme is special  that it does not specify the\n";
  229. #  print " location of a debian archive but specifies the location\n";
  230. #  print " of a list of mirrors to use to access the archive.\n";
  231.   print "\n";
  232.   print " For example:\n";
  233.   print "              file:/mnt/debian,\n";
  234.   print "              ftp://ftp.debian.org/debian,\n";
  235.   print "              http://ftp.de.debian.org/debian,\n";
  236. #  print " and the special mirror scheme,\n";
  237. #  print "              mirror:http://www.debian.org/archivemirrors \n";
  238.   print "\n";
  239.  
  240.   my $index = 0;
  241.   while (!$done) {
  242.     if ($Oldconfig[$index]) {
  243.       push (@Config, &get_source('Default' => $Oldconfig[$index++]));
  244.     }
  245.     else {
  246.       push (@Config, &get_source());
  247.     }
  248.     print "\n";
  249.     print "$boldon Would you like to add another source?[y/N]$boldoff ";
  250.     my $answer = <STDIN>;
  251.     chomp ($answer);
  252.     $answer =~ s/\s+/ /og;
  253.     if ($answer =~ /^\s*$/o) {
  254.       last;
  255.     }
  256.     elsif ($answer !~ m/\s*y/io) {
  257.       last;
  258.     } 
  259.   }
  260.   
  261.   return @Config;
  262. }
  263.  
  264. sub main {
  265.   if (-e $config_file) {
  266.     my @Oldconfig = &read_config('Filename' => $config_file);
  267.     
  268.     print "$boldon I see you already have a source list.$boldoff\n";
  269.     print "-" x 72, "\n";
  270.     &print_config('Config' => \@Oldconfig);
  271.     print "-" x 72, "\n";
  272.     print "$boldon Do you wish to change it?[y/N]$boldoff ";
  273.     my $answer = <STDIN>;
  274.     chomp ($answer);
  275.     $answer =~ s/\s+/ /og;
  276.     exit 0 unless $answer =~ m/\s*y/io;
  277.   }
  278.   # OK. They want to be here.
  279.   my @Config = &get_sources();
  280.   #&print_config('Config' => \@Config);
  281.   &write_config('Config' => \@Config, 'Filename' => $config_file);  
  282. }
  283.  
  284. &main();
  285.  
  286.  
  287.