* Download a set of packages into a pool structure for use as a partial mirror
#!/usr/bin/perl -w
#
# Do Custom Download 0.4
# Download a set of packages and sources for a custom deb pool
# Copyright (C) 2007 Daniel Dickinson
#
# This program is free software; you can redistribute it and/or modify
# it under the terms version 2 of the GNU General Public License as
# published by the Free Software Foundation.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#

# Core modules
use IO::File;
use strict;
use warnings;
use File::Temp;
use Fcntl qw/F_SETFD F_GETFD/;
use Cwd;

# libcarp-clan-perl
use Carp::Clan;

# libgetopt-mixed-perl
use Getopt::Mixed "nextOption";

# libapt-pkg-perl
use AptPkg::Config '$_config';
use AptPkg::System '$_system';
use AptPkg::Version;


use constant TRUE => 1;
use constant FALSE => 0;

use constant EXIT_OK => 0;
use constant EXIT_BAD_COMMAND_LINE => 1;
use constant EXIT_UNREADABLE_FILE => 2;
use constant EXIT_REPEATED_FIELD => 3;
use constant EXIT_MISSING_FIELD => 4;
use constant EXIT_MULTIPLE_STDIN => 5;
use constant EXIT_BAD_ARCHIVE => 6;
use constant EXIT_MISSING_FIELD_NAME => 7;
use constant EXIT_BAD_SOURCE_FILES_FIELD => 8;
use constant EXIT_STDIN_ERR => 9;
use constant EXIT_FILE_OPEN_FAILED => 10;
use constant EXIT_NO_HIGH_FIELDS => 11;
use constant EXIT_NO_VERSION_FOR_PACKAGE => 12;
use constant EXIT_CHDIR_FAILED => 13;
use constant EXIT_WGET_TEMP_CLEARONEXEC_FAILED => 14;
use constant EXIT_CWD_CHDIR_FAILED => 15;

use constant GERMINATE_HEADER_LINES => 2;

my $pkg_control_dir = '';
my @distros;
my @components;
my @ignore_missing;
my $include_installer = TRUE;
my $from_germinate = FALSE;
my $quiet = FALSE;
my $verbose = 0;
my $source_list_filename;
my $binary_list_filename;
my $pool_dir;
my $archive = 'http://archive.debian.org/debian/';
my %binaries;
my %sources;
my @archs;
my $filename;
my $wget_list_handle;
my $wget_filename;
my %apt_ftparchive_file;
my $download_size = 0;
my $skip_download = FALSE;
my $keep_wget_file = FALSE;

my @required_binary_fields = qw/Package Version Filename Architecture Size/;
my @required_source_fields = qw/Package Version Directory Architecture Files/;

# TODO: _FileList & SourceList for dists/components/Packages.gz

&parse_command_line();

if ((defined $pkg_control_dir) && ($pkg_control_dir ne '')) {
if (substr ($pkg_control_dir, -1, 1) ne '/') {
$pkg_control_dir .= '/';
}
} else {
$pkg_control_dir = '';
}

if ((defined $pool_dir) && ($pool_dir ne '')) {
if (substr ($pool_dir, -1, 1) ne '/') {
$pool_dir .= '/';
}
} else {
$pool_dir = '';
}

if ($verbose > 0) {
print "Base dir for package control files: $pkg_control_dir\n";
}

if ((defined $archive) && ($archive ne '')) {
if (substr ($archive, -1, 1) ne '/') {
$archive .= '/';
}
} else {
&print_error_exit("You specified an empty or invalid archive for downloads.\n",
EXIT_BAD_ARCHIVE);
}

if ($verbose > 0) {
print "Mirror archive for downloads: $archive\n";
}

if (!$quiet) {
print "Initializing package & source database...";
}

&parse_package_control_files($pkg_control_dir, \@distros, \@components,
$include_installer);

if (!$quiet) {
print "ok\n";
}

if (!$quiet) {
print "Processing package lists...";
}

if (!$keep_wget_file) {
$wget_list_handle = new File::Temp();
} else {
$wget_list_handle = new IO::File $wget_filename, "w";
}

&process_package_lists($binary_list_filename, $source_list_filename);

if (!$quiet) {
print "ok\n";
}

if (!$quiet) {
print "Initiating download...";
}

if (!$skip_download) {
&do_download();
} else {
print "skipped\n";
}

sub do_download {
my $cwd = getcwd();

if ($pool_dir ne '') {
if (!chdir($pool_dir)) {
print_error_exit("Unable to change to directory $pool_dir\n",
EXIT_CHDIR_FAILED);
}
}
if (!(fcntl($wget_list_handle, F_SETFD, 0))) {
print_error_exit("Couldn't clear close-on-exec flag on temp filehandle: $wget_list_handle",
EXIT_WGET_TEMP_CLEARONEXEC_FAILED);
}
my $wgetfile = "/dev/fd/" . fileno($wget_list_handle);
my $megs = $download_size / 1000000;

my $wget_verbosity = '';

if ($verbose > 1) {
$wget_verbosity = '-v';
} elsif (!$quiet) {
$wget_verbosity = '-nv';
} else {
$wget_verbosity = '-q';
}
printf("Downloading %.0f Mb (less previous downloads)\n", $megs);
my @wgetcmd = ('/usr/bin/wget', '-i', "$wgetfile", "$wget_verbosity", '-nc', '-B', "$archive", '-r', '-nH', '--cut-dirs=1');
system @wgetcmd;

if (!chdir($cwd)) {
print_error_exit("Unable to return to original directory $cwd after downloading files\n",
EXIT_CWD_CHDIR_FAILED);
}
}

sub process_package_lists {
my $binary_list_filename = shift;
my $source_list_filename = shift;
my $package_list_filehandle;
my $is_source = FALSE;

foreach my $filename ($binary_list_filename, $source_list_filename) {
if (($filename ne '') && ($filename eq $source_list_filename)) {
$is_source = TRUE;
}
if ($filename eq '') {
next;
}
if ($filename eq '-') {
$package_list_filehandle = new IO::File;
if (!($package_list_filehandle->fdopen(fileno(STDIN),"r"))) {
print_error_exit("Unable to access standard input.\n",
EXIT_STDIN_ERR);
}
} else {
if (!($package_list_filehandle = new IO::File $filename, "r")) {
print_error_exit("Uable to open file: $filename.\n",
EXIT_FILE_OPEN_FAILED);
}
}
&process_package_list($package_list_filehandle, $is_source);
}
}

sub process_package_list {
my $package_list_filehandle = shift;
my $is_source = shift;
my $line;
my $line_number = 0;
my $package_name;

while ($line = <$package_list_filehandle>) {
if ($from_germinate) {
if ($line_number < GERMINATE_HEADER_LINES) {
$line_number++;
next;
} elsif (!$is_source) {
if ($line =~ m/^(.*?)(\s*?\|).*/) {
$package_name = &trim($1);
}
} else {
if ($line =~ m/^(.*?)\s+\|.*/) {
$package_name = &trim($1);
}
}
} else {
$package_name = &trim($line);
}
if ((defined $package_name) && ($package_name ne '')) {
if ($verbose > 3) {
print "$package_name ";
if (!$is_source) {
print ': binary\n';
} else {
print ': source\n';
}
}
&process_package($package_name, $is_source);
}
}
}

sub process_package {
my $package_name = shift;
my $is_source = shift;
my $ver_hash;
my $version;
my $fields;
my $highest_fields;
my $highest_version;

if (!$is_source) {
$ver_hash = $binaries{$package_name};
} else {
$ver_hash = $sources{$package_name};
}

# initialise the global config object with the default values
$_config->init;

# determine the appropriate system type
$_system = $_config->system;

# fetch a versioning system
my $versys = $_system->versioning;

while (($version, $fields) = each (%{$ver_hash})) {
if (! defined($version)) {
&print_error_exit("No version for '$package_name'",
EXIT_NO_VERSION_FOR_PACKAGE);
}
if (! defined($highest_version)) {
$highest_version = $version;
$highest_fields = $fields;
} elsif ($versys->compare($highest_version, $version) > 0 ) {
if ($verbose > 2) {
print "ver: $version, high_ver: $highest_version\n";
}
$highest_version = $version;
$highest_fields = $fields;
}
}
if (! defined ($highest_fields)) {
&print_error_exit("No highest field for '$package_name'",
EXIT_NO_HIGH_FIELDS);
} else {
if (&filter_package($package_name, $highest_fields, $highest_version, $is_source)) {
my $filepath;
my $filehandle;
my $directory;
if (!$is_source) {
if ($verbose > 2) {
print $archive . ${$highest_fields}{'Filename'} . "\n";
}
$download_size += ${$highest_fields}{'Size'};
$filepath = ${$highest_fields}{'Filename'};
print $wget_list_handle $filepath . "\n";
} else {
my @files = split /\s/, ${$highest_fields}{'Files'};
my @sizes = split /\s/, ${$highest_fields}{'Sizes'};

foreach my $size (@sizes) {
$download_size += $size;
}

foreach my $file (@files) {
$directory = ${$highest_fields}{'Directory'};
$filepath = $directory . '/' . $file;
if ($verbose > 2) {
print $directory . '/' . $file . "\n";
}
if ($verbose > 2) {
print $filepath . "\n";
}
print $wget_list_handle $filepath . "\n";
}
}
my $dist = ${$highest_fields}{'Distro'};
my $component = ${$highest_fields}{'Component'};
my $architecture = ${$highest_fields}{'Architecture'};
my $installer = ${$highest_fields}{'Installer'};

if ($is_source) {
my $filename = $dist . '_' . $component . '_source';
my @files = split /\s/, ${$highest_fields}{'Files'};

foreach my $file (@files) {
if ($file =~ m/.*\.dsc$/) {
$filepath = $directory . '/' . $file;
&emit_ftparchive_list($filepath, $filename);
}
}
} elsif ($installer) {
foreach my $arch (split /\s/, $architecture) {
my $filename = $dist . '_' . $component .
'_debian-installer_binary-' . $arch;
&emit_ftparchive_list($filepath, $filename);
}
} else {
foreach my $arch (split /\s/, $architecture) {
my $filename = $dist . '_' . $component .
'_binary-' . $arch;
&emit_ftparchive_list($filepath, $filename);
}
}
}
}
}

sub emit_ftparchive_list {
my $filepath = shift;
my $filename = shift;

my $filehandle = $apt_ftparchive_file{$filename};
if (!defined $filehandle) {
$filehandle = new IO::File $filename, "w";
$apt_ftparchive_file{$filename} = $filehandle;
}
print $filehandle $filepath . "\n";
}

sub filter_package {
my $package_name = shift;
my $field_hash_ref = shift;
my $version_hash_ref = shift;
my $is_source = shift;
my $pkgarch;
my $cmdarch;
my $exclude_reason = '';
my $excluded = FALSE;

{
if ( index("@components", ${$field_hash_ref}{'Component'}) == -1) {
$excluded = TRUE;
$exclude_reason = "Component ${$field_hash_ref}{'Component'} not included\n";
last;
} elsif ($verbose > 3) {
print "$package_name in included component\n";
}

my $included_arch = FALSE;
foreach $pkgarch (split /\s/, ${$field_hash_ref}{'Architecture'}) {
foreach $cmdarch (@archs) {
if (($pkgarch eq 'any') || ($pkgarch eq $cmdarch)) {
$included_arch = TRUE;
last;
}
}
if ($included_arch) {
last;
}
}

if (!$included_arch) {
$excluded = TRUE;
$exclude_reason = "None of archs @{$field_hash_ref}{'Architecture'} included\n";
last;
}

my $is_installer = ${$field_hash_ref}{'Installer'};
if (! defined($is_installer)) {
$is_installer = FALSE;
}

if ((!$include_installer) && $is_installer) {
$excluded = TRUE;
$exclude_reason = "Installer package but installer packages are being excluded";
last;
}

return TRUE;
}

if ($excluded && ($verbose > 0)) {
print STDERR "$package_name excluded: $exclude_reason";
}
return FALSE;
}

sub trim {
$_ = $_[0];
if (defined $_) {
s/^\s+//;
s/\s+$//;
}
return $_;
}

sub print_error_exit {
my $error_message = shift;
my $error_number = shift;

if (!$quiet) {
print STDERR "$error_message\n";
}
exit $error_number;
}

sub parse_command_line {
my $option;
my $option_value;
my $print_help = TRUE;
my $custom_archs = FALSE;

Getopt::Mixed::init('l=s pkg-control>l','a=s archive>a', 'd=s distro>d',
'c=s components>c', 'n no-installer>n','g germinate>g', 'q quiet>q',
'v verbose>v', 'h help>h', 'k=s architecture>k', 's=s source>s',
'b=s binary>b', 'p=s pool>p', 'skip-download', 'keep-wget-file=s');
while (($option, $option_value) = nextOption()) {
if ((defined $option) && ($option ne '')) {
$option_value = &trim($option_value);
if ($option eq 'a') {
# Archive mirror to download from
$archive = $option_value;
$print_help = FALSE;
} elsif ($option eq 'l') {
# Directory which contains the package control files
$pkg_control_dir = $option_value;
$print_help = FALSE;
} elsif ($option eq 'p') {
# Directory which contains the pool subdirectory
$pool_dir = $option_value;
$print_help = FALSE;
} elsif ($option eq 'd') {
# parse comma-separated list of distributions (e.g. dapper,
# dapper-updates,dapper-security)
my @distros_split = split /,/, $option_value;
foreach my $distro (@distros_split) {
if ((defined $distro) && ($distro ne '')) {
chomp $distro;
$distro = &trim($distro);
push @distros, $distro;
}
}
$print_help = FALSE;
} elsif ($option eq 'c') {
# parse comma-separates list of components (e.g. main,
# restricted,universe)
my @components_split = split /,/, $option_value;
foreach my $component (@components_split) {
if ((defined $component) && ($component ne '')) {
push @components, $component;
}
}
} elsif ($option eq 'k') {
# Architectures to include
my @cmdarchs = split /,/, $option_value;
foreach my $arch (@cmdarchs) {
if ((defined $arch) && ($arch ne '')) {
push @archs, $arch;
}
}
$custom_archs = TRUE;
$print_help = FALSE;
} elsif ($option eq 'n') {
# Don't download installer packages
$include_installer = FALSE;
$print_help = FALSE;
} elsif ($option eq 'g') {
# Package list is of the output format generated by
# germinated
$from_germinate = TRUE;
$print_help = FALSE;
} elsif ($option eq 'q') {
# Run with no messages (even errors)
$quiet = TRUE;
$print_help = FALSE;
$verbose = 0;
} elsif ($option eq 'v') {
# Display verbose progress messages for debugging purposes.
# Level of debugging depends on how many times this option is
# specified
if (!$quiet) {
$verbose++;
} else {
$verbose = 0;
}
$print_help = FALSE;
} elsif ($option eq 's') {
# List of source packages to include
$source_list_filename = $option_value;
} elsif ($option eq 'b') {
# List of binary packages to include
$binary_list_filename = $option_value;
} elsif ($option eq 'skip-download') {
$skip_download = TRUE;
} elsif ($option eq 'keep-wget-file') {
$keep_wget_file = TRUE;
$wget_filename = $option_value;
} else {
# Unknown option so show help info
$print_help = TRUE;
}
}
}

if (!$custom_archs) {
@archs = qw/i386 all/;
}

if (!defined $binary_list_filename) {
$binary_list_filename = '';
}
if (!defined $source_list_filename) {
$source_list_filename = '';
}

if (($source_list_filename eq '') && ($binary_list_filename eq '')) {
# No filename for packages to include is an error
$print_help = TRUE;
} else {
# Check filename(s) for package to include for read permission, or for
# specifying stdin (-) more than once.
my $use_stdin = FALSE;

foreach my $filename (($binary_list_filename, $source_list_filename)) {
if ($filename ne '') {
if (! -r $filename) {
if ($filename eq '-') {
if ($use_stdin) {
&print_error_exit("Error: You specified stdin as more than once.",
EXIT_MULTIPLE_STDIN);
}
} elsif (!$quiet) {
&print_error_exit('Error: You don\'t have read permissions on \'' .
$filename . "'. Aborting.\n", EXIT_UNREADABLE_FILE);
}
}
}
}
}

if ($verbose > 1) {
print "-----------------------\n";
print "Commandline parameters:\n";
print "-----------------------\n";
print "archive mirror: $archive\n";
print "directory with pool subdir: $pool_dir\n";
print "package control base dir: $pkg_control_dir\n";
print "distributions: @distros\n";
print "components: @components\n";
print "architectures: @archs\n";
if ($include_installer) {
print "include installer\n";
} else {
print "don't include installer\n";
}
if ($from_germinate) {
print "package list from germinate\n";
} else {
print "plain package list (not from germinate)\n";
}
if ($binary_list_filename ne '') {
print "binary package list filename: $binary_list_filename\n";
}
if ($source_list_filename ne '') {
print "source package list filename: $source_list_filename\n";
}
if ($keep_wget_file ne '') {
print "wget filename: $wget_filename\n";
}
if ($skip_download) {
print "skipping download\n";
}
print "-----------------------\n";
}

if ($print_help) {
print <<'EOT';
Custom Apt Pool 0.4
Download a set of packages and sources for a custom deb pool
Copyright (C) 2007 Daniel Dickinson
Usage: do-custom-download.pl [options] [-a archive] -d=distro[,distro[,...]]
-c=component[,...] -b binary-package-list-file -s src-package-list-file
-a mirror --archive=mirror : Mirror and root dir from which to download
packages. (e.g http://archive.debian.org/debian).
-l path --pkg-control=path : Where to look for package control files (relative
to current directory)
-d distro --distro=distro : Comma-separated list of distributions (e.g
-d sarge,sarge-security). At least one is required
--no-installer : Don't include installer packages
-c component,.. --component=... : Comma-separated list of components to
include (e.g. -c=main,contrib).
-k architecture --architecture=architecture : Comma-separated lists of
architectures for which to include packages. Defaults to i386,all
-g --from-germinate : Package list is from germinate
-p --pool : Directory containing the pool subdirectory
-q --quiet : No messages, not even error (exit code only)
-v --verbose : Display debugging messages
This program is free software; you can redistribute it and/or modify it under
the terms of the version 2 of the GNU General Public License as published by
the Free Software Foundation.
EOT

Getopt::Mixed::cleanup();
exit EXIT_BAD_COMMAND_LINE;
}
Getopt::Mixed::cleanup();
}

sub parse_package_control_files {
my $base_dir = shift;
my $distros_ref = shift;
my $components_ref = shift;
my $include_installer = shift;

my $distro;
my $component;
my $value;
my $filename;

# Package control files are of the form distribution_component_controltype
# where controltype is Packages, InstallerPackages, or Sources

# So we iterate through the distros and components looking for readable files to parse
# (in the base directory specified on the command line, or (if non specified) the current
# directory).
foreach $distro (@{$distros_ref}) {
foreach $component (qw/main contrib/) {
$filename = $base_dir . $distro . '_' . $component . '_Packages';
if (-r $filename) {
if ($verbose > 0) {
print "Parsing $filename\n";
}
# FALSE, FALSE means, Not installer, not source
&parse_package_control_file($filename, $distro, $component, FALSE, FALSE);
} elsif ($verbose > 0) {
print "Couldn't read $filename\n";
}
if ($include_installer) {
$filename = $base_dir . $distro . '_' . $component . '_InstallerPackages';
if (-r $filename) {
if ($verbose > 0) {
print "Parsing $filename\n";
}
# TRUE, FALSE means, installer, not source
&parse_package_control_file($filename, $distro, $component, TRUE, FALSE);
} elsif ($verbose > 0) {
print "Couldn't read $filename\n";
}
}
$filename = $base_dir . $distro . '_' . $component . '_Sources';
if (-r $filename) {
if ($verbose > 0) {
print "Parsing $filename\n";
}
# FALSE, TRUE means, not installer, is source
# source control files don't list installer udebs generated
&parse_package_control_file($filename, $distro, $component, FALSE, TRUE);
} elsif ($verbose > 0) {
print "Couldn't read $filename\n";
}
}
}
}

sub parse_package_control_package {
my $package_hash_ref = shift;
my $dist = shift;
my $component = shift;
my $is_installer = shift;
my $is_source = shift;
my $line_number = shift;
my @required_fields;
my %pkg_hash;
my %ver_hash;
my %field_hash;
my $ver_hash_ref;
my $version;
my %pkg_archs;

if ($is_source) {
@required_fields = @required_source_fields;
} else {
@required_fields = @required_binary_fields;
}

$version = ${$package_hash_ref}{'Version'};

# Make sure all required fields are present in the package record
foreach my $required_field (@required_fields) {
if ((! defined ${$package_hash_ref}{$required_field}) ||
(${$package_hash_ref}{$required_field} eq '')) {
&print_error_exit("Missing required field '$required_field' at or near line: $line_number",
EXIT_MISSING_FIELD);
}
}

if (!$is_source) {
if ((! defined ${$package_hash_ref}{'Source'}) || (${$package_hash_ref}{'Source'} eq '')) {
${$package_hash_ref}{'Source'} = ${$package_hash_ref}{'Package'};
}

# For fields that shouldn't have a space (like source package name) but
# sometimes do (packages for which gcc-defaults is in the Source
# field, for instance), match up to but not including the first space
# and make this our field value
# Look for the special case of package_name(version) like
# gcc-defaults, if a match note the version as well as field value, otherwise
# only field value
my $field_value = ${$package_hash_ref}{'Source'};
my $source_version;

if ($field_value =~ m/^(.+)\s*\((.+)\)/) {
$field_value = &trim($1);
$source_version = &trim($2);
if ($verbose > 2) {
print "${$package_hash_ref}{'Package'} has source name '$field_value' and source version '$source_version'\n";
}
} else {
$source_version = $version;
}

# Create hash with contents of fields we want
$field_hash{'Source'} = $field_value;
$field_hash{'SourceVersion'} = $source_version;
$field_hash{'Distro'} = $dist;
$field_hash{'Component'} = $component;
$field_hash{'Architecture'} = ${$package_hash_ref}{'Architecture'};
$field_hash{'Filename'} = ${$package_hash_ref}{'Filename'};
$field_hash{'Installer'} = $is_installer;
$field_hash{'Size'} = ${$package_hash_ref}{'Size'};

# Get current hash with all versions of the current package
$ver_hash_ref = $binaries{${$package_hash_ref}{'Package'}};

if (defined $ver_hash_ref) {
# If version hash exists, add current version to it (or replace
# existing version if version string identical
${$ver_hash_ref}{$version} = \%field_hash;
} else {
# Otherwise create new hash and make it the version hash
# for the current package
$ver_hash{$version} = \%field_hash;
$binaries{${$package_hash_ref}{'Package'}} = \%ver_hash;
}
} else {
my @files;
my @sizes;
my $has_file = FALSE;

foreach my $file_line (split /\n/, ${$package_hash_ref}{'Files'}) {
if ($verbose > 3) {
print "multi-line raw: $file_line\n";
}
if ($file_line =~ m/[a-zA-Z0-9]{32}\s([0-9]+)\s(.+)/) {
push @files, $2;
push @sizes, $1;
$has_file = TRUE;
if ($verbose > 3) {
print "Found file '$1'\n";
}
}
}

if (!$has_file) {
&print_error_exit("Invalid Files: field (${$package_hash_ref}{'Files'})",
EXIT_BAD_SOURCE_FILES_FIELD);
}

# Create hash with contents of fields we want
$field_hash{'Directory'} = ${$package_hash_ref}{'Directory'};
$field_hash{'Architecture'} = ${$package_hash_ref}{'Architecture'};
$field_hash{'Distro'} = $dist;
$field_hash{'Component'} = $component;
$field_hash{'Files'} = "@files";
$field_hash{'Sizes'} = "@sizes";

# Get hash with all versions of the current package
$ver_hash_ref = $sources{${$package_hash_ref}{'Package'}};

if (defined $ver_hash_ref) {
# If version hash exists, add current version, or replace
# current version (if version strings identical)
${$ver_hash_ref}{$version} = \%field_hash;
} else {
# Otherwise create new hash and make it the version hash
# for the current package
$ver_hash{$version} = \%field_hash;
$sources{${$package_hash_ref}{'Package'}} = \%ver_hash;
}
}

if ($verbose > 3) {
my $field;
my $value;
print "Package: ${$package_hash_ref}{'Package'}\n";
print "Version: $version\n";
while (($field, $value) = each (%field_hash)) {
print "$field: $value\n";
}
}
}

sub parse_package_control_file {
my $package_control_filename = shift;
my $dist = shift;
my $component = shift;
my $is_installer = shift;
my $is_source = shift;
my $packages_control_handle = new IO::File $package_control_filename, "r";


my $line;
my $line_number = 0;
my $package_name = '';
my @line_array;
my %package_hash;

my $field_name = '';
my $field_value = '';
my $new_package = TRUE;
my $package_number = 0;

if ($verbose > 3) {
print "Package#: $package_number\n";
}

# Parse the control file a line at a time
while ($line = <$packages_control_handle>) {
chomp $line;
$line_number++;

# In the Packages and Sources control files an initial space on a line means that the line
# is the part of a multi-line field.
my $first_space = index($line, ' ');

# If the current line is an empty line, or not the continuation of a multi-line field,
# then the line immediately prior was the completion of a field (and start for single-line fields)
# We therefore record the field and value for this package.
if ((! defined $line) || ($line eq '') || (defined $first_space) && ($first_space != 0)) {
if ((defined $field_name) && ($field_name ne '')) {
# If we already have a field of this name something is wrong
if ((defined $package_hash{$field_name}) && ($package_hash{$field_name} ne '')) {
&print_error_exit("Repeated field $field_name at line $line_number in $package_control_filename",
EXIT_REPEATED_FIELD);
} else {
# Otherwise record the field name and value
$package_hash{$field_name} = $field_value;
}
} elsif (!$new_package) {
&print_error_exit("Missing field name at line $line_number in $package_control_filename",
EXIT_MISSING_FIELD_NAME);
}
}
$new_package = FALSE;

# Packages are always separated by a blank line, so when we encounter a blank line we
# process the package information gathered since the last blank line.
if ((! defined $line) || ($line eq '')) {
&parse_package_control_package(\%package_hash, $dist, $component,
$is_installer, $is_source, $line_number);
$field_name = '';
$field_value = '';
$new_package = TRUE;
%package_hash = ();
if ($verbose > 3) {
print "Package#: $package_number\n";
}
$package_number++;
next;
}

# Lines beginning with a space ought to be the continuation of a multi-line field
if ($first_space == 0) {
# So if we hit such a line, keep the current field name, and add this line to the value of
# of the field (as a line)
$line = &trim($line);
$field_value .= "$line\n";
} else {
# Otherwise, the field ought to be 'fieldname: value', so split at the colon-space
# and call the first item the fieldname, and the rest (space separated), the field value
@line_array = split /:\s/, $line;
$field_name = &trim(shift @line_array);
$field_value = &trim("@line_array");

if ($field_value eq '') {
if (substr($line, -1, 1) eq ':') {
$field_name = substr($line, 0, length($line) - 1);
if ($verbose > 3) {
print "Found multi-line field '$field_name'\n";
}
}
}
}
}
close $packages_control_handle;
}