This is realloc, not reallocf: be more careful :/.

[apt.git] / dselect / setup

#!/usr/bin/perl -w
#                              -*- Mode: Perl -*- 
# setup.pl --- 
# Author           : Manoj Srivastava ( srivasta@tiamat.datasync.com ) 
# Created On       : Wed Mar  4 15:11:47 1998
# Created On Node  : tiamat.datasync.com
# Last Modified By : Manoj Srivastava
# Last Modified On : Tue May 19 11:25:32 1998
# Last Machine Used: tiamat.datasync.com
# Update Count     : 87
# Status           : Unknown, Use with caution!
# HISTORY          : 
# Description      : 
# This file is designed to go into /usr/lib/apt/methods/setup
# 

#use strict;
#use diagnostics;
#printf STDERR "DEBUG: Arguments $ARGV[0];$ARGV[1];$ARGV[2];\n";


# Handle the arguments
my $vardir=$ARGV[0];
my $method=$ARGV[1];
my $option=$ARGV[2];
my $config_file = '/etc/apt/sources.list';

my $boldon=`setterm -bold on`;
my $boldoff=`setterm -bold off`;

my @known_types           = ('deb');
my @known_access         = ('http', 'ftp', 'file');
my @typical_distributions = ('stable', 'unstable', 'testing', 'non-US');
my @typical_components    = ('main', 'contrib', 'non-free');

my %known_access           = map {($_,$_)} @known_access;
my %typical_distributions  = map {($_,$_)} @typical_distributions;

# Read the config file, creating source records
sub read_config {
  my %params = @_;
  my @Config = ();
  
  die "Required parameter Filename Missing" unless
    $params{'Filename'};
  
  open (CONFIG, "$params{'Filename'}") ||
    die "Could not open $params{'Filename'}: $!";
  while (<CONFIG>) {
    chomp;
    my $rec = {};
    my ($type, $urn, $distribution, $components) = 
      m/^\s*(\S+)\s+(\S+)\s+(\S+)\s*(?:\s+(\S.*))?$/o;
    $rec->{'Type'}          = $type;
    $rec->{'URN'}           = $urn;
    $rec->{'Distribution'}  = $distribution;
    $rec->{'Components'}    = $components;
    push @Config, $rec;
  }
  close(CONFIG);
  
  return @Config;
}

# write the config file; writing out the current set of source records
sub write_config {
  my %params = @_;
  my $rec;
  my %Seen = ();
  
  die "Required parameter Filename Missing" unless
    $params{'Filename'};
  die "Required parameter Config Missing" unless
    $params{'Config'};
  
  open (CONFIG, ">$params{'Filename'}") ||
    die "Could not open $params{'Filename'} for writing: $!";
  for $rec (@{$params{'Config'}}) {
        my $line = "$rec->{'Type'} $rec->{'URN'} $rec->{'Distribution'} ";
    $line .= "$rec->{'Components'}" if $rec->{'Components'};
    $line .= "\n";
    print CONFIG $line unless $Seen{$line}++;
  }
  close(CONFIG);
}

# write the config file; writing out the current set of source records
sub print_config {
  my %params = @_;
  my $rec;
  my %Seen = ();
  
  die "Required parameter Config Missing" unless
    $params{'Config'};
  
  for $rec (@{$params{'Config'}}) {
    next unless $rec;
    
    my $line = "$rec->{'Type'} " if $rec->{'Type'};
    $line .= "$rec->{'URN'} " if $rec->{'URN'};
    $line .= "$rec->{'Distribution'} " if $rec->{'Distribution'};
    $line .= "$rec->{'Components'}" if $rec->{'Components'};
    $line .= "\n";
    print $line unless $Seen{$line}++;
  }
}

