FM / apt

/usr/lib/dpkg/methods/apt

Name	Size	Mode	Actions
desc.apt	567	0644	edit dl rm
install	2861	0755	edit dl rm
names	39	0644	edit dl rm
setup	7728	0755	edit dl rm
update	1242	0755	edit dl rm

Edit: /usr/lib/dpkg/methods/apt/setup (7728B)

#!/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();

cmd: