dselect/setup

   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', 'testing', '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 overwrite 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