# Ask for and add a source record
sub get_source {
  my %params = @_;
  my $rec = {};
  my $answer;
  my ($type, $urn, $distribution, $components);
  
  if ($params{'Default'}) {
    ($type, $urn, $distribution, $components) = 
      $params{'Default'} =~ m/^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S.*)$/o;
  }

  $type         = 'deb';
  $urn          = "http://http.us.debian.org/debian" unless $urn;
  $distribution = "stable" unless $distribution;
  $components   = "main contrib non-free" unless $components;

    
  $rec->{'Type'} = 'deb';
  $| = 1;

  my $done = 0;
  
  while (!$done) {
    print "\n";
    print "$boldon URL [$urn]: $boldoff";
    
    $answer=<STDIN>;
    chomp ($answer);
    $answer =~ s/\s*//og;
    
    if ($answer =~ /^\s*$/o) {
      $rec->{'URN'} = $urn;
      last;
    }
    else {
      my ($scheme) = $answer =~ /^\s*([^:]+):/o;
      if (! defined $known_access{$scheme}) {
	print "Unknown access scheme $scheme in $answer\n";
	print "    The available access methods known to me are\n";
	print join (' ', @known_access), "\n";
	print "\n";
      }
      else {
	$rec->{'URN'} = $answer;
	last;
      }
    }
  }

  print "\n";
  
  print " Please give the distribution tag to get or a path to the\n";
  print " package file ending in a /. The distribution\n";
  print " tags are typically something like:$boldon ";
  print join(' ', @typical_distributions), "$boldoff\n";
  print "\n";
  print "$boldon Distribution [$distribution]:$boldoff ";
  $answer=<STDIN>;
  chomp ($answer);
  $answer =~ s/\s*//og;
  
  if ($answer =~ /^\s*$/o) {
    $rec->{'Distribution'} = $distribution;
    $rec->{'Components'}   = &get_components($components);
  }
  elsif ($answer =~ m|/$|o) {
    $rec->{'Distribution'} = "$answer";
    $rec->{'Components'}   = "";
  }
  else {
    # A distribution tag, eh?
    warn "$answer does not seem to be a typical distribution tag\n"
      unless defined $typical_distributions{$answer};
    
    $rec->{'Distribution'} = "$answer";
    $rec->{'Components'}   = &get_components($components);
  }

  return $rec;
}

sub get_components {
  my $default = shift;
  my $answer;
  
  print "\n";
  print " Please give the components to get\n";
  print " The components are typically something like:$boldon ";
  print join(' ', @typical_components), "$boldoff\n";
  print "\n";
  print "$boldon Components [$default]:$boldoff ";
  $answer=<STDIN>;
  chomp ($answer);
  $answer =~ s/\s+/ /og;
  
  if ($answer =~ /^\s*$/o) {
    return $default;
  }
  else {
    return $answer;
  }
}

sub get_sources {
  my @Config = ();
  my $done = 0;

  my @Oldconfig = ();
  
  if (-e $config_file) {
    @Oldconfig = &read_config('Filename' => $config_file)
  }

  print "\t$boldon Set up a list of distribution source locations $boldoff \n";
  print "\n";

  print " Please give the base URL of the debian distribution.\n";
  print " The access schemes I know about are:$boldon ";
  print join (' ', @known_access), "$boldoff\n";
#  print " The mirror scheme is special  that it does not specify the\n";
#  print " location of a debian archive but specifies the location\n";
#  print " of a list of mirrors to use to access the archive.\n";
  print "\n";
  print " For example:\n";
  print "              file:/mnt/debian,\n";
  print "              ftp://ftp.debian.org/debian,\n";
  print "              http://ftp.de.debian.org/debian,\n";
#  print " and the special mirror scheme,\n";
#  print "              mirror:http://www.debian.org/archivemirrors \n";
  print "\n";

  my $index = 0;
  while (!$done) {
    if ($Oldconfig[$index]) {
      push (@Config, &get_source('Default' => $Oldconfig[$index++]));
    }
    else {
      push (@Config, &get_source());
    }
    print "\n";
    print "$boldon Would you like to add another source?[y/N]$boldoff ";
    my $answer = <STDIN>;
    chomp ($answer);
    $answer =~ s/\s+/ /og;
    if ($answer =~ /^\s*$/o) {
      last;
    }
    elsif ($answer !~ m/\s*y/io) {
      last;
    } 
  }
  
  return @Config;
}

sub main {
  if (-e $config_file) {
    my @Oldconfig = &read_config('Filename' => $config_file);
    
    print "$boldon I see you already have a source list.$boldoff\n";
    print "-" x 72, "\n";
    &print_config('Config' => \@Oldconfig);
    print "-" x 72, "\n";
    print "$boldon Do you wish to overwrite it? [y/N]$boldoff ";
    my $answer = <STDIN>;
    chomp ($answer);
    $answer =~ s/\s+/ /og;
    exit 0 unless $answer =~ m/\s*y/io;
  }
  # OK. They want to be here.
  my @Config = &get_sources();
  #&print_config('Config' => \@Config);
  &write_config('Config' => \@Config, 'Filename' => $config_file);  
}

&main();