[PATCH] Based build/installation process around Perl's own mechanisms (ExtUtils::MakeMaker)
Hilko Bengen
bengen at debian.org
Fri May 30 10:44:14 UTC 2008
---
MANIFEST | 15 +
Makefile.PL | 13 +
bin/debpool | 4 -
lib/DebPool/Bzip2.pm | 190 +++++++
lib/DebPool/Config.pm | 1058 ++++++++++++++++++++++++++++++++++++
lib/DebPool/DB.pm | 276 ++++++++++
lib/DebPool/Dirs.pm | 506 +++++++++++++++++
lib/DebPool/GnuPG.pm | 264 +++++++++
lib/DebPool/Gzip.pm | 188 +++++++
lib/DebPool/Logging.pm | 173 ++++++
lib/DebPool/Packages.pm | 1311 +++++++++++++++++++++++++++++++++++++++++++++
lib/DebPool/Release.pm | 374 +++++++++++++
lib/DebPool/Signal.pm | 144 +++++
lib/DebPool/Util.pm | 129 +++++
share/DebPool/Bzip2.pm | 190 -------
share/DebPool/Config.pm | 1058 ------------------------------------
share/DebPool/DB.pm | 276 ----------
share/DebPool/Dirs.pm | 506 -----------------
share/DebPool/GnuPG.pm | 264 ---------
share/DebPool/Gzip.pm | 188 -------
share/DebPool/Logging.pm | 173 ------
share/DebPool/Packages.pm | 1311 ---------------------------------------------
share/DebPool/Release.pm | 374 -------------
share/DebPool/Signal.pm | 144 -----
share/DebPool/Util.pm | 129 -----
25 files changed, 4641 insertions(+), 4617 deletions(-)
create mode 100644 MANIFEST
create mode 100644 Makefile.PL
create mode 100644 lib/DebPool/Bzip2.pm
create mode 100644 lib/DebPool/Config.pm
create mode 100644 lib/DebPool/DB.pm
create mode 100644 lib/DebPool/Dirs.pm
create mode 100644 lib/DebPool/GnuPG.pm
create mode 100644 lib/DebPool/Gzip.pm
create mode 100644 lib/DebPool/Logging.pm
create mode 100644 lib/DebPool/Packages.pm
create mode 100644 lib/DebPool/Release.pm
create mode 100644 lib/DebPool/Signal.pm
create mode 100644 lib/DebPool/Util.pm
delete mode 100644 share/DebPool/Bzip2.pm
delete mode 100644 share/DebPool/Config.pm
delete mode 100644 share/DebPool/DB.pm
delete mode 100644 share/DebPool/Dirs.pm
delete mode 100644 share/DebPool/GnuPG.pm
delete mode 100644 share/DebPool/Gzip.pm
delete mode 100644 share/DebPool/Logging.pm
delete mode 100644 share/DebPool/Packages.pm
delete mode 100644 share/DebPool/Release.pm
delete mode 100644 share/DebPool/Signal.pm
delete mode 100644 share/DebPool/Util.pm
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..4f52faa
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,15 @@
+Makefile.PL
+MANIFEST
+# t/DebPool.t
+lib/DebPool/Packages.pm
+lib/DebPool/Util.pm
+lib/DebPool/Signal.pm
+lib/DebPool/Release.pm
+lib/DebPool/Logging.pm
+lib/DebPool/GnuPG.pm
+lib/DebPool/Gzip.pm
+lib/DebPool/Dirs.pm
+lib/DebPool/Bzip2.pm
+lib/DebPool/Config.pm
+# lib/DebPool/Hooks.pm
+lib/DebPool/DB.pm
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..c8710b9
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,13 @@
+use 5.010000;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'DebPool',
+ VERSION => 0.4,
+ EXE_FILES => [qw(bin/debpool)],
+ PREREQ_PM => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (#ABSTRACT_FROM => 'lib/DebPool.pm', # retrieve abstract from module
+ AUTHOR => 'Hilko Bengen <hbengen@>') : ()),
+);
diff --git a/bin/debpool b/bin/debpool
index 798fc16..2d2488a 100755
--- a/bin/debpool
+++ b/bin/debpool
@@ -32,10 +32,6 @@
#
#####
-# Put our private support module area into the search path
-
-use lib '/usr/share/debpool/perl5';
-
# We always want to be careful about things...
use strict;
diff --git a/lib/DebPool/Bzip2.pm b/lib/DebPool/Bzip2.pm
new file mode 100644
index 0000000..eab24dc
--- /dev/null
+++ b/lib/DebPool/Bzip2.pm
@@ -0,0 +1,190 @@
+package DebPool::Bzip2;
+
+###
+#
+# DebPool::Bzip2 - Module for handling Bzip2 interactions
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Bzip2.pm 27 2004-11-07 03:06:59Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+use POSIX; # WEXITSTATUS
+
+# Needed for open2()
+
+use Fcntl;
+use IPC::Open2;
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Bzip2_File
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Bzip2_File)],
+ 'vars' => [qw()],
+ );
+}
+
+### Exported package globals
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Bzip_File($file)
+#
+# Generates a bzipped version of $file, and returns the filename. Returns
+# undef (and sets $Error) on failure.
+
+sub Bzip2_File {
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($file) = @_;
+
+ # Open a secure tempfile to write the compressed data into
+
+ my($tmpfile) = new File::Temp( SUFFIX => '.bz2', UNLINK => 0 );
+
+ # Open the source file so that we have it available.
+
+ my $source_fh;
+ if (!open($source_fh, '<', $file)) {
+ $Error = "Couldn't open source file '$file': $!";
+ return;
+ }
+
+ # We are go for main engine start
+
+ my(@args) = ('--best', '--force', '--stdout');
+
+ my($bzip2_pid) = open2(*BZIP2_IN, *BZIP2_OUT, '/bin/bzip2', @args);
+
+ my($child_pid);
+ if ($child_pid = fork) { # In the parent
+ # Send all the data to Bzip2;
+
+ close(BZIP2_IN);
+ close($tmpfile);
+
+ print BZIP2_OUT <$source_fh>;
+ close(BZIP2_OUT);
+ close($source_fh);
+
+ waitpid($child_pid, 0);
+ waitpid($bzip2_pid, 0);
+ } else { # In the child - we hope
+ if (!defined($child_pid)) {
+ die "Couldn't fork: $!\n";
+ }
+
+ # Read back the results, and print them into the tempfile.
+
+ close(BZIP2_OUT);
+ close($source_fh);
+
+ print $tmpfile <BZIP2_IN>;
+ close(BZIP2_IN);
+ close($tmpfile);
+
+ exit(0);
+ }
+
+ # And we're done
+
+ return $tmpfile->filename;
+}
+
+sub new {
+ bless { ERROR => undef };
+}
+
+sub Compress_File {
+ my $self = shift;
+ my $tempname = Bzip2_File(@_);
+ if ($tempname) {
+ $self->{'ERROR'} = undef;
+ }
+ else {
+ $self->{'ERROR'} = $Error;
+ }
+ $tempname;
+}
+
+sub Error {
+ my $self = shift;
+ $self->{'ERROR'};
+}
+
+sub Name {
+ 'bzip2';
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Config.pm b/lib/DebPool/Config.pm
new file mode 100644
index 0000000..d323d3a
--- /dev/null
+++ b/lib/DebPool/Config.pm
@@ -0,0 +1,1058 @@
+package DebPool::Config;
+
+###
+#
+# DebPool::Config - Module for handling config options
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Config.pm 38 2005-01-20 21:33:31Z joel $
+#
+###
+
+=head1 NAME
+
+DebPool::Config - configuration file format for debpool
+
+=cut
+
+=head1 SYNOPSIS
+
+package DebPool::Config;
+
+%Options = (
+ 'option1' => value1,
+ 'option2' => value2,
+ ...
+);
+
+1;
+
+=cut
+
+=head1 DESCRIPTION
+
+The DebPool::Config file is normally found in three places;
+F</usr/share/debpool/Config.pm>, F</etc/debpool/Config.pm>, and
+F<$HOME/.debpool/Config.pm> (in ascending order of precedence);
+further locations can also be specified on the command line with the
+'--config=<file>' option, which overrides all of these (and is, in turn,
+overridden by any command line options). Also of note is the --nodefault
+option, which prevents any attempt at loading the default (system and user)
+config files.
+
+The config files in /etc/debpool and $HOME/.debpool are not required to be
+full Perl modules or to even exist. If they are used, they must still
+declare a package namespace of 'DebPool::Config' and return a true value.
+
+=cut
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ %Options
+ %OptionDefs
+ &Clean_Options
+ &Load_Default_Configs
+ &Load_Minimal_Configs
+ &Load_File_Configs
+ &Override_Configs
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Clean_Options &Load_Default_Configs
+ &Load_Minimal_Configs &Load_File_Configs
+ &Override_Configs)],
+ 'vars' => [qw(%Options %OptionDefs)],
+ );
+}
+
+### Exported package globals
+
+# The core of everything this package is about.
+
+our(%Options);
+our(%OptionDefs);
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Module Init
+
+# First things first - figure out how we need to be configured.
+
+use Getopt::Long qw(:config pass_through);
+
+# First, grab --config and --nodefault options if they exist. We
+# don't want these in the %Options hash, and they affect what we do when
+# loading it.
+
+my @config_files;
+my $default;
+
+GetOptions('config=s' => \@config_files, 'default!' => \$default);
+
+# Call Load_Default_Configs if we're loading default values, or
+# Load_Minimal_Configs if we're not (we still need the OptionDefs hash to
+# be populated).
+
+if (!defined($default) || $default) {
+ Load_Default_Configs();
+} else {
+ Load_Minimal_Configs();
+}
+
+# Load any config files we were given.
+
+foreach my $config (@config_files) {
+ Load_File_Configs($config);
+}
+
+# And finally, pull in any other command line options.
+
+GetOptions(\%Options, values(%OptionDefs));
+
+# Run the cleanup stuff on %Options.
+
+Clean_Options();
+
+
+### Meaningful functions
+
+# Load_Default_Configs
+#
+# Loads the internal default values into %Options via
+# Load_Internal_Configs, then 'require's config files from the default
+# locations. It would be nice if we could log errors, but we can't safely
+# load the logging module until we have all the configs in place. Catch-22.
+
+sub Load_Default_Configs {
+ Load_Internal_Configs();
+
+ if (-r '/etc/debpool/Config.pm') {
+ do '/etc/debpool/Config.pm'; # System defaults
+ }
+
+ if (-r "$ENV{'HOME'}/.debpool/Config.pm") {
+ do "$ENV{'HOME'}/.debpool/Config.pm"; # User defaults
+ }
+}
+
+# Load_Minimal_Configs
+#
+# Loads only the minimum configs necessary to be able to do parsing -
+# that is, populate %OptionDefs. However, for sanity sake in documenting
+# things, this has a side effect of also loading %Options, so we clear it
+# afterwards.
+
+sub Load_Minimal_Configs {
+ Load_Internal_Configs();
+
+ undef(%Options);
+}
+
+# Load_File_Configs($file)
+#
+# Loads configuration data from $file. We don't check for readability; if
+# the user is insane enough to ask for a non-existant file, just die and
+# tell them that they're stupid. Note: if this routine is called while a
+# lockfile is held, it won't clean that up if we die.
+
+sub Load_File_Configs {
+ do "$_[0]";
+}
+
+# Override_Configs($override_hashref)
+#
+# Overrides current values in %Options (whatever those might be) with the
+# values in the hash. Does not destroy unnamed values.
+
+sub Override_Configs {
+ my($hashref) = @_;
+
+ foreach my $key (keys(%{$hashref})) {
+ $Options{$key} = $hashref->{$key};
+ }
+}
+
+# Clean_Options()
+#
+# Does some cleanup of $Options for sanity sake; also generates some
+# auto-calculated values.
+
+sub Clean_Options {
+ # Clean up the architectures field; 'source' should always be present,
+ # 'all' should never be. Simplest way to manage this is a throwaway
+ # hash. This should maybe live somewhere else, but I'm not sure where.
+
+ my %dummy;
+ my @newarch;
+
+ foreach my $dummykey (@{$Options{'archs'}}) {
+ $dummy{$dummykey} = 1;
+ }
+
+ $dummy{'all'} = undef;
+ $dummy{'source'} = 1;
+
+ foreach my $dummykey (keys(%dummy)) {
+ if ($dummy{$dummykey}) {
+ push(@newarch, $dummykey);
+ }
+ }
+
+ $Options{'archs'} = \@newarch;
+
+ # Generate 'realdists' from %Options{'dists'} - these are the 'real'
+ # (non-alias) distribution values.
+
+ %dummy = ();
+
+ foreach my $dummykey (values(%{$Options{'dists'}})) {
+ $dummy{$dummykey} = 1;
+ }
+
+ my @realdists = keys(%dummy);
+ $Options{'realdists'} = \@realdists;
+
+ # Also generate a reverse-lookup table of real -> alias; in the case
+ # of multiple aliases, the first one encountered wins (one of them has
+ # to, and making it consistant and first means you can have multiple
+ # aliases in a sensible order).
+
+ my %reverse = ();
+ foreach my $dummykey (keys(%{$Options{'dists'}})) {
+ my $real = $Options{'dists'}->{$dummykey};
+ if (!defined($reverse{$real})) {
+ $reverse{$real} = $dummykey;
+ }
+ }
+
+ $Options{'reverse_dists'} = \%reverse;
+
+ # Enable releases if we have all of the pieces.
+ if (defined($Options{'release_origin'})
+ && defined($Options{'release_label'}) &&
+ defined($Options{'release_description'})) { $Options{'do_release'} = 1;
+ } else { $Options{'do_release'} = 0; }
+
+ # If rebuild-all is present, turn on various rebuild options.
+
+ if ($Options{'rebuild-all'}) {
+ $Options{'rebuild-files'} = 1;
+ $Options{'rebuild-dbs'} = 1;
+ }
+}
+
+# Load_Internal_Configs()
+#
+# Loads %Options with basic default values.
+
+sub Load_Internal_Configs {
+=head1 OPTIONS
+
+=head2 File/Directory configuration
+
+These config values determine what directories various parts of the archive
+are put in, and what permissions those directories have, as well as the
+default permissions for files.
+
+NOTE: While debpool will attempt to create db_dir, dists_dir, incoming_dir,
+installed_dir, pool_dir, and reject_dir if they do not exist, it will *not*
+attempt to do this for archive_dir.
+
+WARNING: If you redefine archive_dir and you want the other four entries to
+reflect this by incorporating the new value, you *MUST* redefine them here
+(even if you simply use the default value of 'archive_dir'/<dirname>) so
+that they use the new definition of archive_dir.
+
+=over 4
+
+=item B<archive_dir> => I<archive directory>
+
+Base directory of the archive. This is never used directly; however, it
+is normally used to construct relative paths for dists_dir, incoming_dir,
+installed_dir, pool_dir, and reject_dir.
+
+WARNING: See the section documentation for important details about
+redefining this value.
+
+Default value: '/var/cache/debpool'
+
+=cut
+
+$Options{'archive_dir'} = '/var/cache/debpool';
+$OptionDefs{'archive_dir'} = 'archive_dir=s';
+
+=item B<db_dir> => I<dists directory>
+
+DB directory, where the database files for each distribution are kept.
+
+Default value: "$Options{'archive_dir'}/db"
+
+=cut
+
+$Options{'db_dir'} = "$Options{'archive_dir'}/db";
+$OptionDefs{'db_dir'} = 'db_dir=s';
+
+=item B<db_dir_mode> = I<permissions (octal)>
+
+Permissions for db_dir.
+
+Default value: 0750
+
+=cut
+
+$Options{'db_dir_mode'} = 0750;
+$OptionDefs{'db_dir_mode'} = 'db_dir_mode=i';
+
+=item B<db_file_mode> = I<permissions (octal)>
+
+Permissions for database files in db_dir.
+
+Default value: 0640
+
+=cut
+
+$Options{'db_file_mode'} = 0640;
+$OptionDefs{'db_file_mode'} = 'db_file_mode=i';
+
+=item B<dists_dir> => I<dists directory>
+
+Dists directory, where distribution files (F<{Packages,Sources}{,.gz}> live.
+
+Default value: "$Options{'archive_dir'}/dists"
+
+=cut
+
+$Options{'dists_dir'} = "$Options{'archive_dir'}/dists";
+$OptionDefs{'dists_dir'} = 'dists_dir=s';
+
+=item B<dists_dir_mode> = I<permissions (octal)>
+
+Permissions for dists_dir and all of it's subdirectories.
+
+Default value: 0755
+
+=cut
+
+$Options{'dists_dir_mode'} = 0755;
+$OptionDefs{'dists_dir_mode'} = 'dists_dir_mode=i';
+
+=item B<dists_file_mode> = I<permissions (octal)>
+
+Permissions for distribution files ({Packages,Sources}{,.gz}.
+
+Default value: 0644
+
+=cut
+
+$Options{'dists_file_mode'} = 0644;
+$OptionDefs{'dists_file_mode'} = 'dists_file_mode=i';
+
+=item B<incoming_dir> => I<incoming directory>
+
+Incoming directory, where new packages are uploaded.
+
+Default value: "$Options{'archive_dir'}/incoming";
+
+=cut
+
+$Options{'incoming_dir'} = "$Options{'archive_dir'}/incoming";
+$OptionDefs{'incoming_dir'} = 'incoming_dir=s';
+
+=item B<incoming_dir_mode> = I<permissions (octal)>
+
+Permissions for incoming_dir. Should have the sticky bit set if you want a
+system archive.
+
+Default value: 01775
+
+=cut
+
+$Options{'incoming_dir_mode'} = 01775;
+$OptionDefs{'incoming_dir_mode'} = 'incoming_dir_mode=i';
+
+=item B<installed_dir> => I<installed directory>
+
+Incoming directory, where new packages are uploaded.
+
+Default value: "$Options{'archive_dir'}/installed";
+
+=cut
+
+$Options{'installed_dir'} = "$Options{'archive_dir'}/installed";
+$OptionDefs{'installed_dir'} = 'installed_dir=s';
+
+=item B<installed_dir_mode> = I<permissions (octal)>
+
+Permissions for installed_dir. Should have the sticky bit set if you want a
+system archive.
+
+Default value: 0755
+
+=cut
+
+$Options{'installed_dir_mode'} = 0755;
+$OptionDefs{'installed_dir_mode'} = 'installed_dir_mode=i';
+
+=item B<installed_file_mode> = I<permissions (octal)>
+
+Permissions for installed Changes files.
+
+Default value: 0644
+
+=cut
+
+$Options{'installed_file_mode'} = 0644;
+$OptionDefs{'installed_file_mode'} = 'installed_file_mode=i';
+
+=item B<pool_dir> => I<pool directory>
+
+Pool directory where all .deb files are stored after being accepted. Normally
+this is constructed as a relative path from archive_dir.
+
+Default value: "$Options{'archive_dir'}/pool"
+
+=cut
+
+$Options{'pool_dir'} = "$Options{'archive_dir'}/pool";
+$OptionDefs{'pool_dir'} = 'pool_dir=s';
+
+=item B<pool_dir_mode> = I<permissions (octal)>
+
+Permissions for pool_dir and all of it's subdirectories.
+
+Default value: 0755
+
+=cut
+
+$Options{'pool_dir_mode'} = 0755;
+$OptionDefs{'pool_dir_mode'} = 'pool_dir_mode=i';
+
+=item B<pool_file_mode> = I<permissions (octal)>
+
+Permissions for files installed into the pool area (orig.tar.gz, tar.gz,
+diff.gz, dsc, deb).
+
+Default value: 0644
+
+=cut
+
+$Options{'pool_file_mode'} = 0644;
+$OptionDefs{'pool_file_mode'} = 'pool_file_mode=i';
+
+=item B<reject_dir> => I<reject directory>
+
+Reject directory, where rejected packages are placed.
+
+Default value: "$Options{'archive_dir'}/reject"
+
+=cut
+
+$Options{'reject_dir'} = "$Options{'archive_dir'}/reject";
+$OptionDefs{'reject_dir'} = 'reject_dir=s';
+
+=item B<reject_dir_mode> = I<permissions (octal)>
+
+Permissions for reject_dir.
+
+Default value: 0750
+
+=cut
+
+$Options{'reject_dir_mode'} = 0750;
+$OptionDefs{'reject_dir_mode'} = 'reject_dir_mode=i';
+
+=item B<reject_file_mode> = I<permissions (octal)>
+
+Permissions for rejected package files.
+
+Default value: 0640
+
+=cut
+
+$Options{'reject_file_mode'} = 0640;
+$OptionDefs{'reject_file_mode'} = 'reject_file_mode=i';
+
+=item B<lock_file> => I<lockfile>
+
+Location of the lockfile to use when running.
+
+Default value: "$Options{'archive_dir'}/.lock"
+
+=cut
+
+$Options{'lock_file'} = "$Options{'archive_dir'}/.lock";
+$OptionDefs{'lock_file'} = 'lock_file=s';
+
+=item B<get_lock_path> => I<boolean>
+
+Display the full path set for the lock file and exit. This is mainly used
+to determine the path set for the lock file from a system's or user's
+default configuration.
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'get_lock_path'} = 0;
+$OptionDefs{'get_lock_path'} = 'get_lock_path!';
+
+=back
+
+=cut
+
+=head2 Compression configuration
+
+These values control what formats will be used to compress the
+distribution files (Packages, Sources).
+
+=over 4
+
+=item B<compress_dists> = I<boolean>
+
+This determines whether or not compressed versions of the distribution
+files (Packages.gz, Sources.gz) are generated in gzip.
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'compress_dists'} = 0;
+$OptionDefs{'compress_dists'} = 'compress_dists!';
+
+=item B<bzcompress_dists> = I<boolean>
+
+This determines whether or not compressed versions of the distribution
+files (Packages.gz, Sources.gz) are generated in bzip2.
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'bzcompress_dists'} = 0;
+$OptionDefs{'bzcompress_dists'} = 'bzcompress_dists!';
+
+=back
+
+=cut
+
+=head2 Archive configuration
+
+These values control which distributions, components, and architectures the
+archive will support.
+
+=over 4
+
+=item B<dists> => I<hash of distribution names and codenames>
+
+A hashref pointing to a hash with entries for all distributions we will
+accept packages for, and what the current codename for each distribution
+is. Note that it is acceptable for more than one distribution to point to a
+given codename (for example, when frozen is active); however, this has some
+strange (and non-deterministic) consequences for Release files.
+
+Default value:
+
+{ 'stable' => 'etch',
+'testing' => 'lenny',
+'unstable' => 'sid',
+'experimental' => 'experimental' }
+
+=cut
+
+$Options{'dists'} = {
+ 'stable' => 'etch',
+ 'testing' => 'lenny',
+ 'unstable' => 'sid',
+ 'experimental' => 'experimental'
+ };
+$OptionDefs{'dists'} = 'dists=s%';
+
+=item B<virtual_dists> => I<hash of virtual distribution names and targets>
+
+A hashref pointing to a hash with entries for all 'virtual' distributions
+we will accept packages for, and what distribution it should be treated
+as. It is acceptable for more than one virtual distribution to point to a
+given target. Note that unlike 'dists' entries, symlinks pointing from the
+virtual name to the real name will not be created, and no attempt is made
+to use these names in reverse processes (such as Release files); however,
+virtual distributions may target any name ("unstable") or codename ("sid")
+which appears in the 'dists' hash.
+
+Default value:
+
+{}
+
+Example value:
+
+{ 'unstable-hostname' => 'unstable',
+ 'testing-hostname' => 'lenny', }
+
+=cut
+
+$Options{'virtual_dists'} = {};
+$OptionDefs{'virtual_dists'} = 'virtual_dists=s%';
+
+=item B<sections> => I<array of section names>
+
+An arrayref pointing to an array which lists all sections we will accept
+packages for.
+
+Default value: [ 'main', 'contrib', 'non-free', 'debian-installer' ]
+
+=cut
+
+$Options{'sections'} = [ 'main', 'contrib', 'non-free', 'debian-installer' ];
+$OptionDefs{'sections'} = 'sections=s@';
+
+=item B<archs> => I<array of architecture names>
+
+An arrayref pointing to an array which lists all architectures we will
+accept packages for. Note that 'source' will always be present, and 'all'
+will be silently ignored (uploads for Arch: all will still work, but the
+listings appear in arch-specific Packages files).
+
+Default value: [ 'i386' ]
+
+=back
+
+=cut
+
+$Options{'archs'} = [ 'i386' ];
+$OptionDefs{'archs'} = 'archs=s@';
+
+=head2 Release configuration
+
+If the variables 'release_origin', 'release_label', and
+'release_description' are defined, Release files will be generated
+for each distribution directory.
+
+Please note that enabling Release files will introduce a dependancy on the
+package 'libdigest-sha-perl'.
+
+See also: sign_release
+
+=over 4
+
+=cut
+
+=item B<release_origin> => I<origin tag>
+
+A string to be used for the Origin tag in the Release file.
+
+Default value: undef
+
+=cut
+
+$Options{'release_origin'} = undef;
+$OptionDefs{'release_origin'} = 'release_origin=s';
+
+=item B<release_label> => I<label tag>
+
+A string to be used for the Label tag in the Release file.
+
+Default value: undef
+
+=cut
+
+$Options{'release_label'} = undef;
+$OptionDefs{'release_label'} = 'release_label=s';
+
+=item B<release_description> => I<description tag>
+
+A string to be used for the Description tag in the Release file. (Note that
+this should be a single line.)
+
+Default value: undef
+
+=cut
+
+$Options{'release_description'} = undef;
+$OptionDefs{'release_description'} = 'release_description=s';
+
+=item B<release_noauto> = <array of NonAutomatic release names>
+
+An array of release names which should be tagged with 'NonAutomatic: yes'
+in their Release files. This tag will keep APT from ever automatically
+selecting a package from that archive as an installation candidate.
+
+Default value: [ 'experimental' ]
+
+=cut
+
+$Options{'release_noauto'} = [ 'experimental' ];
+$OptionDefs{'release_noauto'} = 'release_noauto=s@';
+
+=back
+
+=cut
+
+=head2 Signature configuration
+
+Please note that enabling any of these options will cause a dependancy on
+the 'gnupg' package. See F</usr/share/doc/debpool/README.GnuPG> for more
+information.
+
+=over 4
+
+=item B<require_sigs_debs> = I<boolean>
+
+If true, packages will be rejected unless their package files (.deb)
+are GPG-signed with a recognized key found one of the keyrings listed
+in 'gpg_keyrings'. These can be signed with the tools in the 'debsigs'
+package.
+
+Note that this option currently does nothing. It may be
+implemented in a future version of debpool. However, it's also possible
+that this option will be removed entirely as there seems to be
+little support for signed .deb files in Debian.
+
+Default value: 0 (false)
+
+See also: gpg_keyrings
+
+=cut
+
+$Options{'require_sigs_debs'} = 0;
+$OptionDefs{'require_sigs_debs'} = 'require_sigs_debs!';
+
+=item B<require_sigs_meta> = I<boolean>
+
+If true, packages will be rejected unless their meta-files (.changes and
+.dsc) are GPG-signed with a recognized key found one of the keyrings listed
+in 'gpg_keyrings'. These are the files normally signed by the 'debsign'
+utility in devscripts package.
+
+Default value: 0 (false)
+
+See also: gpg_keyrings
+
+=cut
+
+$Options{'require_sigs_meta'} = 0;
+$OptionDefs{'require_sigs_meta'} = 'require_sigs_meta!';
+
+=item B<sign_release> = I<boolean>
+
+If true, generated Release files will be GPG-signed with the key specified
+in 'gpg_sign_key'.
+
+Note that this will have no effect unless 'gpg_sign_key' is also defined at
+some point.
+
+Default value: 0 (false)
+
+See also: L<"Release configuration">, gpg_sign_key
+
+=cut
+
+$Options{'sign_release'} = 0;
+$OptionDefs{'sign_release'} = 'sign_release!';
+
+=back
+
+=cut
+
+=head2 GnuPG configuration
+
+These values will only be used if the use of GnuPG is triggered in some
+fashion (such as any of the values in L<"Signature configuration"> being
+enabled) , and thus do not (in themselves) trigger a dependancy on GnuPG.
+Please see F</usr/share/doc/debpool/README.GnuPG> for more information.
+
+=over 4
+
+=item B<gpg_bin> = I<GnuPG binary>
+
+This is used to specify the GnuPG binary to run.
+
+Default value: '/usr/bin/gpg'
+
+=cut
+
+$Options{'gpg_bin'} = '/usr/bin/gpg';
+$OptionDefs{'gpg_bin'} = 'gpg_bin=s';
+
+=item B<gpg_home> = I<GnuPG homedir>
+
+This is used to specify the GnuPG homedir (via the --homedir option).
+
+Default value: $ENV{'HOME'}.'/.gnupg'
+
+=cut
+
+$Options{'gpg_home'} = $ENV{'HOME'}.'/.gnupg';
+$OptionDefs{'gpg_home'} = 'gpg_home=s';
+
+=item B<gpg_keyrings> = I<array of keyring filenames>
+
+An arrayref pointing to an array which lists all of the GPG keyrings that
+hold keys for approved uploaders. Note that this will have no effect unless
+at least one of 'require_sigs_debs' or 'require_sigs_meta' is enabled.
+
+Default value: [ 'uploaders.gpg' ]
+
+See also: require_sigs_debs, require_sigs_meta
+
+=cut
+
+$Options{'gpg_keyrings'} = [ 'uploaders.gpg' ];
+$OptionDefs{'gpg_keyrings'} = 'gpg_keyrings=s@';
+
+=item B<gpg_sign_key> = I<signature keyID>
+
+A string which contains the ID of the key which we will sign Release files
+with. Note that this will have no effect unless 'sign_release' is true.
+
+Default value: undef
+
+See also: sign_release
+
+=cut
+
+$Options{'gpg_sign_key'} = undef;
+$OptionDefs{'gpg_sign_key'} = 'gpg_sign_key=s';
+
+=item B<gpg_passfile> = I<passphrase file>
+
+This specifies the name of the file from which we read the GnuPG passphrase
+for the key listed in gpg_sign_key. Note that it will have no effect unless
+'sign_release' is true and 'gpg_sign_key' is defined.
+
+Default value: $ENV{'HOME'}.'/.gnupg/passphrase';
+
+See also: sign_release, gpg_sign_key
+
+=cut
+
+$Options{'gpg_passfile'} = $ENV{'HOME'}.'/.gnupg/passphrase';
+$OptionDefs{'gpg_passfile'} = 'gpg_passfile=s';
+
+=back
+
+=head2 Logging configuration
+
+These are values which control the logging system.
+
+=over 4
+
+=item B<log_file> = I<filename>
+
+If this option is defined, logging output will be sent to the filename
+specified. Note that an undefined value is considered an explicit request
+to log nothing.
+
+Default value: $ENV{'HOME'}.'/.debpool/debpool.log';
+
+=cut
+
+$Options{'log_file'} = $ENV{'HOME'}.'/.debpool/debpool.log';
+$OptionDefs{'log_file'} = 'log_file=s';
+
+=head2 Misc. configuration
+
+These are values which don't particularly fit into any of the other
+sections.
+
+=over 4
+
+=item B<daemon> = I<boolean>
+
+This determines whether debpool runs as a daemon (never exiting except on
+fatal errors, rescanning the Incoming directory periodically), or on a
+single-run basis. True values cause debpool to run as a daemon.
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'daemon'} = 0;
+$OptionDefs{'daemon'} = 'daemon!';
+
+=item B<sleep> = I<delay>
+
+This option determines how long the daemon sleeps for, between each
+processing run. Note that signals (such as SIGHUP, SIGINT, or SIGTERM)
+will force the daemon to wake up before this expires, so don't worry about
+setting it too long.
+
+Default value: 300 (5 minutes)
+
+=cut
+
+$Options{'sleep'} = 300;
+$OptionDefs{'sleep'} = 'sleep=i';
+
+=item B<use_inotify> = I<boolean>
+
+Sets whether debpool should use inotify to monitor for incoming changes.
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'use_inotify'} = 0;
+$OptionDefs{'use_inotify'} = 'use_inotify!';
+
+=item B<rollback> = I<boolean>
+
+This determines whether older packages in the incoming queue are allowed
+to replace newer versions already in the archive (roll back the archive
+version).
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'rollback'} = 0;
+$OptionDefs{'rollback'} = 'rollback!';
+
+=item B<rebuild-files> = I<boolean>
+
+This option can be set in configfiles, but is more commonly used from the
+commandline; if set, it forces all of the distribution files (Packages and
+Sources) to be rebuilt, whether or not they need it. This should almost
+never be used in conjunction with the daemon option.
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'rebuild-files'} = 0;
+$OptionDefs{'rebuild-files'} = 'rebuild-files!';
+
+=item B<rebuild-dbs> = I<boolean>
+
+This option should not be set in configfiles, only used from the
+commandline; if set, it forces all of the metadata files to be rebuilt from
+scratch. This should almost never be used in conjunction with the daemon
+option.
+
+WARNING: This feature is not yet implemented, and will (silently) fail to
+do anything, at this time. It will be implemented in a future version.
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'rebuild-dbs'} = 0;
+$OptionDefs{'rebuild-dbs'} = 'rebuild-dbs!';
+
+=item B<rebuild-all> = I<boolean>
+
+This option should not be set in configfiles, only used from the
+commandline; if set, it is equivalent to turning on all other rebuild
+options (currently --rebuild-files and --rebuild-dbs).
+
+WARNING: This feature depends on rebuild-dbs, which is not yet implemented;
+only the --rebuild-files section will be triggered.
+
+Default value: 0 (false)
+
+=cut
+
+$Options{'rebuild-all'} = 0;
+$OptionDefs{'rebuild-all'} = 'rebuild-all!';
+
+=item B<config> = I<configfile>
+
+This is a special option that should not be put into configfiles; it is
+intended only for command-line use. It may be issued multiple times; each
+time it is used, it will add the named config file to the list which
+DebPool will load (later config files override earlier ones, in case of any
+conflicts).
+
+Default value: N/A
+
+=back
+
+=cut
+}
+
+END {}
+
+1;
+
+__END__
+
+=head1 CAVEATS
+
+Command line options will override all Config.pm declarations.
+
+=cut
+
+=head1 SEE ALSO
+
+L<debpool(1)>
+
+=cut
+
+=head1 AUTHOR
+
+Joel Baker <fenton at debian.org>
+
+This manpage is autogenerated from F<share/DebPool/Config.pm> of the
+source package during build time using pod2man.
+
+=cut
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/DB.pm b/lib/DebPool/DB.pm
new file mode 100644
index 0000000..1e7fdba
--- /dev/null
+++ b/lib/DebPool/DB.pm
@@ -0,0 +1,276 @@
+package DebPool::DB;
+
+###
+#
+# DebPool::DB - Module for managing data hashes via tied NDBM files
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: DB.pm 62 2005-02-23 18:02:38Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+# This module mostly wraps calls to tied NDBM hashes, so we need these.
+
+use Fcntl;
+use NDBM_File;
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ %ComponentDB
+ &Open_Databases
+ &Close_Databases
+ &Get_Version
+ &Get_Archs
+ &Set_Versions
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Open_Databases &Close_Databases &Get_Version
+ &Get_Archs &Set_Versions)],
+ 'vars' => [qw(%ComponentDB)],
+ );
+}
+
+### Exported package globals
+
+# I'd love to be able to do this as a hash of hashes of hashrefs, but the
+# database layer can't handle it. So we have multiple DBs.
+
+# VersionDB - hash of tied hashes, keyed on Distribution (then Source
+# package). Keeps track of all versions. Prior to 0.2.2, the value pointed
+# to was a scalar representing the version of the source package; as of
+# 0.2.2 and later, updated records are hashrefs pointing to hashes that
+# have package -> version mappings, with 'source' being the key for source
+# package version.
+
+our(%VersionDB);
+
+# ComponentDB - hash of tied hashes, keyed on Distribution (then Source
+# package). Stores the component data for the given package.
+
+our(%ComponentDB);
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Open_Databases()
+#
+# Open all tied NDBM hashes for each real distribution. Returns 0 in the
+# case of errors opening hashes, 1 otherwise.
+
+sub Open_Databases {
+ use DebPool::Config qw(:vars);
+
+ my($db_dir) = $Options{'db_dir'};
+ my($db_file_mode) = $Options{'db_file_mode'};
+
+ foreach my $dist (@{$Options{'realdists'}}) {
+ my(%tiedhash);
+ my($tie_result) = tie(%tiedhash, 'NDBM_File',
+ "$db_dir/${dist}_version",
+ O_RDWR|O_CREAT, $db_file_mode);
+ if (!defined($tie_result)) {
+ return 0;
+ };
+
+ $VersionDB{$dist} = \%tiedhash;
+ }
+
+ foreach my $dist (@{$Options{'realdists'}}) {
+ my(%tiedhash);
+ my($tie_result) = tie(%tiedhash, 'NDBM_File',
+ "$db_dir/${dist}_component",
+ O_RDWR|O_CREAT, $db_file_mode);
+ if (!defined($tie_result)) {
+ return 0;
+ };
+
+ $ComponentDB{$dist} = \%tiedhash;
+ }
+
+ return 1;
+}
+
+# Close_Databases()
+#
+# Closes all tied NDBM hashes.
+#
+# NOTE: Untie doesn't return anything (?), so we can't really trap errors.
+
+sub Close_Databases {
+ foreach my $dist (keys(%VersionDB)) {
+ untie(%{$VersionDB{$dist}});
+ }
+
+ foreach my $dist (keys(%ComponentDB)) {
+ untie(%{$ComponentDB{$dist}});
+ }
+
+ return 1;
+}
+
+# Get_Version($dist, $source, $package)
+#
+# Retrieves the version of $package (from source package $source) in
+# distribution $dist. The package name 'source' retrieves the source
+# package name, or undef if no information is available.
+
+sub Get_Version {
+ my($dist, $source, $package) = @_;
+
+ return unless defined $VersionDB{$dist}{$source};
+ my($version, $binlist, $archlist) = split(/\|/, $VersionDB{$dist}{$source});
+
+ # Versions prior to 0.2.2 had only one entry, which is the source
+ # version; since this is the same as the binary version on the vast
+ # majority of packages, fake an answer. This works because hash entries
+ # are guaranteed to be non-empty.
+
+ if (!defined $binlist) {
+ return $version;
+ }
+
+ if ('meta' eq $package) {
+ return $version;
+ } elsif ('source' eq $package) {
+ return $VersionDB{$dist}{"source_${source}"};
+ } else {
+ return $VersionDB{$dist}{"binary_${source}_${package}"};
+ }
+}
+
+sub Get_Archs {
+ my($dist, $source) = @_;
+
+ return unless defined $VersionDB{$dist}{$source};
+ my($version, $binlist, $archlist) = split(/\|/, $VersionDB{$dist}{$source});
+ return split /,/, $archlist if defined $archlist;
+ return @{$Options{'archs'}};
+}
+
+# Set_Versions($dist, $source, $file_arrayref)
+
+sub Set_Versions {
+ my($dist, $source, $meta_version, $file_arrayref) = @_;
+ my (%entries, %archs);
+ my($oldversion, $oldbinlist, $archlist);
+ ($oldversion, $oldbinlist, $archlist) =
+ split(/\|/, $VersionDB{$dist}{$source}) if defined $VersionDB{$dist}{$source};
+
+ if (defined($oldbinlist)) {
+ my(@oldbins) = split(/,/,$oldbinlist);
+ if ($oldversion ne $meta_version) {
+ # 0.2.2 or later
+ foreach my $oldbin (@oldbins) {
+ delete $VersionDB{$dist}{"binary_${source}_${oldbin}"};
+ }
+ delete $VersionDB{$dist}{"source_${source}"};
+ delete $VersionDB{$dist}{"${source}"};
+ }
+ else {
+ $entries{$_} = 1 foreach @oldbins;
+ if (defined $archlist) {
+ $archs{$_} = 1 foreach split /,/, $archlist;
+ }
+ }
+ }
+
+ # Walk through each file looking for version data. Note that only the
+ # .dsc file is guaranteed to be the same for source uploads (it can be
+ # orig.tar.gz or tar.gz, and diff.gz need not exist), and .deb files
+ # have binary versions, so that's all we look for.
+ #
+ # FIXME: Do udeb files have different versions from deb files?
+
+ my(@files) = @{$file_arrayref};
+
+ foreach my $hashref (@files) {
+ my($filename) = $hashref->{'Filename'};
+
+ if ($filename =~ m/^([^_]+)_([^_]+)_(.+)\.u?deb/) {
+ my($package, $version, $arch) = ($1, $2, $3);
+
+ $VersionDB{$dist}->{"binary_${source}_${package}"} = $version;
+ $entries{$package} = 1;
+ $archs{$arch} = 1;
+ } elsif ($filename =~ m/^[^_]+_([^_]+)\.dsc/) {
+ my($version) = $1;
+
+ $VersionDB{$dist}->{"source_${source}"} = $version;
+ $archs{source} = 1;
+ } # else skip
+ }
+
+ $VersionDB{$dist}{$source} = join('|', ${meta_version},
+ join(',', keys %entries),
+ join(',', keys %archs));
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Dirs.pm b/lib/DebPool/Dirs.pm
new file mode 100644
index 0000000..05ce56d
--- /dev/null
+++ b/lib/DebPool/Dirs.pm
@@ -0,0 +1,506 @@
+package DebPool::Dirs;
+
+###
+#
+# DebPool::Dirs - Module for dealing with directory related tasks
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Dirs.pm 71 2006-06-26 21:16:01Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Archfile
+ &Create_Tree
+ &Tree_Mkdir
+ &Setup_Incoming_Watch
+ &Monitor_Incoming
+ &PoolBasePath
+ &PoolDir
+ &Scan_Changes
+ &Scan_All
+ &Strip_Subsection
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Archfile &Create_Tree &Tree_Mkdir
+ &Monitor_Incoming &Setup_Incoming_Watch
+ &PoolBasePath &PoolDir &Scan_Changes &Scan_All
+ &Strip_Subsection)],
+ 'vars' => [qw()],
+ );
+}
+
+### Exported package globals
+
+# None
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+my($inotify);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Create_Tree()
+#
+# Creates a full directory tree based on the current directory values in
+# %DebPool::Config::Options. Returns 1 on success, 0 on failure (and sets
+# or propagates $Error).
+
+sub Create_Tree {
+ use DebPool::Config qw(:vars);
+
+ # Basic directories - none of these are terribly exciting. We don't set
+ # $Error on failure, because Tree_Mkdir will have already done so.
+
+ if (!Tree_Mkdir($Options{'db_dir'}, $Options{'db_dir_mode'})) {
+ return 0;
+ }
+
+ if (!Tree_Mkdir($Options{'incoming_dir'}, $Options{'incoming_dir_mode'})) {
+ return 0;
+ }
+
+ if (!Tree_Mkdir($Options{'installed_dir'}, $Options{'installed_dir_mode'})) {
+ return 0;
+ }
+
+ if (!Tree_Mkdir($Options{'reject_dir'}, $Options{'reject_dir_mode'})) {
+ return 0;
+ }
+
+ # Now the distribution directory and subdirectories
+
+ my($dists_dir) = $Options{'dists_dir'};
+ my($dists_dir_mode) = $Options{'dists_dir_mode'};
+
+ if (!Tree_Mkdir($dists_dir, $dists_dir_mode)) {
+ return 0;
+ }
+
+ # Real distributions are the only ones that get directories.
+
+ foreach my $dist (@{$Options{'realdists'}}) {
+ if (!Tree_Mkdir("$dists_dir/$dist", $dists_dir_mode)) {
+ return 0;
+ }
+
+ foreach my $section (@{$Options{'sections'}}) {
+ if (!Tree_Mkdir("$dists_dir/$dist/$section", $dists_dir_mode)) {
+ return 0;
+ }
+
+ foreach my $arch (@{$Options{'archs'}}) {
+ my($target) = "$dists_dir/$dist/$section/";
+ if ('source' eq $arch) {
+ $target .= $arch;
+ } else {
+ $target .= "binary-$arch";
+ }
+
+ if (!Tree_Mkdir($target, $dists_dir_mode)) {
+ return 0;
+ }
+ }
+ }
+ }
+
+ # Go through all of the distributions looking for those that should be
+ # symlinks, and creating them if necessary.
+
+ foreach my $dist (keys(%{$Options{'dists'}})) {
+ # Check whether it should be a symlink. If so, make sure it is.
+
+ if (!($dist eq $Options{'dists'}->{$dist})) { # Different names -> sym
+ if (! -e "$dists_dir/$dist") {
+ if (!symlink($Options{'dists'}->{$dist}, "$dists_dir/$dist")) {
+ $Error = "Couldn't create symlink $dists_dir/$dist -> ";
+ $Error .= "$Options{'dists'}->{$dist}: $!";
+ }
+ } elsif (! -l "$dists_dir/$dist") {
+ $Error = "$dists_dir/$dist exists and isn't a symlink, ";
+ $Error .= "but it should be";
+ return 0;
+ }
+ }
+ }
+
+ # And, finally, the pool directories and their subdirectories
+
+ my($pool_dir) = $Options{'pool_dir'};
+ my($pool_dir_mode) = $Options{'pool_dir_mode'};
+
+
+ if (!Tree_Mkdir($pool_dir, $pool_dir_mode)) {
+ return 0;
+ }
+
+ # We can only get away with this because Debian pool directories are
+ # named in ASCII...
+
+ foreach my $section (@{$Options{'sections'}}) {
+ next if $section =~ m/\s*\/debian-installer/;
+ if (!Tree_Mkdir("$pool_dir/$section", $pool_dir_mode)) {
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+# Tree_Mkdir($directory, $mode)
+#
+# Creates $directory with $mode. Returns 0 and sets $Error on failure, or
+# 1 on success.
+
+sub Tree_Mkdir {
+ my($dir, $mode) = @_;
+
+ if (-d $dir) {
+ return 1;
+ };
+
+ if (-e $dir) {
+ $Error = "Couldn't create '$dir' - already exists as a non-directory.";
+ return 0;
+ }
+
+ if (!mkdir($dir, $mode)) {
+ $Error = "Couldn't create '$dir': $!";
+ return 0;
+ }
+
+ if (!chmod($mode, $dir)) {
+ $Error = "Couldn't chmod '$dir': $!";
+ return 0;
+ }
+
+ return 1;
+}
+
+# Scan_Changes($directory)
+#
+# Scan the specified directory for changes files. Returns an array of
+# filenames relative to the directory, or undef (and sets $Error) on an error.
+
+sub Scan_Changes {
+ my($directory) = @_;
+
+ if (!opendir(INCOMING, $directory)) {
+ $Error = "Couldn't open directory '$directory': $!";
+ return;
+ }
+
+ # Perl magic - read the directory and grep it for *.changes all at one
+ # shot.
+
+ my(@changes) = grep(/\.changes$/, readdir(INCOMING));
+ close(INCOMING);
+
+ return @changes;
+}
+
+# Scan_All($directory)
+#
+# Scans the specified directory and all subdirectories for any files.
+# Returns an arrayref pointing to an array of filepaths relative to
+# $directory, or undef (and sets $Error) on failure. Ignores any hidden
+# files or directories.
+
+sub Scan_All {
+ my($directory) = @_;
+
+ if (!opendir(DIR, $directory)) {
+ $Error = "Couldn't open directory '$directory'";
+ return;
+ }
+
+
+ my(@entries) = grep(!/^\./, readdir(DIR));
+
+ my(@return);
+
+ foreach my $direntry (@entries) {
+ if (-f "$directory/$direntry") {
+ push(@return, $direntry);
+ } elsif (-d "$directory/$direntry") {
+ my($recurse) = Scan_All("$directory/$direntry");
+
+ if (!defined($recurse)) { # $Error is already set.
+ return;
+ }
+
+ # I'd like to use map(), but Perl makes stooopid guesses.
+
+ foreach my $entry (@{$recurse}) {
+ push(@return, "$direntry/$entry");
+ }
+ }
+ }
+
+ return \@return;
+}
+
+# Setup_Incoming_Watch()
+#
+# Creates a Linux::Inotify2 object and adds a watch on the incoming directory.
+# Returns 1 on success, 0 on failure (and sets $Error).
+
+sub Setup_Incoming_Watch {
+ use DebPool::Logging qw(:functions :facility :level);
+ use DebPool::Config;
+ if (!eval{ require Linux::Inotify2; }) {
+ Log_Message("liblinux-inotify2-perl is required to activate inotify support for debpool.", LOG_GENERAL, LOG_WARNING);
+ return 0;
+ } else {
+ use Linux::Inotify2;
+ }
+
+ $inotify = new Linux::Inotify2;
+ if (!$inotify) {
+ $Error = "Unable to create new inotify object: $!";
+ Log_Message("$Error", LOG_GENERAL, LOG_ERROR);
+ return 0;
+ }
+ if (!$inotify->watch("$Options{'incoming_dir'}",
+ IN_CLOSE_WRITE |
+ IN_MOVED_TO )) {
+ $Error = "Unable to watch $Options{'incoming_dir'}: $!";
+ Log_Message("$Error", LOG_GENERAL, LOG_ERROR);
+ return 0;
+ }
+ Log_Message("Watching $Options{'incoming_dir'} with Inotify",
+ LOG_GENERAL, LOG_DEBUG);
+ return 1;
+}
+
+# Watch_Incoming()
+#
+# Reads events from the Inotify2 object (blocking until one occurs),
+# picks out the .changes file(s) and returns them (if any; otherwise
+# it loops).
+#
+# Returns a list of .changes files on success, undef on failure (which
+# includes interruption by a signal).
+
+sub Watch_Incoming {
+ use DebPool::Logging qw(:functions :facility :level);
+
+ while (my @events = $inotify->read) {
+ my @changes;
+ foreach (@events) {
+ push @changes, $_->name if ($_->name =~ /\.changes$/);
+ }
+ if (@changes > 0) {
+ Log_Message("Found changes: ".join(', ', @changes),
+ LOG_GENERAL, LOG_DEBUG);
+ return @changes;
+ }
+ }
+ return;
+}
+
+# Monitor_Incoming()
+#
+# Monitors the incoming directory, looping until the directory is updated.
+# Returns a list of .changes files on success, undef on failure (which
+# includes interruption by a signal - check $DebPool::Signal::Signal_Caught).
+
+sub Monitor_Incoming {
+ use DebPool::Config;
+ use DebPool::Logging qw(:functions :facility :level);
+
+ # If this is ever false, we either shouldn't have been called in the
+ # first place, or we've caught a signal and shouldn't do anything
+ # further.
+
+ if ($DebPool::Signal::Signal_Caught) {
+ return;
+ }
+
+ if ($Options{'use_inotify'}) {
+ return Watch_Incoming();
+ } else {
+ my(@stat) = stat($Options{'incoming_dir'});
+ my($mtime) = $stat[9];
+
+ do {
+ Log_Message("Incoming monitor: sleeping for " .
+ $Options{'sleep'} . " seconds", LOG_GENERAL, LOG_DEBUG);
+ sleep($Options{'sleep'});
+ @stat = stat($Options{'incoming_dir'});
+ if (!@stat) {
+ $Error = "Couldn't stat incoming_dir '$Options{'incoming_dir'}'";
+ return;
+ }
+ return if $DebPool::Signal::Signal_Caught;
+ } until ($stat[9] != $mtime);
+
+ return Scan_Changes();
+ }
+}
+
+# PoolDir($name, $section, $archive_base)
+#
+# Calculates a pool subdirectory name from the package name and the section
+# (if provided; assumed to be 'main' if undefined or unrecognized).
+
+sub PoolDir {
+ my($name, $section, $archive_base) = @_;
+
+ $section = Strip_Subsection($section);
+
+ # Pool subdirectories are normally the first letter of the package
+ # name, unless it is a lib* package, in which case the subdir is
+ # lib<first letter>.
+
+ if ($name =~ s/^lib//) { # lib(.).*
+ return $section . '/' . 'lib' . substr($name, 0, 1);
+ } else { # (.).*
+ return $section . '/' . substr($name, 0, 1);
+ }
+}
+
+# Strip_Subsection($section)
+#
+# This routine could, perhaps, better named. However, the purpose is to
+# take a Section header as found in a package, and return the 'section'
+# (rather than [section/]subsection) of it - that is, 'main', 'contrib', or
+# 'non-free' (normally; it uses the configuration options to track this).
+#
+# Any unrecognized section is assumed to be 'main'; section values without
+# *any* subsection portion succeed, as well (at least, assuming that they
+# are otherwise valid).
+
+sub Strip_Subsection {
+ use DebPool::Config qw(:vars);
+
+ my($section) = @_;
+
+ if (!defined($section)) {
+ return 'main';
+ }
+
+ foreach my $check_section (@{$Options{'sections'}}) {
+ if ($section =~ m/^$check_section(\/.+)?$/) {
+ return $check_section;
+ }
+ }
+
+ return 'main';
+}
+
+# PoolBasePath()
+#
+# Calculates the value of the relative path from archive_dir to pool_dir
+# (this is primarily useful when having to provide file paths relative to
+# archive_dir, such as in Packages/Sources files). This does assume that
+# pool_dir is a subdirectory of archive_dir, but if that isn't true then
+# things are royally screwed up *anyway*...
+
+sub PoolBasePath {
+ use DebPool::Config qw(:vars);
+
+ my($path) = $Options{'pool_dir'};
+ $path =~ s/^$Options{'archive_dir'}\///;
+ return $path;
+}
+
+# Archfile($archive, $component, $architecture, $dironly)
+#
+# Returns the file name for the Packages/Sources file, or the directory
+# name of the arch directory if $dironly is true, (from a base of
+# dists_dir) for the specified archive, component, and architecture.
+
+sub Archfile {
+ my($archive) = shift(@_);
+ my($component) = shift(@_);
+ my($architecture) = shift(@_);
+ my($dironly) = shift(@_);
+
+ my($result) = "$archive/$component";
+
+ my($type);
+ if ('source' eq $architecture) {
+ $result .= "/${architecture}";
+ $type = "Sources";
+ } else {
+ $result .= "/binary-${architecture}";
+ $type = "Packages";
+ }
+
+ if (!$dironly) {
+ $result .= "/${type}";
+ }
+
+ return $result;
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/GnuPG.pm b/lib/DebPool/GnuPG.pm
new file mode 100644
index 0000000..eb8562c
--- /dev/null
+++ b/lib/DebPool/GnuPG.pm
@@ -0,0 +1,264 @@
+package DebPool::GnuPG;
+
+###
+#
+# DebPool::GnuPG - Module for all interactions with GNU Privacy Guard
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: GnuPG.pm 46 2005-02-12 17:52:37Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+use POSIX; # WEXITSTATUS
+use File::Temp ();
+
+# We need these for open3()
+
+use Fcntl;
+use IPC::Open3;
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Check_Signature
+ &Sign_Release
+ &Strip_GPG
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Check_Signature &Sign_Release &Strip_GPG)],
+ 'vars' => [qw()],
+ );
+}
+
+### Exported package globals
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Check_Signature($file, $signature)
+#
+# Checks the GPG signature of $file (using $signature as an external
+# signature file, if it is defined; if it isn't, $file is assumed to have
+# an internal signature). Returns 0 on failure, 1 on success.
+
+sub Check_Signature {
+ use DebPool::Config qw(:vars);
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($file, $signature) = @_;
+
+ my(@args) = ('--verify', '--no-default-keyring');
+ push(@args, '--homedir', $Options{'gpg_home'}) if defined $Options{'gpg_home'};
+
+ foreach my $keyring (@{$Options{'gpg_keyrings'}}) {
+ push(@args, '--keyring', $keyring);
+ }
+
+ push(@args, '--'); # Always a good idea, even if we're pretty sure we won't
+ # get any file names starting with "--" in this program.
+
+ if (defined($signature)) {
+ push(@args, $signature);
+ }
+
+ push(@args, $file);
+
+ my($pid) = open3(*GPG_IN, *GPG_OUT, *GPG_OUT, $Options{'gpg_bin'}, @args);
+ close(GPG_IN); # No input
+ my @loglines = <GPG_OUT>;
+
+ waitpid($pid,0); # No flags, just wait.
+
+ if ($?) { # Failure
+ foreach (@loglines) {
+ Log_Message($_, LOG_GPG, LOG_DEBUG);
+ }
+ my($msg) = "Failed signature check on '$file' ";
+ if (defined($signature)) {
+ $msg .= "(signature file '$signature'): ";
+ } else {
+ $msg .= "(internal signature): ";
+ }
+ if (WIFEXITED($?)) {
+ $msg .= "gpg returned non-zero status " . WEXITSTATUS($?);
+ }
+ elsif (WIFSIGNALED($?)) {
+ $msg .= "gpg died from signal " . WTERMSIG($?);
+ }
+ else {
+ $msg .= "gpg terminated in an unknown way.";
+ }
+ Log_Message($msg, LOG_GPG, LOG_WARNING);
+ }
+ return 1;
+}
+
+# Sign_Release($release_file)
+#
+# Generates a detached GPG signature file for $release_file, and returns
+# the filename. Returns undef, if an error occurs (and sets $Error).
+
+sub Sign_Release {
+ use DebPool::Config;
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($release_file) = @_;
+
+ # Open a secure tempfile to write the signature to
+
+ my($tmpfile) = new File::Temp;
+
+ # We are go for main engine start
+
+ my(@args) = ('--batch', '--no-tty', '--detach-sign', '--armor', '--output=-');
+ push(@args, '--homedir', $Options{'gpg_home'}) if defined $Options{'gpg_home'};
+ push(@args, '--default-key', $Options{'gpg_sign_key'}) if defined $Options{'gpg_sign_key'};
+ push(@args, '--passphrase-fd=0', '--passphrase-file', $Options{'gpg_passfile'}) if defined $Options{'gpg_passfile'};
+ push(@args, '--', $release_file);
+
+ my($gnupg_pid) = open3(*DUMMY, ">&".fileno $tmpfile, *GPG_ERR, $Options{'gpg_bin'}, @args);
+ close DUMMY;
+ my @loglines = <GPG_ERR>;
+ waitpid($gnupg_pid, 0);
+
+ foreach (@loglines) {
+ Log_Message($_, LOG_GPG, $? ? LOG_ERROR : LOG_WARNING);
+ }
+
+ if ($?) {
+ if (WIFEXITED($?)) {
+ $Error = "gpg returned non-zero status " . WEXITSTATUS($?);
+ }
+ elsif (WIFSIGNALED($?)) {
+ $Error = "gpg died from signal " . WTERMSIG($?);
+ }
+ else {
+ $Error = "gpg terminated in an unknown way.";
+ }
+ return;
+ }
+
+ # And we're done
+ $tmpfile->unlink_on_destroy(0);
+ return $tmpfile->filename;
+}
+
+# Strip_GPG(@text)
+#
+# Goes through @text and determine if it has GnuPG headers; if so, strip
+# out the headers, and undo GnuPG's header protection ('^-' -> '^-- -').
+
+sub Strip_GPG {
+ my(@text) = @_;
+
+ my($header, $firstblank, $sigstart, $sigend);
+
+ for my $count (0..$#text) {
+ if ($text[$count] =~ m/^-----BEGIN PGP SIGNED MESSAGE-----$/) {
+ $header = $count;
+ } elsif (!defined($firstblank) && $text[$count] =~ m/^$/) {
+ $firstblank = $count;
+ } elsif ($text[$count] =~ m/^-----BEGIN PGP SIGNATURE-----$/) {
+ $sigstart = $count;
+ } elsif ($text[$count] =~ m/^-----END PGP SIGNATURE-----$/) {
+ $sigend = $count;
+ }
+ }
+
+ # If we didn't find all three parts, it isn't a validly signed message
+ # (or it's externally signed, but that might as well be the same
+ # thing for our purposes - there's nothing to remove).
+
+ if (!defined($header) || !defined($sigstart) || !defined($sigend)) {
+ return @text;
+ }
+
+ # Okay. Back to front, so that we don't muck up reference numbers.
+ # First, we rip out the signature data by splicing it with an empty
+ # list.
+
+ splice(@text, $sigstart, ($sigend - $sigstart) + 1);
+
+ # We used to just rip off the first 3 lines (BEGIN line, hash header,
+ # and a blank line). However, this was a cheap shortcut that broke as
+ # of GnuPG 1.0.7, because it relied on there being exactly one GnuPG
+ # header line.
+ #
+ # Now, we rip out everything from the header line to the first blank,
+ # which should always be correct.
+
+ splice(@text, $header, ($firstblank - $header) + 1);
+
+ # All done. Fire it back.
+
+ return @text;
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Gzip.pm b/lib/DebPool/Gzip.pm
new file mode 100644
index 0000000..1c097c4
--- /dev/null
+++ b/lib/DebPool/Gzip.pm
@@ -0,0 +1,188 @@
+package DebPool::Gzip;
+
+###
+#
+# DebPool::Gzip - Module for handling Gzip interactions
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Gzip.pm 27 2004-11-07 03:06:59Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+use POSIX; # WEXITSTATUS
+
+# Needed for open2()
+
+use Fcntl;
+use IPC::Open2;
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Gzip_File
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Gzip_File)],
+ 'vars' => [qw()],
+ );
+}
+
+### Exported package globals
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Gzip_File($file)
+#
+# Generates a gzipped version of $file using gzip, and returns the filename.
+# Returns undef (and sets $Error) on failure.
+
+sub Gzip_File {
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($file) = @_;
+
+ # Open a secure tempfile to write the compressed data into
+
+ my($tmpfile) = new File::Temp( SUFFIX => '.gz', UNLINK => 0 );
+
+ # Open the source file so that we have it available.
+
+ if (!open($source_fh, '<', $file)) {
+ $Error = "Couldn't open source file '$file': $!";
+ return;
+ }
+
+ # We are go for main engine start
+
+ my(@args) = ('--best', '--force', '--stdout');
+
+ my($gzip_pid) = open2(*GZIP_IN, *GZIP_OUT, '/bin/gzip', @args);
+
+ my($child_pid);
+ if ($child_pid = fork) { # In the parent
+ # Send all the data to Gzip;
+
+ close(GZIP_IN);
+ close($tmpfile);
+
+ print GZIP_OUT <$source_fh>;
+ close(GZIP_OUT);
+ close($source_fh);
+
+ waitpid($child_pid, 0);
+ waitpid($gzip_pid, 0);
+ } else { # In the child - we hope
+ if (!defined($child_pid)) {
+ die "Couldn't fork: $!\n";
+ }
+
+ # Read back the results, and print them into the tempfile.
+
+ close(GZIP_OUT);
+ close($source_fh);
+
+ print $tmpfile <GZIP_IN>;
+ close(GZIP_IN);
+ close($tmpfile);
+
+ exit(0);
+ }
+
+ # And we're done
+ return $tmpfile->filename;
+}
+
+sub new {
+ bless { ERROR => undef };
+}
+
+sub Compress_File {
+ my $self = shift;
+ my $tempname = Gzip_File(@_);
+ if ($tempname) {
+ $self->{'ERROR'} = undef;
+ }
+ else {
+ $self->{'ERROR'} = $Error;
+ }
+ $tempname;
+}
+
+sub Error {
+ my $self = shift;
+ $self->{'ERROR'};
+}
+
+sub Name {
+ 'gzip';
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Logging.pm b/lib/DebPool/Logging.pm
new file mode 100644
index 0000000..3ea7e5a
--- /dev/null
+++ b/lib/DebPool/Logging.pm
@@ -0,0 +1,173 @@
+package DebPool::Logging;
+
+###
+#
+# DebPool::Logging - Module to handle logging messages
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Logging.pm 31 2005-01-19 17:32:38Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+# For strftime()
+
+use POSIX;
+
+# We need to pull config option information
+
+use DebPool::Config qw(:vars);
+use DebPool::DB qw(:functions); # DB::Close_Databases
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Log_Message
+ &LOG_AUDIT
+ &LOG_CONFIG
+ &LOG_DEBUG
+ &LOG_ERROR
+ &LOG_FATAL
+ &LOG_GENERAL
+ &LOG_GPG
+ &LOG_INFO
+ &LOG_INSTALL
+ &LOG_PARSE
+ &LOG_REJECT
+ &LOG_WARNING
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Log_Message)],
+ 'vars' => [qw()],
+ 'facility' => [qw(&LOG_AUDIT &LOG_CONFIG &LOG_GENERAL &LOG_GPG
+ &LOG_INSTALL &LOG_PARSE &LOG_REJECT)],
+ 'level' => [qw(&LOG_DEBUG &LOG_INFO &LOG_WARNING &LOG_ERROR
+ &LOG_FATAL)],
+ );
+}
+
+### Exported package globals
+
+# None
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions - facility
+
+sub LOG_AUDIT { 'AUDIT' }
+sub LOG_CONFIG { 'CONFIG' }
+sub LOG_GENERAL { 'GENERAL' }
+sub LOG_GPG { 'GPG' }
+sub LOG_INSTALL { 'INSTALL' }
+sub LOG_REJECT { 'REJECT' }
+sub LOG_PARSE { 'PARSE' }
+
+### Constant functions - level
+
+sub LOG_DEBUG { 'DEBUG' }
+sub LOG_INFO { 'INFO' }
+sub LOG_WARNING { 'WARNING' }
+sub LOG_ERROR { 'ERROR' }
+sub LOG_FATAL { 'FATAL' }
+
+### Meaningful functions
+
+# Log_Message($message, FACILITY, LEVEL)
+#
+# Log a message with text $message using FACILITY and LEVEL, via the current
+# configured log method.
+
+# FIXME - this is a really crude logging setup. We should probably support
+# a variety of things, like logging to processes, syslogging, not doing an
+# open/close for each message, maybe email logging with batched messages.
+#
+# However, this is an early version, so it will suffice for now.
+
+sub Log_Message {
+ my($msg, $facility, $level) = @_;
+
+ # First, do we have anywhere to log? We assume that 'undef' is an
+ # explicit request to not log, since it isn't a default value.
+
+ if (!defined($Options{'log_file'})) {
+ return;
+ }
+
+ # If we can't log to it, die with a message (on the off chance that we're
+ # not in daemon mode, and the user will see it).
+
+ my $log_fh;
+ if (!open($log_fh, '>>', $Options{'log_file'})) {
+ Close_Databases(); # If they were open
+ unlink($Options{'lock_file'}); # In case we had one
+
+ die "Couldn't write to log file '$Options{'log_file'}'.";
+ }
+
+ print $log_fh strftime("%Y-%m-%d %H:%M:%S", localtime());
+ print $log_fh " [$facility/$level] $msg\n";
+ close($log_fh);
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Packages.pm b/lib/DebPool/Packages.pm
new file mode 100644
index 0000000..fdf62f3
--- /dev/null
+++ b/lib/DebPool/Packages.pm
@@ -0,0 +1,1311 @@
+package DebPool::Packages;
+
+###
+#
+# DebPool::Packages - Module for handling package metadata
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Packages.pm 70 2006-06-26 20:44:57Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+use POSIX; # WEXITSTATUS
+use File::Temp qw(tempfile);
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Allow_Version
+ &Audit_Package
+ &Generate_List
+ &Generate_Package
+ &Generate_Source
+ &Guess_Section
+ &Install_List
+ &Install_Package
+ &Parse_Changes
+ &Parse_DSC
+ &Reject_Package
+ &Verify_MD5
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Allow_Version &Audit_Package &Generate_List
+ &Generate_Package &Generate_Source &Guess_Section
+ &Install_List &Install_Package &Parse_Changes
+ &Parse_DSC &Reject_Package &Verify_MD5)],
+ 'vars' => [qw()],
+ );
+}
+
+### Exported package globals
+
+# None
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our $Error;
+
+# Fields (other than package relationships) from dpkg --info that we
+# actually care about in some fashion.
+
+my @Info_Fields = (
+# 'Package',
+ 'Priority',
+ 'Section',
+ 'Installed-Size',
+# 'Maintainer',
+ 'Architecture',
+# 'Version',
+ 'Essential',
+);
+
+# Package relationship fieldnames.
+
+my @Relationship_Fields = (
+ 'Pre-Depends',
+ 'Depends',
+ 'Provides',
+ 'Conflicts',
+ 'Recommends',
+ 'Suggests',
+ 'Enhances',
+ 'Replaces',
+);
+
+# Normal fields potentially found in .changes files
+
+my %Changes_Fields = (
+ 'Format' => 'string',
+ 'Date' => 'string',
+ 'Source' => 'string',
+ 'Binary' => 'space_array',
+ 'Architecture' => 'space_array',
+ 'Version' => 'string',
+ 'Distribution' => 'space_array',
+ 'Urgency' => 'string',
+ 'Maintainer' => 'string',
+ 'Changed-By' => 'string',
+ 'Closes' => 'space_array',
+);
+
+# Normal fields potentially found in .dsc files
+
+my %DSC_Fields = (
+ 'Format' => 'string',
+ 'Source' => 'string',
+ 'Version' => 'string',
+ 'Binary' => 'comma_array',
+ 'Maintainer' => 'string',
+ 'Architecture' => 'space_array',
+ 'Standards-Version' => 'string',
+ 'Build-Depends' => 'comma_array',
+ 'Build-Depends-Indep' => 'comma_array',
+);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Allow_Version($package, $version, $distribution)
+#
+# Decide, based on version comparison and config options, whether $version
+# is an acceptable version for $package in $distribution. Returns 1 if the
+# version is acceptable, 0 if it is not, and undef (and sets $Error) in the
+# case of an error.
+
+sub Allow_Version {
+ use DebPool::Config qw(:vars);
+ use DebPool::DB qw(:functions);
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($package, $version, $distribution, $arch) = @_;
+ my $old_version = Get_Version($distribution, $package, 'meta');
+
+ # If we permit rollback, any version is valid.
+
+ if ($Options{'rollback'}) {
+ return 1;
+ }
+
+ # If we don't have an old version, anything is acceptable.
+
+ if (!defined($old_version)) {
+ return 1;
+ }
+
+ if ($version eq $old_version) {
+ my (%count, @duplicate_arches);
+ my @old_archs = Get_Archs($distribution, $package);
+ foreach (@old_archs, @$arch) {
+ if (++$count{$_} > 1) {
+ push @duplicate_arches, $_;
+ }
+ }
+ if (@duplicate_arches) {
+ my $msg = "Version comparison for '$package': ";
+ $msg .= "proposed version for $distribution ($version) ";
+ $msg .= "is same as current version and the following ";
+ $msg .= "architectures already exist: ";
+ $msg .= join ', ', @duplicate_arches;
+ Log_Message($msg, LOG_GENERAL, LOG_DEBUG);
+ return 0;
+ }
+ return 1;
+ }
+
+ my $dpkg_bin = '/usr/bin/dpkg';
+ my @args = ('--compare-versions', $version, 'gt', $old_version);
+
+ my $sysret = WEXITSTATUS(system($dpkg_bin, @args));
+
+ if (0 != $sysret) { # DPKG says no go.
+ my $msg = "Version comparison for '$package': proposed version for ";
+ $msg .= "$distribution ($version) is not greater than current ";
+ $msg .= "version ($old_version)";
+ Log_Message($msg, LOG_GENERAL, LOG_DEBUG);
+
+ return 0;
+ }
+
+ return 1;
+}
+
+# Parse_Changes($changes_filename)
+#
+# Parses the changes file found at $changes_filename (which should be a
+# fully qualified path and filename), and returns a hashref pointing to a
+# Changes hash. Returns undef in the case of a failure (and sets $Error).
+
+# Changes Hash format:
+# {
+# 'Architecture' => \@Architectures
+# 'Binary' => \@Binaries
+# 'Changed-By' => Changed-By
+# 'Changes' => \@Changes lines
+# 'Closes' => \@Bugs
+# 'Description' => Description
+# 'Files' => \@\%File Hashes
+# 'Date' => RFC 822 timestamp
+# 'Distribution' => \@Distributions
+# 'Maintainer' => Maintainer
+# 'Source' => Source
+# 'Urgency' => Urgency
+# 'Version' => Version
+# }
+
+# File Hash format:
+# {
+# 'Filename' => Filename (leaf node only)
+# 'MD5Sum' => File MD5Sum
+# 'Priority' => Requested archive priority
+# 'Section' => Requested archive section
+# 'Size' => File size (in bytes)
+# }
+
+sub Parse_Changes {
+ use DebPool::GnuPG qw(:functions);
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($file) = @_;
+ my %result;
+
+ # Read in the entire Changes file, stripping GPG encoding if we find
+ # it. It should be small, this is fine.
+
+ my $changes_fh;
+ if (!open($changes_fh, '<', $file)) {
+ $Error = "Couldn't open changes file '$file': $!";
+ return;
+ }
+
+ my @changes = <$changes_fh>;
+ chomp(@changes);
+ @changes = Strip_GPG(@changes);
+ close($changes_fh);
+
+ # Go through each of the primary fields, stuffing it into the result
+ # hash if we find it.
+
+ foreach my $field (keys(%Changes_Fields)) {
+ my @lines = grep(/^${field}:\s+/, @changes);
+ if (-1 == $#lines) { # No match
+ next;
+ } elsif (0 < $#lines) { # Multiple matches
+ Log_Message("Duplicate entries for field '$field'",
+ LOG_PARSE, LOG_WARNING);
+ }
+
+ $lines[0] =~ s/^${field}:\s+//;
+
+ if ('string' eq $Changes_Fields{$field}) {
+ $result{$field} = $lines[0];
+ } elsif ('space_array' eq $Changes_Fields{$field}) {
+ my @array = split(/\s+/, $lines[0]);
+ $result{$field} = \@array;
+ } elsif ('comma_array' eq $Changes_Fields{$field}) {
+ my @array = split(/\s+,\s+/, $lines[0]);
+ $result{$field} = \@array;
+ }
+ }
+
+ # Now that we should have it, check to make sure we have a Format
+ # header, and that it's format 1.7 or 1.8.
+
+ if (!defined($result{'Format'})) {
+ Log_Message("No Format header found in changes file '$file'",
+ LOG_PARSE, LOG_ERROR);
+ $Error = 'No Format header found';
+ return;
+ } elsif (('1.7' ne $result{'Format'}) and ('1.8' ne $result{'Format'})) {
+ Log_Message("Unrecognized Format version '$result{'Format'}'",
+ LOG_PARSE, LOG_ERROR);
+ $Error = 'Unrecognized Format version';
+ return;
+ }
+
+ # Special case: Description. One-line entry, immediately after a line
+ # with '^Description:'.
+
+ for my $count (0..$#changes) {
+ if ($changes[$count] =~ m/^Description:/) {
+ $result{'Description'} = $changes[$count+1];
+ }
+ }
+
+ # Special case: Changes. Multi-line entry, starts one line after
+ # '^Changes:', goes until we hit the Files header.
+
+ my($found) = 0;
+ my @changelines;
+
+ for my $count (0..$#changes) {
+ if ($found) {
+ if ($changes[$count] =~ m/^Files:/) {
+ $found = 0;
+ } else {
+ push(@changelines, $changes[$count]);
+ }
+ } else {
+ if ($changes[$count] =~ m/^Changes:/) {
+ $found = 1;
+ }
+ }
+ }
+
+ $result{'Changes'} = \@changelines;
+
+ # The Files section is a special case. It starts on the line after the
+ # 'Files:' header, and goes until we hit a blank line, or the end of
+ # the data.
+
+ my @files;
+
+ for my $count (0..$#changes) {
+ if ($found) {
+ if ($changes[$count] =~ m/^(\s*$|\S)/) { # End of Files entry
+ $found = 0; # No longer in Files
+ } elsif ($changes[$count] =~ m/\s*([[:xdigit:]]+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
+ my ($md5, $size, $sec, $pri, $file) = ($1, $2, $3, $4, $5);
+ push(@files, {
+ 'Filename' => $file,
+ 'MD5Sum' => $md5,
+ 'Priority' => $pri,
+ 'Section' => $sec,
+ 'Size' => $size,
+ });
+ } else { # What's this doing here?
+ my $msg = 'Unrecognized data in Files section of changes file';
+ $msg .= " '$file'";
+ Log_Message($msg, LOG_PARSE, LOG_WARNING);
+ }
+ } else {
+ if ($changes[$count] =~ m/^Files:/) {
+ $found = 1;
+ }
+ }
+ }
+
+ $result{'Files'} = \@files;
+
+ return \%result;
+}
+
+# Parse_DSC($dsc_filename)
+#
+# Parses the dsc file found at $dsc_filename (which should be a fully
+# qualified path and filename), and returns a hashref pointing to a DSC
+# hash. Returns undef in the case of a failure (and sets $Error).
+
+# DSC Hash format:
+# {
+# 'Format' => Format
+# 'Source' => Source
+# 'Binary' => \@Binaries
+# 'Maintainer' => Maintainer
+# 'Architecture' => \@Architectures
+# 'Standards-Version' => Standards-Version
+# 'Build-Depends' => Build-Depends
+# 'Build-Depends-Indep' => Build-Depends-Indep
+# 'Files' => \@\%Filehash
+# }
+
+# File Hash format:
+# {
+# 'Filename' => Filename (leaf node only)
+# 'MD5Sum' => File MD5Sum
+# 'Size' => File size (in bytes)
+# }
+
+sub Parse_DSC {
+ use DebPool::GnuPG qw(:functions);
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($file) = @_;
+ my %result;
+
+ # Read in the entire DSC file, stripping GPG encoding if we find it. It
+ # should be small, this is fine.
+
+ my $dsc_fh;
+ if (!open($dsc_fh, '<', $file)) {
+ $Error = "Couldn't open dsc file '$file': $!";
+ return;
+ }
+
+ my @dsc = <$dsc_fh>;
+ chomp(@dsc);
+ @dsc = Strip_GPG(@dsc);
+ close($dsc_fh);
+
+ # Go through each of the primary fields, stuffing it into the result
+ # hash if we find it.
+
+ foreach my $field (keys(%DSC_Fields)) {
+ my @lines = grep(/^${field}:\s+/, @dsc);
+ if (-1 == $#lines) { # No match
+ next;
+ } elsif (0 < $#lines) { # Multiple matches
+ Log_Message("Duplicate entries for field '$field'",
+ LOG_PARSE, LOG_WARNING);
+ }
+
+ $lines[0] =~ s/^${field}:\s+//;
+
+ if ('string' eq $DSC_Fields{$field}) {
+ $result{$field} = $lines[0];
+ } elsif ('space_array' eq $DSC_Fields{$field}) {
+ my @array = split(/\s+/, $lines[0]);
+ $result{$field} = \@array;
+ } elsif ('comma_array' eq $DSC_Fields{$field}) {
+ my @array = split(/\s+,\s+/, $lines[0]);
+ $result{$field} = \@array;
+ }
+ }
+
+ # Now that we should have it, check to make sure we have a Format
+ # header, and that it's format 1.0 (the only thing we grok).
+
+ if (!defined($result{'Format'})) {
+ Log_Message("No Format header found in dsc file '$file'",
+ LOG_PARSE, LOG_ERROR);
+ $Error = 'No Format header found';
+ return;
+ } elsif ('1.0' ne $result{'Format'}) {
+ Log_Message("Unrecognized Format version '$result{'Format'}'",
+ LOG_PARSE, LOG_ERROR);
+ $Error = 'Unrecognized Format version';
+ return;
+ }
+
+ # The Files section is a special case. It starts on the line after the
+ # 'Files:' header, and goes until we hit a blank line, or the end of
+ # the data.
+
+ # In fact, it's even more special than that; it includes, first, an entry
+ # for the DSC file itself...
+
+ my $count;
+ my $found = 0;
+ my @files;
+
+ my @temp = split(/\//, $file);
+ my $dsc_leaf = pop(@temp);
+
+ my $cmd_result = `/usr/bin/md5sum $file`;
+ $cmd_result =~ m/^([[:xdigit:]]+)\s+/;
+ my $dsc_md5 = $1;
+
+ my @stat = stat($file);
+ if (!@stat) {
+ $Error = "Couldn't stat DSC file '$file'";
+ return;
+ }
+ my $dsc_size = $stat[7];
+
+ push(@files, {
+ 'Filename' => $dsc_leaf,
+ 'MD5Sum' => $dsc_md5,
+ 'Size' => $dsc_size,
+ });
+
+ for my $count (0..$#dsc) {
+ if ($found) {
+ if ($dsc[$count] =~ m/^(\s*$|\S)/) { # End of Files entry
+ $found = 0; # No longer in Files
+ } elsif ($dsc[$count] =~ m/\s*([[:xdigit:]]+)\s+(\d+)\s+(\S+)/) {
+ my($md5, $size, $file) = ($1, $2, $3);
+ push(@files, {
+ 'Filename' => $file,
+ 'MD5Sum' => $md5,
+ 'Size' => $size,
+ });
+ } else { # What's this doing here?
+ my $msg = 'Unrecognized data in Files section of dsc file';
+ $msg .= " '$file'";
+ Log_Message($msg, LOG_PARSE, LOG_WARNING);
+ }
+ } else {
+ if ($dsc[$count] =~ m/^Files:/) {
+ $found = 1;
+ }
+ }
+ }
+
+ $result{'Files'} = \@files;
+
+ return \%result;
+}
+
+# Generate_List($distribution, $section, $arch)
+#
+# Generates a Packages (or Sources) file for the given distribution,
+# section, and architecture (with 'source' being a special value for
+# Sources). Returns the filename of the generated file on success, or undef
+# (and sets $Error) on failure. Note that requests for an 'all' list are
+# ignored - however, every non-source arch gets 'all' files.
+
+sub Generate_List {
+ use DebPool::Config qw(:vars);
+ use DebPool::DB qw(:functions :vars);
+ use DebPool::Dirs qw(:functions);
+
+ my($distribution, $section, $arch) = @_;
+
+ my %packages;
+
+ if ('all' eq $arch) {
+ $Error = "No point in generating Packages file for binary-all";
+ return;
+ }
+
+ my @sources = grep($ComponentDB{$distribution}->{$_} eq $section,
+ keys(%{$ComponentDB{$distribution}}));
+
+ my($tmpfile_handle, $tmpfile_name) = tempfile();
+
+ # Dump the data from pool/*/*/pkg_ver.{package,source} into the list.
+
+ # FIXME: This needs to be refactored. Needs it pretty badly, in fact.
+
+ if ('source' eq $arch) {
+ foreach my $source (@sources) {
+ my $pool = join('/',
+ ($Options{'pool_dir'}, PoolDir($source, $section), $source));
+ my $version = Get_Version($distribution, $source, 'meta');
+ my $target = "$pool/${source}_" . Strip_Epoch($version);
+ $target .= '.source';
+
+ # Source files aren't always present.
+ next if (!open(my $src_fh, '<', "$target"));
+
+ $tmpfile_handle->print(<$src_fh>);
+ close($src_fh);
+ }
+ } else {
+ foreach my $source (@sources) {
+ my $pool = join('/',
+ ($Options{'pool_dir'}, PoolDir($source, $section), $source));
+ my $version = Get_Version($distribution, $source, 'meta');
+ my $target = "$pool/${source}_" . Strip_Epoch($version);
+ $target .= "_$arch\.package";
+ my $target_all = "$pool/${source}_" . Strip_Epoch($version);
+ $target_all .= "_all\.package";
+
+ my ($pkg_arch_fh, $pkg_all_fh);
+
+ # Check for any binary-arch packages
+ if (-e $target) {
+ if (!open($pkg_arch_fh, '<', "$target")) {
+ my $msg = "Skipping package entry for all packages from ";
+ $msg .= "${source}: couldn't open '$target' for reading: $!";
+
+ Log_Message($msg, LOG_GENERAL, LOG_ERROR);
+ next;
+ }
+ }
+
+ # Check for any binary-all packages
+ if (-e $target_all) {
+ if (!open($pkg_all_fh, '<', "$target_all")) {
+ my $msg = "Skipping package entry for all packages ";
+ $msg .= "from ${source}: couldn't open '$target_all' for";
+ $msg .= " reading: $!";
+
+ Log_Message($msg, LOG_GENERAL, LOG_ERROR);
+ next;
+ }
+ }
+
+ # Playing around with the record separator ($/) to make this
+ # easier.
+
+ my $backup_RS = $/;
+ $/ = "";
+
+ my @arch_entries;
+ if (-e $target) { # Write entries from arch packages
+ @arch_entries = <$pkg_arch_fh>;
+ close($pkg_arch_fh);
+ }
+
+ my @all_entries;
+ if (-e $target_all) { # Write entries from all packages
+ @all_entries = <$pkg_all_fh>;
+ close($pkg_all_fh);
+ }
+
+ $/ = $backup_RS;
+
+ # Pare it down to the relevant entries, and print those out.
+
+ @arch_entries = grep(/\nArchitecture: ($arch)\n/, @arch_entries);
+ @all_entries = grep(/\nArchitecture: all\n/, @all_entries);
+ print $tmpfile_handle @arch_entries;
+ print $tmpfile_handle @all_entries;
+ }
+ }
+
+ close($tmpfile_handle);
+
+ return $tmpfile_name;
+}
+
+# Install_Package($changes, $Changes_hashref, $DSC, $DSC_hashref, \@distributions)
+#
+# Install all of the package files for $Changes_hashref (which should
+# be a Parse_Changes result hash) into the pool directory, and install
+# the file in $changes to the installed directory. Also generates (and
+# installes) .package and .source meta-data files. It also updates the
+# Version database for the listed distributions. Returns 1 if successful, 0
+# if not (and sets $Error).
+
+sub Install_Package {
+ use DebPool::Config qw(:vars);
+ use DebPool::Dirs qw(:functions);
+ use DebPool::DB qw(:functions :vars);
+ use DebPool::Util qw(:functions);
+
+ my($changes, $chg_hashref, $dsc, $dsc_hashref, $distributions) = @_;
+
+ my $incoming_dir = $Options{'incoming_dir'};
+ my $installed_dir = $Options{'installed_dir'};
+ my $pool_dir = $Options{'pool_dir'};
+
+ my $pkg_name = $chg_hashref->{'Source'};
+ my $pkg_ver = $chg_hashref->{'Version'};
+
+ my $guess_section = Guess_Section($chg_hashref);
+ my $pkg_pool_subdir = join('/',
+ ($pool_dir, PoolDir($pkg_name, $guess_section)));
+ my $pkg_dir = join('/', ($pkg_pool_subdir, $pkg_name));
+
+ # Create the directory or error out
+
+ if (!Tree_Mkdir($pkg_pool_subdir, $Options{'pool_dir_mode'})) {
+ return 0;
+ }
+ if (!Tree_Mkdir($pkg_dir, $Options{'pool_dir_mode'})) {
+ return 0;
+ }
+
+ # Walk the File Hash, trying to install each listed file into the
+ # pool directory.
+
+ foreach my $filehash (@{$chg_hashref->{'Files'}}) {
+ my $file = $filehash->{'Filename'};
+ if (!Move_File("${incoming_dir}/${file}", "${pkg_dir}/${file}",
+ $Options{'pool_file_mode'})) {
+ $Error = "Failed to move '${incoming_dir}/${file}' ";
+ $Error .= "to '${pkg_dir}/${file}': ${DebPool::Util::Error}";
+ return 0;
+ }
+ }
+
+ # Generate and install .package and .source metadata files.
+
+ my @pkg_archs = @{$chg_hashref->{'Architecture'}};
+ @pkg_archs = grep(!/source/, @pkg_archs); # Source is on it's own.
+
+ my $target;
+ foreach my $pkg_arch (@pkg_archs) {
+ my $pkg_file = Generate_Package($chg_hashref, $pkg_arch);
+
+ if (!defined($pkg_file)) {
+ $Error = "Failed to generate .package file: $Error";
+ return;
+ }
+
+ $target = "$pkg_dir/${pkg_name}_" . Strip_Epoch($pkg_ver) . "_$pkg_arch" . '.package';
+
+ if (!Move_File($pkg_file, $target, $Options{'pool_file_mode'})) {
+ $Error = "Failed to move '$pkg_file' to '$target': ";
+ $Error .= $DebPool::Util::Error;
+ return 0;
+ }
+ }
+
+ if (defined($dsc) && defined($dsc_hashref)) {
+ my $src_file = Generate_Source($dsc, $dsc_hashref, $chg_hashref);
+
+ if (!defined($src_file)) {
+ $Error = "Failed to generate .source file: $Error";
+ return;
+ }
+
+ $target = "$pkg_dir/${pkg_name}_" . Strip_Epoch($pkg_ver) . '.source';
+
+ if (!Move_File($src_file, $target, $Options{'pool_file_mode'})) {
+ $Error = "Failed to move '$src_file' to '$target': ";
+ $Error .= $DebPool::Util::Error;
+ return 0;
+ }
+ }
+
+ # Finally, try to install the changes file to the installed directory.
+
+ if (!Move_File("$incoming_dir/$changes", "$installed_dir/$changes",
+ $Options{'installed_file_mode'})) {
+ $Error = "Failed to move '$incoming_dir/$changes' to ";
+ $Error .= "'$installed_dir/$changes': ${DebPool::Util::Error}";
+ return 0;
+ }
+
+ # Update the various databases.
+
+ my $distribution;
+
+ # This whole block is just to calculate the component. What a stupid
+ # setup - it should be in the changes file. Oh well.
+
+ my @filearray = @{$chg_hashref->{'Files'}};
+ my $fileref = $filearray[0];
+ my $section = $fileref->{'Section'};
+ my $component = Strip_Subsection($section);
+
+ foreach my $distribution (@{$distributions}) {
+ Set_Versions($distribution, $pkg_name, $pkg_ver,
+ $chg_hashref->{'Files'});
+ $ComponentDB{$distribution}->{$pkg_name} = $component;
+ }
+ if ( $section eq 'debian-installer' ) {
+ $component .= '/debian-installer';
+ }
+
+ return 1;
+}
+
+# Reject_Package($changes, $chg_hashref)
+#
+# Move all of the package files for $chg_hashref (which should be a
+# Parse_Changes result hash) into the rejected directory, as well as the
+# file in $changes. Returns 1 if successful, 0 if not (and sets $Error).
+
+sub Reject_Package {
+ use DebPool::Config qw(:vars);
+ use DebPool::DB qw(:functions);
+ use DebPool::Util qw(:functions);
+
+ my($changes, $chg_hashref) = @_;
+
+ my $incoming_dir = $Options{'incoming_dir'};
+ my $reject_dir = $Options{'reject_dir'};
+ my $reject_file_mode = $Options{'reject_file_mode'};
+
+ # Walk the File Hash, moving each file to the rejected directory.
+
+ foreach my $filehash (@{$chg_hashref->{'Files'}}) {
+ my $file = $filehash->{'Filename'};
+ if (!Move_File("$incoming_dir/$file", "$reject_dir/$file",
+ $reject_file_mode)) {
+ $Error = "Failed to move '$incoming_dir/$file' ";
+ $Error .= "to '$reject_dir/$file': ${DebPool::Util::Error}";
+ return 0;
+ }
+ }
+
+ # Now move the changes file to the rejected directory, as well.
+
+ if (!Move_File("$incoming_dir/$changes", "$reject_dir/$changes",
+ $reject_file_mode)) {
+ $Error = "Failed to move '$incoming_dir/$changes' to ";
+ $Error .= "'$reject_dir/$changes': ${DebPool::Util::Error}";
+ return 0;
+ }
+
+ return 1;
+}
+
+# Verify_MD5($file, $md5)
+#
+# Verifies the MD5 checksum of $file against $md5. Returns 1 if it matches,
+# 0 if it doesn't, and undef (also setting $Error) if an error occurs. This
+# routine uses the dpkg md5sum utility, to avoid pulling in a dependancy on
+# Digest::MD5.
+
+sub Verify_MD5 {
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($file, $md5) = @_;
+
+ # Read in and mangle the md5 output.
+
+ if (! -r $file) { # The file doesn't exist! Will be hard to checksum it...
+ my $msg = "MD5 checksum unavailable: file '$file' does not exist!";
+ Log_Message($msg, LOG_GENERAL, LOG_ERROR);
+ return 0;
+ }
+
+ my $cmd_result = `/usr/bin/md5sum $file`;
+ if (!$cmd_result) { # Failed to run md5sum for some reason
+ my $msg = "MD5 checksum unavailable: file '$file'";
+ Log_Message($msg, LOG_GENERAL, LOG_ERROR);
+ return 0;
+ }
+
+ $cmd_result =~ m/^([[:xdigit:]]+)\s+/;
+ my $check_md5 = $1;
+
+ if ($md5 ne $check_md5) {
+ my $msg = "MD5 checksum failure: file '$file', ";
+ $msg .= "expected '$md5', got '$check_md5'";
+ Log_Message($msg, LOG_GENERAL, LOG_ERROR);
+ return 0;
+ }
+
+ return 1;
+}
+
+# Audit_Package($package, $chg_hashref)
+#
+# Delete a package and changes files for the named (source) package which
+# are not referenced by any version currently found in the various release
+# databases. Returns the number of files unlinked (which may be 0), or
+# undef (and sets $Error) on an error.
+
+sub Audit_Package {
+ use DebPool::Config qw(:vars);
+ use DebPool::Dirs qw(:functions);
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($package, $changes_hashref) = @_;
+
+ # Checking for version of package being installed
+ my $changes_version = $changes_hashref->{'Version'};
+ # Checking for binary only upload
+ my $with_source = undef;
+ # Checking for binary-all packages in binary only upload
+ my $with_indep = undef;
+ for my $temp (@{$changes_hashref->{'Architecture'}}) {
+ if ('source' eq $temp) {
+ $with_source = 1;
+ }
+ if ('all' eq $temp) {
+ $with_indep = 1;
+ }
+ }
+
+ my $installed_dir = $Options{'installed_dir'};
+ my $pool_dir = $Options{'pool_dir'};
+
+ my $section = Guess_Section($changes_hashref);
+ my $package_dir = join('/',
+ ($pool_dir, PoolDir($package, $section), $package));
+
+ my @changes = grep(/${package}_/, Scan_Changes($installed_dir));
+
+ my $pool_scan = Scan_All($package_dir);
+ if (!defined($pool_scan)) {
+ $Error = $DebPool::Dirs::Error;
+ return;
+ }
+ my @pool_files = @{$pool_scan};
+
+ # Go through each file found in the pool directory, and determine its
+ # version. If it isn't in the current version tables, unlink it.
+
+ my $unlinked = 0;
+ foreach my $file (@pool_files) {
+ my $orig = 0;
+ my $deb = 0;
+ my $src = 0;
+ my($bin_package, $version);
+
+ if ($file =~ m/^([^_]+)_([^_]+)\.orig\.tar\.gz$/) { # orig.tar.gz
+ $bin_package = $1;
+ $version = $2;
+ $src = 1;
+ $orig = 1;
+ } elsif ($file =~ m/^([^_]+)_([^_]+)\.tar\.gz$/) { # tar.gz
+ $bin_package = $1;
+ $version = $2;
+ $src = 1;
+ } elsif ($file =~ m/^([^_]+)_([^_]+)\.diff\.gz$/) { # diff.gz
+ $bin_package = $1;
+ $version = $2;
+ $src = 1;
+ } elsif ($file =~ m/^([^_]+)_([^_]+)\.dsc$/) { # dsc
+ $bin_package = $1;
+ $version = $2;
+ $src = 1;
+ } elsif ($file =~ m/^([^_]+)_([^_]+)_.+\.deb$/) { # deb
+ $bin_package = $1;
+ $version = $2;
+ $deb = 1;
+ } elsif ($file =~ m/^([^_]+)_([^_]+)_.+\.udeb$/) { # udeb
+ $bin_package = $1;
+ $version = $2;
+ $deb = 1;
+ } elsif ($file =~ m/^([^_]+)_([^_]+)_.+\.package$/) { # package metadata
+ $bin_package = $1;
+ $version = $2;
+ } elsif ($file =~ m/^([^_]+)_([^_]+)\.source$/) { # source metadata
+ $bin_package = $1;
+ $version = $2;
+ } else {
+ Log_Message("Couldn't figure out filetype for '$package_dir/$file'",
+ LOG_AUDIT, LOG_ERROR);
+ next;
+ }
+
+ # Skip files if we recognize it as a valid version.
+
+ # Skipping dsc, diff.gz, and orig tarball files if doing a binary only
+ # upload
+ if (!$with_source) {
+ $src = 0;
+ # Skip binary-all packages in a binary only upload without
+ # binary-all packages as long as they're of the same changes
+ # version
+ if ((!$with_indep) &&
+ ($file =~ m/\Q_${changes_version}_all.\Eu?deb/)) {
+ $deb = 0;
+ }
+ }
+ my $matched = 0;
+ foreach my $dist (@{$Options{'realdists'}}) {
+ my $ver_pkg;
+ if ($src) {
+ $ver_pkg = 'source';
+ } elsif ($deb) {
+ $ver_pkg = $bin_package;
+ } else {
+ $ver_pkg = 'meta';
+ }
+
+ my $dist_ver = Get_Version($dist, $package, $ver_pkg);
+ next if (!defined($dist_ver)); # No version in specified dist
+ $dist_ver = Strip_Epoch($dist_ver);
+ if ($orig) { $dist_ver =~ s/-.+$//; }
+ if ($version eq $dist_ver) { $matched = 1; }
+ }
+ next if $matched;
+
+ # Otherwise, unlink it.
+
+ if (unlink("$package_dir/$file")) {
+ $unlinked += 1;
+ Log_Message("Unlinked obsolete pool file '$package_dir/$file'",
+ LOG_AUDIT, LOG_DEBUG);
+ } else {
+ Log_Message("Couldn't obsolete pool file '$package_dir/$file'",
+ LOG_AUDIT, LOG_ERROR);
+ }
+ }
+
+ foreach my $file (@changes) {
+ $file =~ m/^[^_]+_([^_]+)_.+$/; # changes
+ my $version = $1;
+
+ my $matched = 0;
+ foreach my $dist (@{$Options{'realdists'}}) {
+ my $dist_ver = Get_Version($dist, $package, 'meta');
+ next if (!defined($dist_ver)); # No version in specified dist
+ $dist_ver = Strip_Epoch($dist_ver);
+ if ($version eq $dist_ver) { $matched = 1; }
+ }
+ next if $matched;
+
+ if (unlink("$installed_dir/$file")) {
+ $unlinked += 1;
+ Log_Message("Unlinked obsolete changes file " .
+ "'$installed_dir/$file'", LOG_AUDIT, LOG_DEBUG);
+ } else {
+ Log_Message("Couldn't obsolete changes file " .
+ "'$installed_dir/$file'", LOG_AUDIT, LOG_ERROR);
+ }
+ }
+
+ return $unlinked;
+}
+
+# Generate_Package($chg_hashref)
+#
+# Generates a .package metadata file (Packages entries for each binary
+# package) in the tempfile area, and returns the filename. Returns undef
+# (and sets $Error) on failure.
+
+sub Generate_Package {
+ use DebPool::Config qw(:vars);
+ use DebPool::Dirs qw(:functions);
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($changes_data, $arch) = @_;
+ my $source = $changes_data->{'Source'};
+ my @files = @{$changes_data->{'Files'}};
+ my $pool_base = PoolBasePath();
+
+ # Grab a temporary file.
+
+ my($tmpfile_handle, $tmpfile_name) = tempfile();
+
+ my @packages = @{$changes_data->{'Binary'}};
+
+ my $package;
+
+ foreach my $package (@packages) {
+ # Construct a pattern to match the filename and nothing else.
+ # This used to be an exact match using the source version, but
+ # Debian's standards are sort of insane, and the version number
+ # on binary files is not always the same as that on the source
+ # file (nor is it even something simple like "source version
+ # without the epoch" -- it is more or less arbitrary, as long
+ # as it is a well-formed version number).
+ my $filepat = qr/^\Q${package}_\E.*\Q_${arch}.\Eu?deb/;
+ my $section = Guess_Section($changes_data);
+ my $pool = join('/', (PoolDir($source, $section), $source));
+
+ my $marker = -1;
+ # Step through each file, match against filename. Save matches
+ # for later use.
+
+ for my $count (0..$#files) {
+ if ($files[$count]->{'Filename'} =~ m/^$filepat$/) {
+ $marker = $count;
+ }
+ }
+
+ # The changes file has a stupid quirk; it puts all binaries from
+ # a package in the Binary: line, even if they weren't built (for
+ # example, an Arch: all doc package when doing an arch-only build
+ # for a port). So if we didn't find a .deb file for it, assume
+ # that it's one of those, and skip, rather than choking on it.
+
+ next if (-1 == $marker);
+
+ # Run Dpkg_Info to grab the dpkg --info data on the package.
+
+ my $file = $files[$marker]->{'Filename'};
+ my $info = Dpkg_Info("$Options{'pool_dir'}/$pool/$file");
+
+ # Dump all of our data into the metadata tempfile.
+
+ print $tmpfile_handle "Package: $package\n";
+
+ if (defined($info->{'Priority'})) {
+ print $tmpfile_handle "Priority: $info->{'Priority'}\n";
+ }
+
+ if (defined($info->{'Section'})) {
+ print $tmpfile_handle "Section: $info->{'Section'}\n";
+ }
+
+ if (defined($info->{'Essential'})) {
+ print $tmpfile_handle "Essential: $info->{'Essential'}\n";
+ }
+
+ print $tmpfile_handle "Installed-Size: $info->{'Installed-Size'}\n";
+
+ print $tmpfile_handle "Maintainer: $changes_data->{'Maintainer'}\n";
+ print $tmpfile_handle "Architecture: $arch\n";
+ print $tmpfile_handle "Source: $source\n";
+ print $tmpfile_handle "Version: $changes_data->{'Version'}\n";
+
+ # All of the inter-package relationships go together, and any
+ # one of them can potentially be empty (and omitted).
+
+ foreach my $field (@Relationship_Fields) {
+ if (defined($info->{$field})) {
+ print $tmpfile_handle "${field}: $info->{$field}\n";
+ }
+ }
+
+ # And now, some stuff we can grab out of the parsed changes
+ # data far more easily than anywhere else.
+
+ print $tmpfile_handle "Filename: $pool_base/$pool/$file\n";
+
+ print $tmpfile_handle "Size: $files[$marker]->{'Size'}\n";
+ print $tmpfile_handle "MD5sum: $files[$marker]->{'MD5Sum'}\n";
+
+ print $tmpfile_handle "Description: $info->{'Description'}";
+
+ print $tmpfile_handle "\n";
+ }
+
+ # All done
+
+ close($tmpfile_handle);
+ return $tmpfile_name;
+}
+
+# Generate_Source($dsc, $dsc_hashref, $changes_hashref)
+#
+# Generates a .source metadata file (Sources entries for the source
+# package) in the tempfile area, and returns the filename. Returns undef
+# (and sets $Error) on failure.
+
+sub Generate_Source {
+ use DebPool::Dirs qw(:functions);
+ use DebPool::Logging qw(:functions :facility :level);
+
+ my($dsc, $dsc_data, $changes_data) = @_;
+ my $source = $dsc_data->{'Source'};
+ my @files = @{$dsc_data->{'Files'}};
+
+ # Figure out the priority and section, using the DSC filename and
+ # the Changes file data.
+
+ my ($section, $priority);
+ foreach my $filehr (@{$changes_data->{'Files'}}) {
+ if ($filehr->{'Filename'} eq $dsc) {
+ $section = $filehr->{'Section'};
+ $priority = $filehr->{'Priority'};
+ }
+ }
+
+ # Grab a temporary file.
+
+ my($tmpfile_handle, $tmpfile_name) = tempfile();
+
+ # Dump out various metadata.
+
+ print $tmpfile_handle "Package: $source\n";
+ print $tmpfile_handle "Binary: " . join(', ', @{$dsc_data->{'Binary'}}) . "\n";
+ print $tmpfile_handle "Version: $dsc_data->{'Version'}\n";
+ print $tmpfile_handle "Priority: $priority\n";
+ print $tmpfile_handle "Section: $section\n";
+ print $tmpfile_handle "Maintainer: $dsc_data->{'Maintainer'}\n";
+
+ if (defined($dsc_data->{'Build-Depends'})) {
+ print $tmpfile_handle 'Build-Depends: ';
+ print $tmpfile_handle join(', ', @{$dsc_data->{'Build-Depends'}}) . "\n";
+ }
+
+ if (defined($dsc_data->{'Build-Depends-Indep'})) {
+ print $tmpfile_handle 'Build-Depends-Indep: ';
+ print $tmpfile_handle join(', ', @{$dsc_data->{'Build-Depends-Indep'}}) . "\n";
+ }
+
+ print $tmpfile_handle 'Architecture: ';
+ print $tmpfile_handle join(' ', @{$dsc_data->{'Architecture'}}) . "\n";
+
+ print $tmpfile_handle "Standards-Version: $dsc_data->{'Standards-Version'}\n"
+ if exists $dsc_data->{'Standards-Version'};
+ print $tmpfile_handle "Format: $dsc_data->{'Format'}\n";
+ print $tmpfile_handle "Directory: " . join('/',
+ (PoolBasePath(), PoolDir($source, $section), $source)) . "\n";
+
+ print $tmpfile_handle "Files:\n";
+
+ foreach my $fileref (@files) {
+ print $tmpfile_handle " $fileref->{'MD5Sum'}";
+ print $tmpfile_handle " $fileref->{'Size'}";
+ print $tmpfile_handle " $fileref->{'Filename'}\n";
+ }
+
+ print $tmpfile_handle "\n";
+
+ # All done
+
+ close($tmpfile_handle);
+ return $tmpfile_name;
+}
+
+# Dpkg_Info($file)
+#
+# Runs dpkg --info on $file, and returns a hash of relevant information.
+#
+# Internal support function for Generate_Package.
+
+sub Dpkg_Info {
+ my($file) = @_;
+ my %result;
+
+ # Grab the info from dpkg --info.
+
+ my @info = `/usr/bin/dpkg --info $file`;
+ my $smashed = join('', @info);
+
+ # Look for each of these fields in the info. All are single line values,
+ # so the matching is fairly easy.
+
+ foreach my $field (@Info_Fields, @Relationship_Fields) {
+ if ($smashed =~ m/\n ${field}:\s+(\S.*)\n/) {
+ $result{$field} = $1;
+ }
+ }
+
+ # And, finally, grab the description.
+
+ my $found = 0;
+ foreach my $line (@info) {
+ if ($found) {
+ $line =~ s/^ //;
+ $result{'Description'} .= $line;
+ } elsif ($line =~ m/^ Description: (.+)/) {
+ $result{'Description'} = "$1\n";
+ $found = 1;
+ }
+ }
+
+ return \%result;
+}
+
+# Install_List($archive, $component, $architecture, $listfile, @zfiles)
+#
+# Installs a distribution list file (from Generate_List), along with an
+# optional gzipped version of the same file (if $gzfile is defined).
+# Returns 1 on success, or 0 (and sets $Error) on failure.
+
+sub Install_List {
+ use DebPool::Config qw(:vars);
+ use DebPool::Dirs qw(:functions);
+
+ my($archive, $component, $architecture, $listfile, @zfiles) = @_;
+
+ my $dists_file_mode = $Options{'dists_file_mode'};
+ my $inst_file = "$Options{'dists_dir'}/";
+ $inst_file .= Archfile($archive, $component, $architecture, 0);
+
+ # Now install the file(s) into the appropriate place(s).
+
+ if (!Move_File($listfile, $inst_file, $dists_file_mode)) {
+ $Error = "Couldn't install distribution file '$listfile' ";
+ $Error .= "to '${inst_file}': ${DebPool::Util::Error}";
+ return 0;
+ }
+
+ foreach my $zfile (@zfiles) {
+ my ($ext) = $zfile =~ m{\.([^/]+)$};
+ if (!Move_File($zfile, "${inst_file}.${ext}",
+ $dists_file_mode)) {
+ $Error = "Couldn't install compressed distribution file '$zfile' ";
+ $Error .= "to '${inst_file}.${ext}': ${DebPool::Util::Error}";
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+# Guess_Section($changes_hashref)
+#
+# Attempt to guess the freeness section of a package based on the data
+# for the first file listed in the changes.
+
+sub Guess_Section {
+ # Pull out the primary section from the changes data. Note that this is
+ # a cheap hack, but it is mostly used when needing the pool directory
+ # section, which is based solely on freeness-sections (main, contrib,
+ # non-free).
+
+ my($changes_hashref) = @_;
+
+ my @changes_files = @{$changes_hashref->{'Files'}};
+ return $changes_files[0]->{'Section'};
+}
+
+# Strip_Epoch($version)
+#
+# Strips any epoch data off of the version.
+
+sub Strip_Epoch {
+ my($version) = @_;
+
+ $version =~ s/^[^:]://;
+ return $version;
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Release.pm b/lib/DebPool/Release.pm
new file mode 100644
index 0000000..066e4dc
--- /dev/null
+++ b/lib/DebPool/Release.pm
@@ -0,0 +1,374 @@
+package DebPool::Release;
+
+###
+#
+# DebPool::Release - Module for generating and installing Release files
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Release.pm 27 2004-11-07 03:06:59Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+use POSIX; # strftime
+use File::Temp qw(tempfile);
+
+# We need the Digest modules so that we can calculate the proper checksums.
+
+use Digest::MD5;
+use Digest::SHA;
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Generate_Release_Triple
+ &Install_Release
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Generate_Release_Triple &Install_Release)],
+ 'vars' => [qw()],
+ );
+}
+
+### Exported package globals
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+# Magic filenames - these are files we want to include hashes for in a
+# Release file.
+
+my(@SigFiles) = (
+ 'Packages',
+ 'Sources',
+ 'Packages.gz',
+ 'Sources.gz',
+ 'Packages.bz2',
+ 'Sources.bz2',
+);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Generate_Release_Triple($archive, $component, $architecture, $version)
+#
+# Generate a Release file for a specific dist/component/arch, in the
+# temp/working area, and return the filename.
+#
+# Returns undef (and sets $Error) on error.
+
+sub Generate_Release_Triple {
+ use DebPool::Config qw(:vars);
+ use DebPool::Dirs qw(:functions);
+
+ my($archive, $component, $architecture, $version) = @_;
+
+ my(@Checksums);
+
+ # Before we bother to do much else, generate the MD5 and SHA1 checksums
+ # we'll need later. This is mostly so that we can catch errors before
+ # ever bothering to open a tempfile.
+
+ # First, grab a list of files from the directory.
+
+ my($dirpath) = "${Options{'dists_dir'}}/";
+ $dirpath .= Archfile($archive, $component, $architecture, 1);
+
+ if (!opendir(RELDIR, $dirpath)) {
+ $Error = "Couldn't open directory '$dirpath'.";
+ return;
+ }
+
+ my(@dirfiles) = readdir(RELDIR);
+ close(RELDIR);
+
+ # Now, for each file, generate MD5 and SHA1 checksums, and put them
+ # into Checksums for later use (assuming it's a file we care about).
+
+ foreach my $ck_file (@dirfiles) {
+ if (0 == grep(/^$ck_file$/, @SigFiles)) { # We don't care about it.
+ next;
+ }
+
+ # Grab the filesize from stat()
+
+ my(@stat) = stat("${dirpath}/${ck_file}");
+ my($size) = $stat[7];
+
+ # Open the file and read in the contents. This could be a very
+ # large amount of data, but unfortunately, both Digest routines
+ # require the entire thing at once.
+
+ if (!open($ck_fh, '<', "${dirpath}/${ck_file}")) {
+ $Error = "Couldn't open file '${dirpath}/${ck_file}' for reading.";
+ return;
+ }
+
+ my(@filetext) = <$ck_fh>;
+ close($ck_fh);
+
+ # Now calculate the checksums and put them into the hashes.
+
+ my($md5) = Digest::MD5::md5_hex(@filetext);
+ my($sha1) = Digest::SHA::sha1_hex(@filetext);
+ my($sha256) = Digest::SHA::sha256_hex(@filetext);
+
+ push @Checksums, {
+ 'File' => $ck_file,
+ 'Size' => $size,
+ 'MD5' => $md5,
+ 'SHA1' => $sha1,
+ 'SHA256' => $sha256,
+ };
+ }
+
+ # Open a secure tempfile, and write the headers to it.
+
+ my($tmpfile_handle, $tmpfile_name) = tempfile();
+
+ print $tmpfile_handle "Archive: $archive\n";
+ print $tmpfile_handle "Component: $component\n";
+ print $tmpfile_handle "Version: $version\n";
+ print $tmpfile_handle "Origin: $Options{'release_origin'}\n";
+ print $tmpfile_handle "Label: $Options{'release_label'}\n";
+ print $tmpfile_handle "Architecture: $architecture\n";
+
+ # If the archive (aka distribution) appears in release_noauto, print
+ # the appropriate directive.
+
+ if (0 != grep(/^$archive$/, @{$Options{'release_noauto'}})) {
+ print $tmpfile_handle "NotAutomatic: yes\n";
+ }
+
+ print $tmpfile_handle "Description: $Options{'release_description'}\n";
+
+ # Now print MD5 and SHA1 checksum lists.
+
+ print $tmpfile_handle "MD5Sum:\n";
+ foreach my $checksum (@Checksums) {
+ printf $tmpfile_handle " %s %8d %s\n", $checksum->{'MD5'},
+ $checksum->{'Size'}, $checksum->{'File'};
+ }
+
+ print $tmpfile_handle "SHA1:\n";
+ foreach my $checksum (@Checksums) {
+ printf $tmpfile_handle " %s %8d %s\n", $checksum->{'SHA1'},
+ $checksum->{'Size'}, $checksum->{'File'};
+ }
+
+ print $tmpfile_handle "SHA256:\n";
+ foreach my $checksum (@Checksums) {
+ printf $tmpfile_handle " %s %8d %s\n", $checksum->{'SHA256'},
+ $checksum->{'Size'}, $checksum->{'File'};
+ }
+
+ close($tmpfile_handle);
+
+ return $tmpfile_name;
+}
+
+# Generate_Release_Dist($archive, $version, @files)
+#
+# Generate top-level Release file for a specific distribution, covering the
+# given files, in the temp/working area, and return the filename.
+#
+# Filenames in @files should be relative to <dists_dir>/<archive>, with no
+# leading slash (ie, main/binary-i386/Packages).
+#
+# Returns undef (and sets $Error) on error.
+
+sub Generate_Release_Dist {
+ use DebPool::Config qw(:vars);
+
+ my($archive) = shift(@_);
+ my($version) = shift(@_);
+ my(@files) = @_;
+
+ my(@Checksums);
+ my($dists_dir) = $Options{'dists_dir'};
+
+ # Before we bother to do much else, generate the MD5 and SHA1 checksums
+ # we'll need later. This is mostly so that we can catch errors before
+ # ever bothering to open a tempfile.
+
+ for my $file (@files) {
+ my($fullfile) = "${dists_dir}/${archive}/${file}";
+
+ # Now, for each file, generate MD5 and SHA1 checksums, and put them
+ # into Checksums for later use (assuming it's a file we care about).
+
+ my(@stat) = stat($fullfile);
+ my($size) = $stat[7];
+
+ if (!open($hash_fh, '<', $fullfile)) {
+ $Error = "Couldn't open file '${fullfile} for reading.";
+ return;
+ }
+ my(@filetext) = <$hash_fh>;
+ close($hash_fh);
+
+ # Now calculate the checksums and put them into the hashes.
+
+ my($md5) = Digest::MD5::md5_hex(@filetext);
+ my($sha1) = Digest::SHA::sha1_hex(@filetext);
+ my($sha256) = Digest::SHA::sha256_hex(@filetext);
+
+ push @Checksums, {
+ 'File' => $file,
+ 'Size' => $size,
+ 'MD5' => $md5,
+ 'SHA1' => $sha1,
+ 'SHA256' => $sha256,
+ };
+ }
+
+ # Open a secure tempfile, and set up some variables.
+
+ my($tmpfile_handle, $tmpfile_name) = tempfile();
+
+ my($now_822) = strftime('%a, %d %b %Y %H:%M:%S %Z', localtime());
+ my(@archs) = grep(!/^source$/, @{$Options{'archs'}});
+ my($suite) = $Options{'reverse_dists'}->{$archive};
+
+ # Write the headers into the Release tempfile
+
+ print $tmpfile_handle "Origin: ${Options{'release_origin'}}\n";
+ print $tmpfile_handle "Label: ${Options{'release_label'}}\n";
+ print $tmpfile_handle "Suite: ${suite}\n";
+ print $tmpfile_handle "Codename: ${archive}\n";
+ print $tmpfile_handle "Date: ${now_822}\n";
+ print $tmpfile_handle "Architectures: " . join(' ', @archs) . "\n";
+ print $tmpfile_handle "Components: " . join(' ', @{$Options{'sections'}}) . "\n";
+ print $tmpfile_handle "Description: $Options{'release_description'}\n";
+
+ # Now print MD5 and SHA1 checksum lists.
+
+ print $tmpfile_handle "MD5Sum:\n";
+ foreach my $file (@Checksums) {
+ printf $tmpfile_handle " %s %8d %s\n", $file->{'MD5'},
+ $file->{'Size'}, $file->{'File'};
+ }
+
+ print $tmpfile_handle "SHA1:\n";
+ foreach my $file (@Checksums) {
+ printf $tmpfile_handle " %s %8d %s\n", $file->{'SHA1'},
+ $file->{'Size'}, $file->{'File'};
+ }
+
+ print $tmpfile_handle "SHA256:\n";
+ foreach my $file (@Checksums) {
+ printf $tmpfile_handle " %s %8d %s\n", $file->{'SHA256'},
+ $file->{'Size'}, $file->{'File'};
+ }
+
+ close($tmpfile_handle);
+
+ return $tmpfile_name;
+}
+
+# Install_Release($archive, $component, $architecture, $release, $signature)
+#
+# Installs a release file and an optional signature file to the
+# distribution directory specified by the ($archive, $component,
+# $architecture) triple, or $archive if $component and $architecture are
+# undefined. Returns 0 (and sets $Error) on failure, 1 on
+# success.
+
+sub Install_Release {
+ use DebPool::Config qw(:vars);
+ use DebPool::Util qw(:functions);
+
+ my($archive, $component, $architecture, $release, $signature) = @_;
+
+ my($dists_file_mode) = $Options{'dists_file_mode'};
+
+ my($inst_dir);
+ if (defined($architecture) && defined($component)) {
+ $inst_dir = "${Options{'dists_dir'}}/";
+ $inst_dir .= Archfile($archive, $component, $architecture, 1);
+ } else {
+ $inst_dir = "${Options{'dists_dir'}}/${archive}";
+ }
+
+ # Now install the file(s) into the appropriate place(s).
+
+ if (!Move_File($release, "${inst_dir}/Release", $dists_file_mode)) {
+ $Error = "Couldn't install Release file '${release}' to ";
+ $Error .= "'${inst_dir}': ${DebPool::Util::Error}";
+ return 0;
+ }
+
+ if (defined($signature) && !Move_File($signature, "${inst_dir}/Release.gpg",
+ $dists_file_mode)) {
+ $Error = "Couldn't install Signature file '${signature}' to ";
+ $Error .= "'${inst_dir}': ${DebPool::Util::Error}";
+ return 0;
+ }
+
+ return 1;
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Signal.pm b/lib/DebPool/Signal.pm
new file mode 100644
index 0000000..a8c0fe8
--- /dev/null
+++ b/lib/DebPool/Signal.pm
@@ -0,0 +1,144 @@
+package DebPool::Signal;
+
+###
+#
+# DebPool::DB - Module for handling inter-process signals
+#
+# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Signal.pm 27 2004-11-07 03:06:59Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+# We do logging, so we need this.
+
+use DebPool::Logging qw(:functions :facility :level);
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ $Signal_Caught
+ %ComponentDB
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw()],
+ 'vars' => [qw($Signal_Caught)],
+ );
+}
+
+### Exported package globals
+
+# Boolean value indicating whether we have caught one of the signals that
+# normally trigger clean termination (SIGHUP, SIGINT, SIGPIPE, SIGTERM).
+
+our($Signal_Caught) = 0;
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# None
+
+### Special
+
+# The purpose of this module is to handle signals usefully; therefore, we
+# set up a basic term-signal handler that catches the 'ordinary termination
+# requested' class of signals, and bind it via sigtrap.
+
+sub Handle_SIGtermrequest {
+ my($signal) = shift(@_);
+
+ $Signal_Caught = 1;
+ Log_Message("Caught signal " . $signal, LOG_GENERAL, LOG_INFO);
+}
+
+sub Handle_SIGHUP {
+ Handle_SIGtermrequest('SIGHUP');
+}
+
+use sigtrap qw(handler Handle_SIGHUP HUP);
+
+sub Handle_SIGINT {
+ Handle_SIGtermrequest('SIGINT');
+}
+
+use sigtrap qw(handler Handle_SIGINT INT);
+
+sub Handle_SIGPIPE {
+ Handle_SIGtermrequest('SIGPIPE');
+}
+
+use sigtrap qw(handler Handle_SIGPIPE PIPE);
+
+sub Handle_SIGTERM {
+ Handle_SIGtermrequest('SIGTERM');
+}
+
+use sigtrap qw(handler Handle_SIGTERM TERM);
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Util.pm b/lib/DebPool/Util.pm
new file mode 100644
index 0000000..2f8daa6
--- /dev/null
+++ b/lib/DebPool/Util.pm
@@ -0,0 +1,129 @@
+package DebPool::Util;
+
+###
+#
+# DebPool::Util - Module to contain various utility routines
+#
+# Copyright 2004 Joel Aelwyn. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+# 3. Neither the name of the Author nor the names of any contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+#
+# $Id: Util.pm 27 2004-11-07 03:06:59Z joel $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+use File::Copy;
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Move_File
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Move_File)],
+ 'vars' => [qw()],
+ );
+}
+
+### Exported package globals
+
+# None
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Move_File($orig, $new, $mode)
+#
+# Move an file from $orig to $new by copying, and set the file mode
+# of the new file according to the variables given.
+#
+# Returns 1 if successful, 0 if not (and sets $Error)
+
+sub Move_File {
+ my($orig) = shift(@_);
+ my($new) = shift(@_);
+ my($mode) = shift(@_);
+
+ if (!copy($orig, $new)) {
+ $Error = $!;
+ return 0;
+ }
+
+ if (!chmod($mode, $new)) {
+ $Error = $!;
+ return 0;
+ }
+
+ if (!unlink($orig)) {
+ $Error = $!;
+ return 0;
+ }
+
+ return 1;
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Bzip2.pm b/share/DebPool/Bzip2.pm
deleted file mode 100644
index eab24dc..0000000
--- a/share/DebPool/Bzip2.pm
+++ /dev/null
@@ -1,190 +0,0 @@
-package DebPool::Bzip2;
-
-###
-#
-# DebPool::Bzip2 - Module for handling Bzip2 interactions
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Bzip2.pm 27 2004-11-07 03:06:59Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-use POSIX; # WEXITSTATUS
-
-# Needed for open2()
-
-use Fcntl;
-use IPC::Open2;
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- &Bzip2_File
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Bzip2_File)],
- 'vars' => [qw()],
- );
-}
-
-### Exported package globals
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# Bzip_File($file)
-#
-# Generates a bzipped version of $file, and returns the filename. Returns
-# undef (and sets $Error) on failure.
-
-sub Bzip2_File {
- use DebPool::Logging qw(:functions :facility :level);
-
- my($file) = @_;
-
- # Open a secure tempfile to write the compressed data into
-
- my($tmpfile) = new File::Temp( SUFFIX => '.bz2', UNLINK => 0 );
-
- # Open the source file so that we have it available.
-
- my $source_fh;
- if (!open($source_fh, '<', $file)) {
- $Error = "Couldn't open source file '$file': $!";
- return;
- }
-
- # We are go for main engine start
-
- my(@args) = ('--best', '--force', '--stdout');
-
- my($bzip2_pid) = open2(*BZIP2_IN, *BZIP2_OUT, '/bin/bzip2', @args);
-
- my($child_pid);
- if ($child_pid = fork) { # In the parent
- # Send all the data to Bzip2;
-
- close(BZIP2_IN);
- close($tmpfile);
-
- print BZIP2_OUT <$source_fh>;
- close(BZIP2_OUT);
- close($source_fh);
-
- waitpid($child_pid, 0);
- waitpid($bzip2_pid, 0);
- } else { # In the child - we hope
- if (!defined($child_pid)) {
- die "Couldn't fork: $!\n";
- }
-
- # Read back the results, and print them into the tempfile.
-
- close(BZIP2_OUT);
- close($source_fh);
-
- print $tmpfile <BZIP2_IN>;
- close(BZIP2_IN);
- close($tmpfile);
-
- exit(0);
- }
-
- # And we're done
-
- return $tmpfile->filename;
-}
-
-sub new {
- bless { ERROR => undef };
-}
-
-sub Compress_File {
- my $self = shift;
- my $tempname = Bzip2_File(@_);
- if ($tempname) {
- $self->{'ERROR'} = undef;
- }
- else {
- $self->{'ERROR'} = $Error;
- }
- $tempname;
-}
-
-sub Error {
- my $self = shift;
- $self->{'ERROR'};
-}
-
-sub Name {
- 'bzip2';
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Config.pm b/share/DebPool/Config.pm
deleted file mode 100644
index d323d3a..0000000
--- a/share/DebPool/Config.pm
+++ /dev/null
@@ -1,1058 +0,0 @@
-package DebPool::Config;
-
-###
-#
-# DebPool::Config - Module for handling config options
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Config.pm 38 2005-01-20 21:33:31Z joel $
-#
-###
-
-=head1 NAME
-
-DebPool::Config - configuration file format for debpool
-
-=cut
-
-=head1 SYNOPSIS
-
-package DebPool::Config;
-
-%Options = (
- 'option1' => value1,
- 'option2' => value2,
- ...
-);
-
-1;
-
-=cut
-
-=head1 DESCRIPTION
-
-The DebPool::Config file is normally found in three places;
-F</usr/share/debpool/Config.pm>, F</etc/debpool/Config.pm>, and
-F<$HOME/.debpool/Config.pm> (in ascending order of precedence);
-further locations can also be specified on the command line with the
-'--config=<file>' option, which overrides all of these (and is, in turn,
-overridden by any command line options). Also of note is the --nodefault
-option, which prevents any attempt at loading the default (system and user)
-config files.
-
-The config files in /etc/debpool and $HOME/.debpool are not required to be
-full Perl modules or to even exist. If they are used, they must still
-declare a package namespace of 'DebPool::Config' and return a true value.
-
-=cut
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- %Options
- %OptionDefs
- &Clean_Options
- &Load_Default_Configs
- &Load_Minimal_Configs
- &Load_File_Configs
- &Override_Configs
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Clean_Options &Load_Default_Configs
- &Load_Minimal_Configs &Load_File_Configs
- &Override_Configs)],
- 'vars' => [qw(%Options %OptionDefs)],
- );
-}
-
-### Exported package globals
-
-# The core of everything this package is about.
-
-our(%Options);
-our(%OptionDefs);
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Module Init
-
-# First things first - figure out how we need to be configured.
-
-use Getopt::Long qw(:config pass_through);
-
-# First, grab --config and --nodefault options if they exist. We
-# don't want these in the %Options hash, and they affect what we do when
-# loading it.
-
-my @config_files;
-my $default;
-
-GetOptions('config=s' => \@config_files, 'default!' => \$default);
-
-# Call Load_Default_Configs if we're loading default values, or
-# Load_Minimal_Configs if we're not (we still need the OptionDefs hash to
-# be populated).
-
-if (!defined($default) || $default) {
- Load_Default_Configs();
-} else {
- Load_Minimal_Configs();
-}
-
-# Load any config files we were given.
-
-foreach my $config (@config_files) {
- Load_File_Configs($config);
-}
-
-# And finally, pull in any other command line options.
-
-GetOptions(\%Options, values(%OptionDefs));
-
-# Run the cleanup stuff on %Options.
-
-Clean_Options();
-
-
-### Meaningful functions
-
-# Load_Default_Configs
-#
-# Loads the internal default values into %Options via
-# Load_Internal_Configs, then 'require's config files from the default
-# locations. It would be nice if we could log errors, but we can't safely
-# load the logging module until we have all the configs in place. Catch-22.
-
-sub Load_Default_Configs {
- Load_Internal_Configs();
-
- if (-r '/etc/debpool/Config.pm') {
- do '/etc/debpool/Config.pm'; # System defaults
- }
-
- if (-r "$ENV{'HOME'}/.debpool/Config.pm") {
- do "$ENV{'HOME'}/.debpool/Config.pm"; # User defaults
- }
-}
-
-# Load_Minimal_Configs
-#
-# Loads only the minimum configs necessary to be able to do parsing -
-# that is, populate %OptionDefs. However, for sanity sake in documenting
-# things, this has a side effect of also loading %Options, so we clear it
-# afterwards.
-
-sub Load_Minimal_Configs {
- Load_Internal_Configs();
-
- undef(%Options);
-}
-
-# Load_File_Configs($file)
-#
-# Loads configuration data from $file. We don't check for readability; if
-# the user is insane enough to ask for a non-existant file, just die and
-# tell them that they're stupid. Note: if this routine is called while a
-# lockfile is held, it won't clean that up if we die.
-
-sub Load_File_Configs {
- do "$_[0]";
-}
-
-# Override_Configs($override_hashref)
-#
-# Overrides current values in %Options (whatever those might be) with the
-# values in the hash. Does not destroy unnamed values.
-
-sub Override_Configs {
- my($hashref) = @_;
-
- foreach my $key (keys(%{$hashref})) {
- $Options{$key} = $hashref->{$key};
- }
-}
-
-# Clean_Options()
-#
-# Does some cleanup of $Options for sanity sake; also generates some
-# auto-calculated values.
-
-sub Clean_Options {
- # Clean up the architectures field; 'source' should always be present,
- # 'all' should never be. Simplest way to manage this is a throwaway
- # hash. This should maybe live somewhere else, but I'm not sure where.
-
- my %dummy;
- my @newarch;
-
- foreach my $dummykey (@{$Options{'archs'}}) {
- $dummy{$dummykey} = 1;
- }
-
- $dummy{'all'} = undef;
- $dummy{'source'} = 1;
-
- foreach my $dummykey (keys(%dummy)) {
- if ($dummy{$dummykey}) {
- push(@newarch, $dummykey);
- }
- }
-
- $Options{'archs'} = \@newarch;
-
- # Generate 'realdists' from %Options{'dists'} - these are the 'real'
- # (non-alias) distribution values.
-
- %dummy = ();
-
- foreach my $dummykey (values(%{$Options{'dists'}})) {
- $dummy{$dummykey} = 1;
- }
-
- my @realdists = keys(%dummy);
- $Options{'realdists'} = \@realdists;
-
- # Also generate a reverse-lookup table of real -> alias; in the case
- # of multiple aliases, the first one encountered wins (one of them has
- # to, and making it consistant and first means you can have multiple
- # aliases in a sensible order).
-
- my %reverse = ();
- foreach my $dummykey (keys(%{$Options{'dists'}})) {
- my $real = $Options{'dists'}->{$dummykey};
- if (!defined($reverse{$real})) {
- $reverse{$real} = $dummykey;
- }
- }
-
- $Options{'reverse_dists'} = \%reverse;
-
- # Enable releases if we have all of the pieces.
- if (defined($Options{'release_origin'})
- && defined($Options{'release_label'}) &&
- defined($Options{'release_description'})) { $Options{'do_release'} = 1;
- } else { $Options{'do_release'} = 0; }
-
- # If rebuild-all is present, turn on various rebuild options.
-
- if ($Options{'rebuild-all'}) {
- $Options{'rebuild-files'} = 1;
- $Options{'rebuild-dbs'} = 1;
- }
-}
-
-# Load_Internal_Configs()
-#
-# Loads %Options with basic default values.
-
-sub Load_Internal_Configs {
-=head1 OPTIONS
-
-=head2 File/Directory configuration
-
-These config values determine what directories various parts of the archive
-are put in, and what permissions those directories have, as well as the
-default permissions for files.
-
-NOTE: While debpool will attempt to create db_dir, dists_dir, incoming_dir,
-installed_dir, pool_dir, and reject_dir if they do not exist, it will *not*
-attempt to do this for archive_dir.
-
-WARNING: If you redefine archive_dir and you want the other four entries to
-reflect this by incorporating the new value, you *MUST* redefine them here
-(even if you simply use the default value of 'archive_dir'/<dirname>) so
-that they use the new definition of archive_dir.
-
-=over 4
-
-=item B<archive_dir> => I<archive directory>
-
-Base directory of the archive. This is never used directly; however, it
-is normally used to construct relative paths for dists_dir, incoming_dir,
-installed_dir, pool_dir, and reject_dir.
-
-WARNING: See the section documentation for important details about
-redefining this value.
-
-Default value: '/var/cache/debpool'
-
-=cut
-
-$Options{'archive_dir'} = '/var/cache/debpool';
-$OptionDefs{'archive_dir'} = 'archive_dir=s';
-
-=item B<db_dir> => I<dists directory>
-
-DB directory, where the database files for each distribution are kept.
-
-Default value: "$Options{'archive_dir'}/db"
-
-=cut
-
-$Options{'db_dir'} = "$Options{'archive_dir'}/db";
-$OptionDefs{'db_dir'} = 'db_dir=s';
-
-=item B<db_dir_mode> = I<permissions (octal)>
-
-Permissions for db_dir.
-
-Default value: 0750
-
-=cut
-
-$Options{'db_dir_mode'} = 0750;
-$OptionDefs{'db_dir_mode'} = 'db_dir_mode=i';
-
-=item B<db_file_mode> = I<permissions (octal)>
-
-Permissions for database files in db_dir.
-
-Default value: 0640
-
-=cut
-
-$Options{'db_file_mode'} = 0640;
-$OptionDefs{'db_file_mode'} = 'db_file_mode=i';
-
-=item B<dists_dir> => I<dists directory>
-
-Dists directory, where distribution files (F<{Packages,Sources}{,.gz}> live.
-
-Default value: "$Options{'archive_dir'}/dists"
-
-=cut
-
-$Options{'dists_dir'} = "$Options{'archive_dir'}/dists";
-$OptionDefs{'dists_dir'} = 'dists_dir=s';
-
-=item B<dists_dir_mode> = I<permissions (octal)>
-
-Permissions for dists_dir and all of it's subdirectories.
-
-Default value: 0755
-
-=cut
-
-$Options{'dists_dir_mode'} = 0755;
-$OptionDefs{'dists_dir_mode'} = 'dists_dir_mode=i';
-
-=item B<dists_file_mode> = I<permissions (octal)>
-
-Permissions for distribution files ({Packages,Sources}{,.gz}.
-
-Default value: 0644
-
-=cut
-
-$Options{'dists_file_mode'} = 0644;
-$OptionDefs{'dists_file_mode'} = 'dists_file_mode=i';
-
-=item B<incoming_dir> => I<incoming directory>
-
-Incoming directory, where new packages are uploaded.
-
-Default value: "$Options{'archive_dir'}/incoming";
-
-=cut
-
-$Options{'incoming_dir'} = "$Options{'archive_dir'}/incoming";
-$OptionDefs{'incoming_dir'} = 'incoming_dir=s';
-
-=item B<incoming_dir_mode> = I<permissions (octal)>
-
-Permissions for incoming_dir. Should have the sticky bit set if you want a
-system archive.
-
-Default value: 01775
-
-=cut
-
-$Options{'incoming_dir_mode'} = 01775;
-$OptionDefs{'incoming_dir_mode'} = 'incoming_dir_mode=i';
-
-=item B<installed_dir> => I<installed directory>
-
-Incoming directory, where new packages are uploaded.
-
-Default value: "$Options{'archive_dir'}/installed";
-
-=cut
-
-$Options{'installed_dir'} = "$Options{'archive_dir'}/installed";
-$OptionDefs{'installed_dir'} = 'installed_dir=s';
-
-=item B<installed_dir_mode> = I<permissions (octal)>
-
-Permissions for installed_dir. Should have the sticky bit set if you want a
-system archive.
-
-Default value: 0755
-
-=cut
-
-$Options{'installed_dir_mode'} = 0755;
-$OptionDefs{'installed_dir_mode'} = 'installed_dir_mode=i';
-
-=item B<installed_file_mode> = I<permissions (octal)>
-
-Permissions for installed Changes files.
-
-Default value: 0644
-
-=cut
-
-$Options{'installed_file_mode'} = 0644;
-$OptionDefs{'installed_file_mode'} = 'installed_file_mode=i';
-
-=item B<pool_dir> => I<pool directory>
-
-Pool directory where all .deb files are stored after being accepted. Normally
-this is constructed as a relative path from archive_dir.
-
-Default value: "$Options{'archive_dir'}/pool"
-
-=cut
-
-$Options{'pool_dir'} = "$Options{'archive_dir'}/pool";
-$OptionDefs{'pool_dir'} = 'pool_dir=s';
-
-=item B<pool_dir_mode> = I<permissions (octal)>
-
-Permissions for pool_dir and all of it's subdirectories.
-
-Default value: 0755
-
-=cut
-
-$Options{'pool_dir_mode'} = 0755;
-$OptionDefs{'pool_dir_mode'} = 'pool_dir_mode=i';
-
-=item B<pool_file_mode> = I<permissions (octal)>
-
-Permissions for files installed into the pool area (orig.tar.gz, tar.gz,
-diff.gz, dsc, deb).
-
-Default value: 0644
-
-=cut
-
-$Options{'pool_file_mode'} = 0644;
-$OptionDefs{'pool_file_mode'} = 'pool_file_mode=i';
-
-=item B<reject_dir> => I<reject directory>
-
-Reject directory, where rejected packages are placed.
-
-Default value: "$Options{'archive_dir'}/reject"
-
-=cut
-
-$Options{'reject_dir'} = "$Options{'archive_dir'}/reject";
-$OptionDefs{'reject_dir'} = 'reject_dir=s';
-
-=item B<reject_dir_mode> = I<permissions (octal)>
-
-Permissions for reject_dir.
-
-Default value: 0750
-
-=cut
-
-$Options{'reject_dir_mode'} = 0750;
-$OptionDefs{'reject_dir_mode'} = 'reject_dir_mode=i';
-
-=item B<reject_file_mode> = I<permissions (octal)>
-
-Permissions for rejected package files.
-
-Default value: 0640
-
-=cut
-
-$Options{'reject_file_mode'} = 0640;
-$OptionDefs{'reject_file_mode'} = 'reject_file_mode=i';
-
-=item B<lock_file> => I<lockfile>
-
-Location of the lockfile to use when running.
-
-Default value: "$Options{'archive_dir'}/.lock"
-
-=cut
-
-$Options{'lock_file'} = "$Options{'archive_dir'}/.lock";
-$OptionDefs{'lock_file'} = 'lock_file=s';
-
-=item B<get_lock_path> => I<boolean>
-
-Display the full path set for the lock file and exit. This is mainly used
-to determine the path set for the lock file from a system's or user's
-default configuration.
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'get_lock_path'} = 0;
-$OptionDefs{'get_lock_path'} = 'get_lock_path!';
-
-=back
-
-=cut
-
-=head2 Compression configuration
-
-These values control what formats will be used to compress the
-distribution files (Packages, Sources).
-
-=over 4
-
-=item B<compress_dists> = I<boolean>
-
-This determines whether or not compressed versions of the distribution
-files (Packages.gz, Sources.gz) are generated in gzip.
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'compress_dists'} = 0;
-$OptionDefs{'compress_dists'} = 'compress_dists!';
-
-=item B<bzcompress_dists> = I<boolean>
-
-This determines whether or not compressed versions of the distribution
-files (Packages.gz, Sources.gz) are generated in bzip2.
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'bzcompress_dists'} = 0;
-$OptionDefs{'bzcompress_dists'} = 'bzcompress_dists!';
-
-=back
-
-=cut
-
-=head2 Archive configuration
-
-These values control which distributions, components, and architectures the
-archive will support.
-
-=over 4
-
-=item B<dists> => I<hash of distribution names and codenames>
-
-A hashref pointing to a hash with entries for all distributions we will
-accept packages for, and what the current codename for each distribution
-is. Note that it is acceptable for more than one distribution to point to a
-given codename (for example, when frozen is active); however, this has some
-strange (and non-deterministic) consequences for Release files.
-
-Default value:
-
-{ 'stable' => 'etch',
-'testing' => 'lenny',
-'unstable' => 'sid',
-'experimental' => 'experimental' }
-
-=cut
-
-$Options{'dists'} = {
- 'stable' => 'etch',
- 'testing' => 'lenny',
- 'unstable' => 'sid',
- 'experimental' => 'experimental'
- };
-$OptionDefs{'dists'} = 'dists=s%';
-
-=item B<virtual_dists> => I<hash of virtual distribution names and targets>
-
-A hashref pointing to a hash with entries for all 'virtual' distributions
-we will accept packages for, and what distribution it should be treated
-as. It is acceptable for more than one virtual distribution to point to a
-given target. Note that unlike 'dists' entries, symlinks pointing from the
-virtual name to the real name will not be created, and no attempt is made
-to use these names in reverse processes (such as Release files); however,
-virtual distributions may target any name ("unstable") or codename ("sid")
-which appears in the 'dists' hash.
-
-Default value:
-
-{}
-
-Example value:
-
-{ 'unstable-hostname' => 'unstable',
- 'testing-hostname' => 'lenny', }
-
-=cut
-
-$Options{'virtual_dists'} = {};
-$OptionDefs{'virtual_dists'} = 'virtual_dists=s%';
-
-=item B<sections> => I<array of section names>
-
-An arrayref pointing to an array which lists all sections we will accept
-packages for.
-
-Default value: [ 'main', 'contrib', 'non-free', 'debian-installer' ]
-
-=cut
-
-$Options{'sections'} = [ 'main', 'contrib', 'non-free', 'debian-installer' ];
-$OptionDefs{'sections'} = 'sections=s@';
-
-=item B<archs> => I<array of architecture names>
-
-An arrayref pointing to an array which lists all architectures we will
-accept packages for. Note that 'source' will always be present, and 'all'
-will be silently ignored (uploads for Arch: all will still work, but the
-listings appear in arch-specific Packages files).
-
-Default value: [ 'i386' ]
-
-=back
-
-=cut
-
-$Options{'archs'} = [ 'i386' ];
-$OptionDefs{'archs'} = 'archs=s@';
-
-=head2 Release configuration
-
-If the variables 'release_origin', 'release_label', and
-'release_description' are defined, Release files will be generated
-for each distribution directory.
-
-Please note that enabling Release files will introduce a dependancy on the
-package 'libdigest-sha-perl'.
-
-See also: sign_release
-
-=over 4
-
-=cut
-
-=item B<release_origin> => I<origin tag>
-
-A string to be used for the Origin tag in the Release file.
-
-Default value: undef
-
-=cut
-
-$Options{'release_origin'} = undef;
-$OptionDefs{'release_origin'} = 'release_origin=s';
-
-=item B<release_label> => I<label tag>
-
-A string to be used for the Label tag in the Release file.
-
-Default value: undef
-
-=cut
-
-$Options{'release_label'} = undef;
-$OptionDefs{'release_label'} = 'release_label=s';
-
-=item B<release_description> => I<description tag>
-
-A string to be used for the Description tag in the Release file. (Note that
-this should be a single line.)
-
-Default value: undef
-
-=cut
-
-$Options{'release_description'} = undef;
-$OptionDefs{'release_description'} = 'release_description=s';
-
-=item B<release_noauto> = <array of NonAutomatic release names>
-
-An array of release names which should be tagged with 'NonAutomatic: yes'
-in their Release files. This tag will keep APT from ever automatically
-selecting a package from that archive as an installation candidate.
-
-Default value: [ 'experimental' ]
-
-=cut
-
-$Options{'release_noauto'} = [ 'experimental' ];
-$OptionDefs{'release_noauto'} = 'release_noauto=s@';
-
-=back
-
-=cut
-
-=head2 Signature configuration
-
-Please note that enabling any of these options will cause a dependancy on
-the 'gnupg' package. See F</usr/share/doc/debpool/README.GnuPG> for more
-information.
-
-=over 4
-
-=item B<require_sigs_debs> = I<boolean>
-
-If true, packages will be rejected unless their package files (.deb)
-are GPG-signed with a recognized key found one of the keyrings listed
-in 'gpg_keyrings'. These can be signed with the tools in the 'debsigs'
-package.
-
-Note that this option currently does nothing. It may be
-implemented in a future version of debpool. However, it's also possible
-that this option will be removed entirely as there seems to be
-little support for signed .deb files in Debian.
-
-Default value: 0 (false)
-
-See also: gpg_keyrings
-
-=cut
-
-$Options{'require_sigs_debs'} = 0;
-$OptionDefs{'require_sigs_debs'} = 'require_sigs_debs!';
-
-=item B<require_sigs_meta> = I<boolean>
-
-If true, packages will be rejected unless their meta-files (.changes and
-.dsc) are GPG-signed with a recognized key found one of the keyrings listed
-in 'gpg_keyrings'. These are the files normally signed by the 'debsign'
-utility in devscripts package.
-
-Default value: 0 (false)
-
-See also: gpg_keyrings
-
-=cut
-
-$Options{'require_sigs_meta'} = 0;
-$OptionDefs{'require_sigs_meta'} = 'require_sigs_meta!';
-
-=item B<sign_release> = I<boolean>
-
-If true, generated Release files will be GPG-signed with the key specified
-in 'gpg_sign_key'.
-
-Note that this will have no effect unless 'gpg_sign_key' is also defined at
-some point.
-
-Default value: 0 (false)
-
-See also: L<"Release configuration">, gpg_sign_key
-
-=cut
-
-$Options{'sign_release'} = 0;
-$OptionDefs{'sign_release'} = 'sign_release!';
-
-=back
-
-=cut
-
-=head2 GnuPG configuration
-
-These values will only be used if the use of GnuPG is triggered in some
-fashion (such as any of the values in L<"Signature configuration"> being
-enabled) , and thus do not (in themselves) trigger a dependancy on GnuPG.
-Please see F</usr/share/doc/debpool/README.GnuPG> for more information.
-
-=over 4
-
-=item B<gpg_bin> = I<GnuPG binary>
-
-This is used to specify the GnuPG binary to run.
-
-Default value: '/usr/bin/gpg'
-
-=cut
-
-$Options{'gpg_bin'} = '/usr/bin/gpg';
-$OptionDefs{'gpg_bin'} = 'gpg_bin=s';
-
-=item B<gpg_home> = I<GnuPG homedir>
-
-This is used to specify the GnuPG homedir (via the --homedir option).
-
-Default value: $ENV{'HOME'}.'/.gnupg'
-
-=cut
-
-$Options{'gpg_home'} = $ENV{'HOME'}.'/.gnupg';
-$OptionDefs{'gpg_home'} = 'gpg_home=s';
-
-=item B<gpg_keyrings> = I<array of keyring filenames>
-
-An arrayref pointing to an array which lists all of the GPG keyrings that
-hold keys for approved uploaders. Note that this will have no effect unless
-at least one of 'require_sigs_debs' or 'require_sigs_meta' is enabled.
-
-Default value: [ 'uploaders.gpg' ]
-
-See also: require_sigs_debs, require_sigs_meta
-
-=cut
-
-$Options{'gpg_keyrings'} = [ 'uploaders.gpg' ];
-$OptionDefs{'gpg_keyrings'} = 'gpg_keyrings=s@';
-
-=item B<gpg_sign_key> = I<signature keyID>
-
-A string which contains the ID of the key which we will sign Release files
-with. Note that this will have no effect unless 'sign_release' is true.
-
-Default value: undef
-
-See also: sign_release
-
-=cut
-
-$Options{'gpg_sign_key'} = undef;
-$OptionDefs{'gpg_sign_key'} = 'gpg_sign_key=s';
-
-=item B<gpg_passfile> = I<passphrase file>
-
-This specifies the name of the file from which we read the GnuPG passphrase
-for the key listed in gpg_sign_key. Note that it will have no effect unless
-'sign_release' is true and 'gpg_sign_key' is defined.
-
-Default value: $ENV{'HOME'}.'/.gnupg/passphrase';
-
-See also: sign_release, gpg_sign_key
-
-=cut
-
-$Options{'gpg_passfile'} = $ENV{'HOME'}.'/.gnupg/passphrase';
-$OptionDefs{'gpg_passfile'} = 'gpg_passfile=s';
-
-=back
-
-=head2 Logging configuration
-
-These are values which control the logging system.
-
-=over 4
-
-=item B<log_file> = I<filename>
-
-If this option is defined, logging output will be sent to the filename
-specified. Note that an undefined value is considered an explicit request
-to log nothing.
-
-Default value: $ENV{'HOME'}.'/.debpool/debpool.log';
-
-=cut
-
-$Options{'log_file'} = $ENV{'HOME'}.'/.debpool/debpool.log';
-$OptionDefs{'log_file'} = 'log_file=s';
-
-=head2 Misc. configuration
-
-These are values which don't particularly fit into any of the other
-sections.
-
-=over 4
-
-=item B<daemon> = I<boolean>
-
-This determines whether debpool runs as a daemon (never exiting except on
-fatal errors, rescanning the Incoming directory periodically), or on a
-single-run basis. True values cause debpool to run as a daemon.
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'daemon'} = 0;
-$OptionDefs{'daemon'} = 'daemon!';
-
-=item B<sleep> = I<delay>
-
-This option determines how long the daemon sleeps for, between each
-processing run. Note that signals (such as SIGHUP, SIGINT, or SIGTERM)
-will force the daemon to wake up before this expires, so don't worry about
-setting it too long.
-
-Default value: 300 (5 minutes)
-
-=cut
-
-$Options{'sleep'} = 300;
-$OptionDefs{'sleep'} = 'sleep=i';
-
-=item B<use_inotify> = I<boolean>
-
-Sets whether debpool should use inotify to monitor for incoming changes.
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'use_inotify'} = 0;
-$OptionDefs{'use_inotify'} = 'use_inotify!';
-
-=item B<rollback> = I<boolean>
-
-This determines whether older packages in the incoming queue are allowed
-to replace newer versions already in the archive (roll back the archive
-version).
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'rollback'} = 0;
-$OptionDefs{'rollback'} = 'rollback!';
-
-=item B<rebuild-files> = I<boolean>
-
-This option can be set in configfiles, but is more commonly used from the
-commandline; if set, it forces all of the distribution files (Packages and
-Sources) to be rebuilt, whether or not they need it. This should almost
-never be used in conjunction with the daemon option.
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'rebuild-files'} = 0;
-$OptionDefs{'rebuild-files'} = 'rebuild-files!';
-
-=item B<rebuild-dbs> = I<boolean>
-
-This option should not be set in configfiles, only used from the
-commandline; if set, it forces all of the metadata files to be rebuilt from
-scratch. This should almost never be used in conjunction with the daemon
-option.
-
-WARNING: This feature is not yet implemented, and will (silently) fail to
-do anything, at this time. It will be implemented in a future version.
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'rebuild-dbs'} = 0;
-$OptionDefs{'rebuild-dbs'} = 'rebuild-dbs!';
-
-=item B<rebuild-all> = I<boolean>
-
-This option should not be set in configfiles, only used from the
-commandline; if set, it is equivalent to turning on all other rebuild
-options (currently --rebuild-files and --rebuild-dbs).
-
-WARNING: This feature depends on rebuild-dbs, which is not yet implemented;
-only the --rebuild-files section will be triggered.
-
-Default value: 0 (false)
-
-=cut
-
-$Options{'rebuild-all'} = 0;
-$OptionDefs{'rebuild-all'} = 'rebuild-all!';
-
-=item B<config> = I<configfile>
-
-This is a special option that should not be put into configfiles; it is
-intended only for command-line use. It may be issued multiple times; each
-time it is used, it will add the named config file to the list which
-DebPool will load (later config files override earlier ones, in case of any
-conflicts).
-
-Default value: N/A
-
-=back
-
-=cut
-}
-
-END {}
-
-1;
-
-__END__
-
-=head1 CAVEATS
-
-Command line options will override all Config.pm declarations.
-
-=cut
-
-=head1 SEE ALSO
-
-L<debpool(1)>
-
-=cut
-
-=head1 AUTHOR
-
-Joel Baker <fenton at debian.org>
-
-This manpage is autogenerated from F<share/DebPool/Config.pm> of the
-source package during build time using pod2man.
-
-=cut
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/DB.pm b/share/DebPool/DB.pm
deleted file mode 100644
index 1e7fdba..0000000
--- a/share/DebPool/DB.pm
+++ /dev/null
@@ -1,276 +0,0 @@
-package DebPool::DB;
-
-###
-#
-# DebPool::DB - Module for managing data hashes via tied NDBM files
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: DB.pm 62 2005-02-23 18:02:38Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-# This module mostly wraps calls to tied NDBM hashes, so we need these.
-
-use Fcntl;
-use NDBM_File;
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- %ComponentDB
- &Open_Databases
- &Close_Databases
- &Get_Version
- &Get_Archs
- &Set_Versions
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Open_Databases &Close_Databases &Get_Version
- &Get_Archs &Set_Versions)],
- 'vars' => [qw(%ComponentDB)],
- );
-}
-
-### Exported package globals
-
-# I'd love to be able to do this as a hash of hashes of hashrefs, but the
-# database layer can't handle it. So we have multiple DBs.
-
-# VersionDB - hash of tied hashes, keyed on Distribution (then Source
-# package). Keeps track of all versions. Prior to 0.2.2, the value pointed
-# to was a scalar representing the version of the source package; as of
-# 0.2.2 and later, updated records are hashrefs pointing to hashes that
-# have package -> version mappings, with 'source' being the key for source
-# package version.
-
-our(%VersionDB);
-
-# ComponentDB - hash of tied hashes, keyed on Distribution (then Source
-# package). Stores the component data for the given package.
-
-our(%ComponentDB);
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# Open_Databases()
-#
-# Open all tied NDBM hashes for each real distribution. Returns 0 in the
-# case of errors opening hashes, 1 otherwise.
-
-sub Open_Databases {
- use DebPool::Config qw(:vars);
-
- my($db_dir) = $Options{'db_dir'};
- my($db_file_mode) = $Options{'db_file_mode'};
-
- foreach my $dist (@{$Options{'realdists'}}) {
- my(%tiedhash);
- my($tie_result) = tie(%tiedhash, 'NDBM_File',
- "$db_dir/${dist}_version",
- O_RDWR|O_CREAT, $db_file_mode);
- if (!defined($tie_result)) {
- return 0;
- };
-
- $VersionDB{$dist} = \%tiedhash;
- }
-
- foreach my $dist (@{$Options{'realdists'}}) {
- my(%tiedhash);
- my($tie_result) = tie(%tiedhash, 'NDBM_File',
- "$db_dir/${dist}_component",
- O_RDWR|O_CREAT, $db_file_mode);
- if (!defined($tie_result)) {
- return 0;
- };
-
- $ComponentDB{$dist} = \%tiedhash;
- }
-
- return 1;
-}
-
-# Close_Databases()
-#
-# Closes all tied NDBM hashes.
-#
-# NOTE: Untie doesn't return anything (?), so we can't really trap errors.
-
-sub Close_Databases {
- foreach my $dist (keys(%VersionDB)) {
- untie(%{$VersionDB{$dist}});
- }
-
- foreach my $dist (keys(%ComponentDB)) {
- untie(%{$ComponentDB{$dist}});
- }
-
- return 1;
-}
-
-# Get_Version($dist, $source, $package)
-#
-# Retrieves the version of $package (from source package $source) in
-# distribution $dist. The package name 'source' retrieves the source
-# package name, or undef if no information is available.
-
-sub Get_Version {
- my($dist, $source, $package) = @_;
-
- return unless defined $VersionDB{$dist}{$source};
- my($version, $binlist, $archlist) = split(/\|/, $VersionDB{$dist}{$source});
-
- # Versions prior to 0.2.2 had only one entry, which is the source
- # version; since this is the same as the binary version on the vast
- # majority of packages, fake an answer. This works because hash entries
- # are guaranteed to be non-empty.
-
- if (!defined $binlist) {
- return $version;
- }
-
- if ('meta' eq $package) {
- return $version;
- } elsif ('source' eq $package) {
- return $VersionDB{$dist}{"source_${source}"};
- } else {
- return $VersionDB{$dist}{"binary_${source}_${package}"};
- }
-}
-
-sub Get_Archs {
- my($dist, $source) = @_;
-
- return unless defined $VersionDB{$dist}{$source};
- my($version, $binlist, $archlist) = split(/\|/, $VersionDB{$dist}{$source});
- return split /,/, $archlist if defined $archlist;
- return @{$Options{'archs'}};
-}
-
-# Set_Versions($dist, $source, $file_arrayref)
-
-sub Set_Versions {
- my($dist, $source, $meta_version, $file_arrayref) = @_;
- my (%entries, %archs);
- my($oldversion, $oldbinlist, $archlist);
- ($oldversion, $oldbinlist, $archlist) =
- split(/\|/, $VersionDB{$dist}{$source}) if defined $VersionDB{$dist}{$source};
-
- if (defined($oldbinlist)) {
- my(@oldbins) = split(/,/,$oldbinlist);
- if ($oldversion ne $meta_version) {
- # 0.2.2 or later
- foreach my $oldbin (@oldbins) {
- delete $VersionDB{$dist}{"binary_${source}_${oldbin}"};
- }
- delete $VersionDB{$dist}{"source_${source}"};
- delete $VersionDB{$dist}{"${source}"};
- }
- else {
- $entries{$_} = 1 foreach @oldbins;
- if (defined $archlist) {
- $archs{$_} = 1 foreach split /,/, $archlist;
- }
- }
- }
-
- # Walk through each file looking for version data. Note that only the
- # .dsc file is guaranteed to be the same for source uploads (it can be
- # orig.tar.gz or tar.gz, and diff.gz need not exist), and .deb files
- # have binary versions, so that's all we look for.
- #
- # FIXME: Do udeb files have different versions from deb files?
-
- my(@files) = @{$file_arrayref};
-
- foreach my $hashref (@files) {
- my($filename) = $hashref->{'Filename'};
-
- if ($filename =~ m/^([^_]+)_([^_]+)_(.+)\.u?deb/) {
- my($package, $version, $arch) = ($1, $2, $3);
-
- $VersionDB{$dist}->{"binary_${source}_${package}"} = $version;
- $entries{$package} = 1;
- $archs{$arch} = 1;
- } elsif ($filename =~ m/^[^_]+_([^_]+)\.dsc/) {
- my($version) = $1;
-
- $VersionDB{$dist}->{"source_${source}"} = $version;
- $archs{source} = 1;
- } # else skip
- }
-
- $VersionDB{$dist}{$source} = join('|', ${meta_version},
- join(',', keys %entries),
- join(',', keys %archs));
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Dirs.pm b/share/DebPool/Dirs.pm
deleted file mode 100644
index 05ce56d..0000000
--- a/share/DebPool/Dirs.pm
+++ /dev/null
@@ -1,506 +0,0 @@
-package DebPool::Dirs;
-
-###
-#
-# DebPool::Dirs - Module for dealing with directory related tasks
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Dirs.pm 71 2006-06-26 21:16:01Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- &Archfile
- &Create_Tree
- &Tree_Mkdir
- &Setup_Incoming_Watch
- &Monitor_Incoming
- &PoolBasePath
- &PoolDir
- &Scan_Changes
- &Scan_All
- &Strip_Subsection
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Archfile &Create_Tree &Tree_Mkdir
- &Monitor_Incoming &Setup_Incoming_Watch
- &PoolBasePath &PoolDir &Scan_Changes &Scan_All
- &Strip_Subsection)],
- 'vars' => [qw()],
- );
-}
-
-### Exported package globals
-
-# None
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-my($inotify);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# Create_Tree()
-#
-# Creates a full directory tree based on the current directory values in
-# %DebPool::Config::Options. Returns 1 on success, 0 on failure (and sets
-# or propagates $Error).
-
-sub Create_Tree {
- use DebPool::Config qw(:vars);
-
- # Basic directories - none of these are terribly exciting. We don't set
- # $Error on failure, because Tree_Mkdir will have already done so.
-
- if (!Tree_Mkdir($Options{'db_dir'}, $Options{'db_dir_mode'})) {
- return 0;
- }
-
- if (!Tree_Mkdir($Options{'incoming_dir'}, $Options{'incoming_dir_mode'})) {
- return 0;
- }
-
- if (!Tree_Mkdir($Options{'installed_dir'}, $Options{'installed_dir_mode'})) {
- return 0;
- }
-
- if (!Tree_Mkdir($Options{'reject_dir'}, $Options{'reject_dir_mode'})) {
- return 0;
- }
-
- # Now the distribution directory and subdirectories
-
- my($dists_dir) = $Options{'dists_dir'};
- my($dists_dir_mode) = $Options{'dists_dir_mode'};
-
- if (!Tree_Mkdir($dists_dir, $dists_dir_mode)) {
- return 0;
- }
-
- # Real distributions are the only ones that get directories.
-
- foreach my $dist (@{$Options{'realdists'}}) {
- if (!Tree_Mkdir("$dists_dir/$dist", $dists_dir_mode)) {
- return 0;
- }
-
- foreach my $section (@{$Options{'sections'}}) {
- if (!Tree_Mkdir("$dists_dir/$dist/$section", $dists_dir_mode)) {
- return 0;
- }
-
- foreach my $arch (@{$Options{'archs'}}) {
- my($target) = "$dists_dir/$dist/$section/";
- if ('source' eq $arch) {
- $target .= $arch;
- } else {
- $target .= "binary-$arch";
- }
-
- if (!Tree_Mkdir($target, $dists_dir_mode)) {
- return 0;
- }
- }
- }
- }
-
- # Go through all of the distributions looking for those that should be
- # symlinks, and creating them if necessary.
-
- foreach my $dist (keys(%{$Options{'dists'}})) {
- # Check whether it should be a symlink. If so, make sure it is.
-
- if (!($dist eq $Options{'dists'}->{$dist})) { # Different names -> sym
- if (! -e "$dists_dir/$dist") {
- if (!symlink($Options{'dists'}->{$dist}, "$dists_dir/$dist")) {
- $Error = "Couldn't create symlink $dists_dir/$dist -> ";
- $Error .= "$Options{'dists'}->{$dist}: $!";
- }
- } elsif (! -l "$dists_dir/$dist") {
- $Error = "$dists_dir/$dist exists and isn't a symlink, ";
- $Error .= "but it should be";
- return 0;
- }
- }
- }
-
- # And, finally, the pool directories and their subdirectories
-
- my($pool_dir) = $Options{'pool_dir'};
- my($pool_dir_mode) = $Options{'pool_dir_mode'};
-
-
- if (!Tree_Mkdir($pool_dir, $pool_dir_mode)) {
- return 0;
- }
-
- # We can only get away with this because Debian pool directories are
- # named in ASCII...
-
- foreach my $section (@{$Options{'sections'}}) {
- next if $section =~ m/\s*\/debian-installer/;
- if (!Tree_Mkdir("$pool_dir/$section", $pool_dir_mode)) {
- return 0;
- }
- }
-
- return 1;
-}
-
-# Tree_Mkdir($directory, $mode)
-#
-# Creates $directory with $mode. Returns 0 and sets $Error on failure, or
-# 1 on success.
-
-sub Tree_Mkdir {
- my($dir, $mode) = @_;
-
- if (-d $dir) {
- return 1;
- };
-
- if (-e $dir) {
- $Error = "Couldn't create '$dir' - already exists as a non-directory.";
- return 0;
- }
-
- if (!mkdir($dir, $mode)) {
- $Error = "Couldn't create '$dir': $!";
- return 0;
- }
-
- if (!chmod($mode, $dir)) {
- $Error = "Couldn't chmod '$dir': $!";
- return 0;
- }
-
- return 1;
-}
-
-# Scan_Changes($directory)
-#
-# Scan the specified directory for changes files. Returns an array of
-# filenames relative to the directory, or undef (and sets $Error) on an error.
-
-sub Scan_Changes {
- my($directory) = @_;
-
- if (!opendir(INCOMING, $directory)) {
- $Error = "Couldn't open directory '$directory': $!";
- return;
- }
-
- # Perl magic - read the directory and grep it for *.changes all at one
- # shot.
-
- my(@changes) = grep(/\.changes$/, readdir(INCOMING));
- close(INCOMING);
-
- return @changes;
-}
-
-# Scan_All($directory)
-#
-# Scans the specified directory and all subdirectories for any files.
-# Returns an arrayref pointing to an array of filepaths relative to
-# $directory, or undef (and sets $Error) on failure. Ignores any hidden
-# files or directories.
-
-sub Scan_All {
- my($directory) = @_;
-
- if (!opendir(DIR, $directory)) {
- $Error = "Couldn't open directory '$directory'";
- return;
- }
-
-
- my(@entries) = grep(!/^\./, readdir(DIR));
-
- my(@return);
-
- foreach my $direntry (@entries) {
- if (-f "$directory/$direntry") {
- push(@return, $direntry);
- } elsif (-d "$directory/$direntry") {
- my($recurse) = Scan_All("$directory/$direntry");
-
- if (!defined($recurse)) { # $Error is already set.
- return;
- }
-
- # I'd like to use map(), but Perl makes stooopid guesses.
-
- foreach my $entry (@{$recurse}) {
- push(@return, "$direntry/$entry");
- }
- }
- }
-
- return \@return;
-}
-
-# Setup_Incoming_Watch()
-#
-# Creates a Linux::Inotify2 object and adds a watch on the incoming directory.
-# Returns 1 on success, 0 on failure (and sets $Error).
-
-sub Setup_Incoming_Watch {
- use DebPool::Logging qw(:functions :facility :level);
- use DebPool::Config;
- if (!eval{ require Linux::Inotify2; }) {
- Log_Message("liblinux-inotify2-perl is required to activate inotify support for debpool.", LOG_GENERAL, LOG_WARNING);
- return 0;
- } else {
- use Linux::Inotify2;
- }
-
- $inotify = new Linux::Inotify2;
- if (!$inotify) {
- $Error = "Unable to create new inotify object: $!";
- Log_Message("$Error", LOG_GENERAL, LOG_ERROR);
- return 0;
- }
- if (!$inotify->watch("$Options{'incoming_dir'}",
- IN_CLOSE_WRITE |
- IN_MOVED_TO )) {
- $Error = "Unable to watch $Options{'incoming_dir'}: $!";
- Log_Message("$Error", LOG_GENERAL, LOG_ERROR);
- return 0;
- }
- Log_Message("Watching $Options{'incoming_dir'} with Inotify",
- LOG_GENERAL, LOG_DEBUG);
- return 1;
-}
-
-# Watch_Incoming()
-#
-# Reads events from the Inotify2 object (blocking until one occurs),
-# picks out the .changes file(s) and returns them (if any; otherwise
-# it loops).
-#
-# Returns a list of .changes files on success, undef on failure (which
-# includes interruption by a signal).
-
-sub Watch_Incoming {
- use DebPool::Logging qw(:functions :facility :level);
-
- while (my @events = $inotify->read) {
- my @changes;
- foreach (@events) {
- push @changes, $_->name if ($_->name =~ /\.changes$/);
- }
- if (@changes > 0) {
- Log_Message("Found changes: ".join(', ', @changes),
- LOG_GENERAL, LOG_DEBUG);
- return @changes;
- }
- }
- return;
-}
-
-# Monitor_Incoming()
-#
-# Monitors the incoming directory, looping until the directory is updated.
-# Returns a list of .changes files on success, undef on failure (which
-# includes interruption by a signal - check $DebPool::Signal::Signal_Caught).
-
-sub Monitor_Incoming {
- use DebPool::Config;
- use DebPool::Logging qw(:functions :facility :level);
-
- # If this is ever false, we either shouldn't have been called in the
- # first place, or we've caught a signal and shouldn't do anything
- # further.
-
- if ($DebPool::Signal::Signal_Caught) {
- return;
- }
-
- if ($Options{'use_inotify'}) {
- return Watch_Incoming();
- } else {
- my(@stat) = stat($Options{'incoming_dir'});
- my($mtime) = $stat[9];
-
- do {
- Log_Message("Incoming monitor: sleeping for " .
- $Options{'sleep'} . " seconds", LOG_GENERAL, LOG_DEBUG);
- sleep($Options{'sleep'});
- @stat = stat($Options{'incoming_dir'});
- if (!@stat) {
- $Error = "Couldn't stat incoming_dir '$Options{'incoming_dir'}'";
- return;
- }
- return if $DebPool::Signal::Signal_Caught;
- } until ($stat[9] != $mtime);
-
- return Scan_Changes();
- }
-}
-
-# PoolDir($name, $section, $archive_base)
-#
-# Calculates a pool subdirectory name from the package name and the section
-# (if provided; assumed to be 'main' if undefined or unrecognized).
-
-sub PoolDir {
- my($name, $section, $archive_base) = @_;
-
- $section = Strip_Subsection($section);
-
- # Pool subdirectories are normally the first letter of the package
- # name, unless it is a lib* package, in which case the subdir is
- # lib<first letter>.
-
- if ($name =~ s/^lib//) { # lib(.).*
- return $section . '/' . 'lib' . substr($name, 0, 1);
- } else { # (.).*
- return $section . '/' . substr($name, 0, 1);
- }
-}
-
-# Strip_Subsection($section)
-#
-# This routine could, perhaps, better named. However, the purpose is to
-# take a Section header as found in a package, and return the 'section'
-# (rather than [section/]subsection) of it - that is, 'main', 'contrib', or
-# 'non-free' (normally; it uses the configuration options to track this).
-#
-# Any unrecognized section is assumed to be 'main'; section values without
-# *any* subsection portion succeed, as well (at least, assuming that they
-# are otherwise valid).
-
-sub Strip_Subsection {
- use DebPool::Config qw(:vars);
-
- my($section) = @_;
-
- if (!defined($section)) {
- return 'main';
- }
-
- foreach my $check_section (@{$Options{'sections'}}) {
- if ($section =~ m/^$check_section(\/.+)?$/) {
- return $check_section;
- }
- }
-
- return 'main';
-}
-
-# PoolBasePath()
-#
-# Calculates the value of the relative path from archive_dir to pool_dir
-# (this is primarily useful when having to provide file paths relative to
-# archive_dir, such as in Packages/Sources files). This does assume that
-# pool_dir is a subdirectory of archive_dir, but if that isn't true then
-# things are royally screwed up *anyway*...
-
-sub PoolBasePath {
- use DebPool::Config qw(:vars);
-
- my($path) = $Options{'pool_dir'};
- $path =~ s/^$Options{'archive_dir'}\///;
- return $path;
-}
-
-# Archfile($archive, $component, $architecture, $dironly)
-#
-# Returns the file name for the Packages/Sources file, or the directory
-# name of the arch directory if $dironly is true, (from a base of
-# dists_dir) for the specified archive, component, and architecture.
-
-sub Archfile {
- my($archive) = shift(@_);
- my($component) = shift(@_);
- my($architecture) = shift(@_);
- my($dironly) = shift(@_);
-
- my($result) = "$archive/$component";
-
- my($type);
- if ('source' eq $architecture) {
- $result .= "/${architecture}";
- $type = "Sources";
- } else {
- $result .= "/binary-${architecture}";
- $type = "Packages";
- }
-
- if (!$dironly) {
- $result .= "/${type}";
- }
-
- return $result;
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/GnuPG.pm b/share/DebPool/GnuPG.pm
deleted file mode 100644
index eb8562c..0000000
--- a/share/DebPool/GnuPG.pm
+++ /dev/null
@@ -1,264 +0,0 @@
-package DebPool::GnuPG;
-
-###
-#
-# DebPool::GnuPG - Module for all interactions with GNU Privacy Guard
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: GnuPG.pm 46 2005-02-12 17:52:37Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-use POSIX; # WEXITSTATUS
-use File::Temp ();
-
-# We need these for open3()
-
-use Fcntl;
-use IPC::Open3;
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- &Check_Signature
- &Sign_Release
- &Strip_GPG
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Check_Signature &Sign_Release &Strip_GPG)],
- 'vars' => [qw()],
- );
-}
-
-### Exported package globals
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# Check_Signature($file, $signature)
-#
-# Checks the GPG signature of $file (using $signature as an external
-# signature file, if it is defined; if it isn't, $file is assumed to have
-# an internal signature). Returns 0 on failure, 1 on success.
-
-sub Check_Signature {
- use DebPool::Config qw(:vars);
- use DebPool::Logging qw(:functions :facility :level);
-
- my($file, $signature) = @_;
-
- my(@args) = ('--verify', '--no-default-keyring');
- push(@args, '--homedir', $Options{'gpg_home'}) if defined $Options{'gpg_home'};
-
- foreach my $keyring (@{$Options{'gpg_keyrings'}}) {
- push(@args, '--keyring', $keyring);
- }
-
- push(@args, '--'); # Always a good idea, even if we're pretty sure we won't
- # get any file names starting with "--" in this program.
-
- if (defined($signature)) {
- push(@args, $signature);
- }
-
- push(@args, $file);
-
- my($pid) = open3(*GPG_IN, *GPG_OUT, *GPG_OUT, $Options{'gpg_bin'}, @args);
- close(GPG_IN); # No input
- my @loglines = <GPG_OUT>;
-
- waitpid($pid,0); # No flags, just wait.
-
- if ($?) { # Failure
- foreach (@loglines) {
- Log_Message($_, LOG_GPG, LOG_DEBUG);
- }
- my($msg) = "Failed signature check on '$file' ";
- if (defined($signature)) {
- $msg .= "(signature file '$signature'): ";
- } else {
- $msg .= "(internal signature): ";
- }
- if (WIFEXITED($?)) {
- $msg .= "gpg returned non-zero status " . WEXITSTATUS($?);
- }
- elsif (WIFSIGNALED($?)) {
- $msg .= "gpg died from signal " . WTERMSIG($?);
- }
- else {
- $msg .= "gpg terminated in an unknown way.";
- }
- Log_Message($msg, LOG_GPG, LOG_WARNING);
- }
- return 1;
-}
-
-# Sign_Release($release_file)
-#
-# Generates a detached GPG signature file for $release_file, and returns
-# the filename. Returns undef, if an error occurs (and sets $Error).
-
-sub Sign_Release {
- use DebPool::Config;
- use DebPool::Logging qw(:functions :facility :level);
-
- my($release_file) = @_;
-
- # Open a secure tempfile to write the signature to
-
- my($tmpfile) = new File::Temp;
-
- # We are go for main engine start
-
- my(@args) = ('--batch', '--no-tty', '--detach-sign', '--armor', '--output=-');
- push(@args, '--homedir', $Options{'gpg_home'}) if defined $Options{'gpg_home'};
- push(@args, '--default-key', $Options{'gpg_sign_key'}) if defined $Options{'gpg_sign_key'};
- push(@args, '--passphrase-fd=0', '--passphrase-file', $Options{'gpg_passfile'}) if defined $Options{'gpg_passfile'};
- push(@args, '--', $release_file);
-
- my($gnupg_pid) = open3(*DUMMY, ">&".fileno $tmpfile, *GPG_ERR, $Options{'gpg_bin'}, @args);
- close DUMMY;
- my @loglines = <GPG_ERR>;
- waitpid($gnupg_pid, 0);
-
- foreach (@loglines) {
- Log_Message($_, LOG_GPG, $? ? LOG_ERROR : LOG_WARNING);
- }
-
- if ($?) {
- if (WIFEXITED($?)) {
- $Error = "gpg returned non-zero status " . WEXITSTATUS($?);
- }
- elsif (WIFSIGNALED($?)) {
- $Error = "gpg died from signal " . WTERMSIG($?);
- }
- else {
- $Error = "gpg terminated in an unknown way.";
- }
- return;
- }
-
- # And we're done
- $tmpfile->unlink_on_destroy(0);
- return $tmpfile->filename;
-}
-
-# Strip_GPG(@text)
-#
-# Goes through @text and determine if it has GnuPG headers; if so, strip
-# out the headers, and undo GnuPG's header protection ('^-' -> '^-- -').
-
-sub Strip_GPG {
- my(@text) = @_;
-
- my($header, $firstblank, $sigstart, $sigend);
-
- for my $count (0..$#text) {
- if ($text[$count] =~ m/^-----BEGIN PGP SIGNED MESSAGE-----$/) {
- $header = $count;
- } elsif (!defined($firstblank) && $text[$count] =~ m/^$/) {
- $firstblank = $count;
- } elsif ($text[$count] =~ m/^-----BEGIN PGP SIGNATURE-----$/) {
- $sigstart = $count;
- } elsif ($text[$count] =~ m/^-----END PGP SIGNATURE-----$/) {
- $sigend = $count;
- }
- }
-
- # If we didn't find all three parts, it isn't a validly signed message
- # (or it's externally signed, but that might as well be the same
- # thing for our purposes - there's nothing to remove).
-
- if (!defined($header) || !defined($sigstart) || !defined($sigend)) {
- return @text;
- }
-
- # Okay. Back to front, so that we don't muck up reference numbers.
- # First, we rip out the signature data by splicing it with an empty
- # list.
-
- splice(@text, $sigstart, ($sigend - $sigstart) + 1);
-
- # We used to just rip off the first 3 lines (BEGIN line, hash header,
- # and a blank line). However, this was a cheap shortcut that broke as
- # of GnuPG 1.0.7, because it relied on there being exactly one GnuPG
- # header line.
- #
- # Now, we rip out everything from the header line to the first blank,
- # which should always be correct.
-
- splice(@text, $header, ($firstblank - $header) + 1);
-
- # All done. Fire it back.
-
- return @text;
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Gzip.pm b/share/DebPool/Gzip.pm
deleted file mode 100644
index 1c097c4..0000000
--- a/share/DebPool/Gzip.pm
+++ /dev/null
@@ -1,188 +0,0 @@
-package DebPool::Gzip;
-
-###
-#
-# DebPool::Gzip - Module for handling Gzip interactions
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Gzip.pm 27 2004-11-07 03:06:59Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-use POSIX; # WEXITSTATUS
-
-# Needed for open2()
-
-use Fcntl;
-use IPC::Open2;
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- &Gzip_File
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Gzip_File)],
- 'vars' => [qw()],
- );
-}
-
-### Exported package globals
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# Gzip_File($file)
-#
-# Generates a gzipped version of $file using gzip, and returns the filename.
-# Returns undef (and sets $Error) on failure.
-
-sub Gzip_File {
- use DebPool::Logging qw(:functions :facility :level);
-
- my($file) = @_;
-
- # Open a secure tempfile to write the compressed data into
-
- my($tmpfile) = new File::Temp( SUFFIX => '.gz', UNLINK => 0 );
-
- # Open the source file so that we have it available.
-
- if (!open($source_fh, '<', $file)) {
- $Error = "Couldn't open source file '$file': $!";
- return;
- }
-
- # We are go for main engine start
-
- my(@args) = ('--best', '--force', '--stdout');
-
- my($gzip_pid) = open2(*GZIP_IN, *GZIP_OUT, '/bin/gzip', @args);
-
- my($child_pid);
- if ($child_pid = fork) { # In the parent
- # Send all the data to Gzip;
-
- close(GZIP_IN);
- close($tmpfile);
-
- print GZIP_OUT <$source_fh>;
- close(GZIP_OUT);
- close($source_fh);
-
- waitpid($child_pid, 0);
- waitpid($gzip_pid, 0);
- } else { # In the child - we hope
- if (!defined($child_pid)) {
- die "Couldn't fork: $!\n";
- }
-
- # Read back the results, and print them into the tempfile.
-
- close(GZIP_OUT);
- close($source_fh);
-
- print $tmpfile <GZIP_IN>;
- close(GZIP_IN);
- close($tmpfile);
-
- exit(0);
- }
-
- # And we're done
- return $tmpfile->filename;
-}
-
-sub new {
- bless { ERROR => undef };
-}
-
-sub Compress_File {
- my $self = shift;
- my $tempname = Gzip_File(@_);
- if ($tempname) {
- $self->{'ERROR'} = undef;
- }
- else {
- $self->{'ERROR'} = $Error;
- }
- $tempname;
-}
-
-sub Error {
- my $self = shift;
- $self->{'ERROR'};
-}
-
-sub Name {
- 'gzip';
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Logging.pm b/share/DebPool/Logging.pm
deleted file mode 100644
index 3ea7e5a..0000000
--- a/share/DebPool/Logging.pm
+++ /dev/null
@@ -1,173 +0,0 @@
-package DebPool::Logging;
-
-###
-#
-# DebPool::Logging - Module to handle logging messages
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Logging.pm 31 2005-01-19 17:32:38Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-# For strftime()
-
-use POSIX;
-
-# We need to pull config option information
-
-use DebPool::Config qw(:vars);
-use DebPool::DB qw(:functions); # DB::Close_Databases
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- &Log_Message
- &LOG_AUDIT
- &LOG_CONFIG
- &LOG_DEBUG
- &LOG_ERROR
- &LOG_FATAL
- &LOG_GENERAL
- &LOG_GPG
- &LOG_INFO
- &LOG_INSTALL
- &LOG_PARSE
- &LOG_REJECT
- &LOG_WARNING
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Log_Message)],
- 'vars' => [qw()],
- 'facility' => [qw(&LOG_AUDIT &LOG_CONFIG &LOG_GENERAL &LOG_GPG
- &LOG_INSTALL &LOG_PARSE &LOG_REJECT)],
- 'level' => [qw(&LOG_DEBUG &LOG_INFO &LOG_WARNING &LOG_ERROR
- &LOG_FATAL)],
- );
-}
-
-### Exported package globals
-
-# None
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-### File lexicals
-
-# None
-
-### Constant functions - facility
-
-sub LOG_AUDIT { 'AUDIT' }
-sub LOG_CONFIG { 'CONFIG' }
-sub LOG_GENERAL { 'GENERAL' }
-sub LOG_GPG { 'GPG' }
-sub LOG_INSTALL { 'INSTALL' }
-sub LOG_REJECT { 'REJECT' }
-sub LOG_PARSE { 'PARSE' }
-
-### Constant functions - level
-
-sub LOG_DEBUG { 'DEBUG' }
-sub LOG_INFO { 'INFO' }
-sub LOG_WARNING { 'WARNING' }
-sub LOG_ERROR { 'ERROR' }
-sub LOG_FATAL { 'FATAL' }
-
-### Meaningful functions
-
-# Log_Message($message, FACILITY, LEVEL)
-#
-# Log a message with text $message using FACILITY and LEVEL, via the current
-# configured log method.
-
-# FIXME - this is a really crude logging setup. We should probably support
-# a variety of things, like logging to processes, syslogging, not doing an
-# open/close for each message, maybe email logging with batched messages.
-#
-# However, this is an early version, so it will suffice for now.
-
-sub Log_Message {
- my($msg, $facility, $level) = @_;
-
- # First, do we have anywhere to log? We assume that 'undef' is an
- # explicit request to not log, since it isn't a default value.
-
- if (!defined($Options{'log_file'})) {
- return;
- }
-
- # If we can't log to it, die with a message (on the off chance that we're
- # not in daemon mode, and the user will see it).
-
- my $log_fh;
- if (!open($log_fh, '>>', $Options{'log_file'})) {
- Close_Databases(); # If they were open
- unlink($Options{'lock_file'}); # In case we had one
-
- die "Couldn't write to log file '$Options{'log_file'}'.";
- }
-
- print $log_fh strftime("%Y-%m-%d %H:%M:%S", localtime());
- print $log_fh " [$facility/$level] $msg\n";
- close($log_fh);
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Packages.pm b/share/DebPool/Packages.pm
deleted file mode 100644
index fdf62f3..0000000
--- a/share/DebPool/Packages.pm
+++ /dev/null
@@ -1,1311 +0,0 @@
-package DebPool::Packages;
-
-###
-#
-# DebPool::Packages - Module for handling package metadata
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Packages.pm 70 2006-06-26 20:44:57Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-use POSIX; # WEXITSTATUS
-use File::Temp qw(tempfile);
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- &Allow_Version
- &Audit_Package
- &Generate_List
- &Generate_Package
- &Generate_Source
- &Guess_Section
- &Install_List
- &Install_Package
- &Parse_Changes
- &Parse_DSC
- &Reject_Package
- &Verify_MD5
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Allow_Version &Audit_Package &Generate_List
- &Generate_Package &Generate_Source &Guess_Section
- &Install_List &Install_Package &Parse_Changes
- &Parse_DSC &Reject_Package &Verify_MD5)],
- 'vars' => [qw()],
- );
-}
-
-### Exported package globals
-
-# None
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our $Error;
-
-# Fields (other than package relationships) from dpkg --info that we
-# actually care about in some fashion.
-
-my @Info_Fields = (
-# 'Package',
- 'Priority',
- 'Section',
- 'Installed-Size',
-# 'Maintainer',
- 'Architecture',
-# 'Version',
- 'Essential',
-);
-
-# Package relationship fieldnames.
-
-my @Relationship_Fields = (
- 'Pre-Depends',
- 'Depends',
- 'Provides',
- 'Conflicts',
- 'Recommends',
- 'Suggests',
- 'Enhances',
- 'Replaces',
-);
-
-# Normal fields potentially found in .changes files
-
-my %Changes_Fields = (
- 'Format' => 'string',
- 'Date' => 'string',
- 'Source' => 'string',
- 'Binary' => 'space_array',
- 'Architecture' => 'space_array',
- 'Version' => 'string',
- 'Distribution' => 'space_array',
- 'Urgency' => 'string',
- 'Maintainer' => 'string',
- 'Changed-By' => 'string',
- 'Closes' => 'space_array',
-);
-
-# Normal fields potentially found in .dsc files
-
-my %DSC_Fields = (
- 'Format' => 'string',
- 'Source' => 'string',
- 'Version' => 'string',
- 'Binary' => 'comma_array',
- 'Maintainer' => 'string',
- 'Architecture' => 'space_array',
- 'Standards-Version' => 'string',
- 'Build-Depends' => 'comma_array',
- 'Build-Depends-Indep' => 'comma_array',
-);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# Allow_Version($package, $version, $distribution)
-#
-# Decide, based on version comparison and config options, whether $version
-# is an acceptable version for $package in $distribution. Returns 1 if the
-# version is acceptable, 0 if it is not, and undef (and sets $Error) in the
-# case of an error.
-
-sub Allow_Version {
- use DebPool::Config qw(:vars);
- use DebPool::DB qw(:functions);
- use DebPool::Logging qw(:functions :facility :level);
-
- my($package, $version, $distribution, $arch) = @_;
- my $old_version = Get_Version($distribution, $package, 'meta');
-
- # If we permit rollback, any version is valid.
-
- if ($Options{'rollback'}) {
- return 1;
- }
-
- # If we don't have an old version, anything is acceptable.
-
- if (!defined($old_version)) {
- return 1;
- }
-
- if ($version eq $old_version) {
- my (%count, @duplicate_arches);
- my @old_archs = Get_Archs($distribution, $package);
- foreach (@old_archs, @$arch) {
- if (++$count{$_} > 1) {
- push @duplicate_arches, $_;
- }
- }
- if (@duplicate_arches) {
- my $msg = "Version comparison for '$package': ";
- $msg .= "proposed version for $distribution ($version) ";
- $msg .= "is same as current version and the following ";
- $msg .= "architectures already exist: ";
- $msg .= join ', ', @duplicate_arches;
- Log_Message($msg, LOG_GENERAL, LOG_DEBUG);
- return 0;
- }
- return 1;
- }
-
- my $dpkg_bin = '/usr/bin/dpkg';
- my @args = ('--compare-versions', $version, 'gt', $old_version);
-
- my $sysret = WEXITSTATUS(system($dpkg_bin, @args));
-
- if (0 != $sysret) { # DPKG says no go.
- my $msg = "Version comparison for '$package': proposed version for ";
- $msg .= "$distribution ($version) is not greater than current ";
- $msg .= "version ($old_version)";
- Log_Message($msg, LOG_GENERAL, LOG_DEBUG);
-
- return 0;
- }
-
- return 1;
-}
-
-# Parse_Changes($changes_filename)
-#
-# Parses the changes file found at $changes_filename (which should be a
-# fully qualified path and filename), and returns a hashref pointing to a
-# Changes hash. Returns undef in the case of a failure (and sets $Error).
-
-# Changes Hash format:
-# {
-# 'Architecture' => \@Architectures
-# 'Binary' => \@Binaries
-# 'Changed-By' => Changed-By
-# 'Changes' => \@Changes lines
-# 'Closes' => \@Bugs
-# 'Description' => Description
-# 'Files' => \@\%File Hashes
-# 'Date' => RFC 822 timestamp
-# 'Distribution' => \@Distributions
-# 'Maintainer' => Maintainer
-# 'Source' => Source
-# 'Urgency' => Urgency
-# 'Version' => Version
-# }
-
-# File Hash format:
-# {
-# 'Filename' => Filename (leaf node only)
-# 'MD5Sum' => File MD5Sum
-# 'Priority' => Requested archive priority
-# 'Section' => Requested archive section
-# 'Size' => File size (in bytes)
-# }
-
-sub Parse_Changes {
- use DebPool::GnuPG qw(:functions);
- use DebPool::Logging qw(:functions :facility :level);
-
- my($file) = @_;
- my %result;
-
- # Read in the entire Changes file, stripping GPG encoding if we find
- # it. It should be small, this is fine.
-
- my $changes_fh;
- if (!open($changes_fh, '<', $file)) {
- $Error = "Couldn't open changes file '$file': $!";
- return;
- }
-
- my @changes = <$changes_fh>;
- chomp(@changes);
- @changes = Strip_GPG(@changes);
- close($changes_fh);
-
- # Go through each of the primary fields, stuffing it into the result
- # hash if we find it.
-
- foreach my $field (keys(%Changes_Fields)) {
- my @lines = grep(/^${field}:\s+/, @changes);
- if (-1 == $#lines) { # No match
- next;
- } elsif (0 < $#lines) { # Multiple matches
- Log_Message("Duplicate entries for field '$field'",
- LOG_PARSE, LOG_WARNING);
- }
-
- $lines[0] =~ s/^${field}:\s+//;
-
- if ('string' eq $Changes_Fields{$field}) {
- $result{$field} = $lines[0];
- } elsif ('space_array' eq $Changes_Fields{$field}) {
- my @array = split(/\s+/, $lines[0]);
- $result{$field} = \@array;
- } elsif ('comma_array' eq $Changes_Fields{$field}) {
- my @array = split(/\s+,\s+/, $lines[0]);
- $result{$field} = \@array;
- }
- }
-
- # Now that we should have it, check to make sure we have a Format
- # header, and that it's format 1.7 or 1.8.
-
- if (!defined($result{'Format'})) {
- Log_Message("No Format header found in changes file '$file'",
- LOG_PARSE, LOG_ERROR);
- $Error = 'No Format header found';
- return;
- } elsif (('1.7' ne $result{'Format'}) and ('1.8' ne $result{'Format'})) {
- Log_Message("Unrecognized Format version '$result{'Format'}'",
- LOG_PARSE, LOG_ERROR);
- $Error = 'Unrecognized Format version';
- return;
- }
-
- # Special case: Description. One-line entry, immediately after a line
- # with '^Description:'.
-
- for my $count (0..$#changes) {
- if ($changes[$count] =~ m/^Description:/) {
- $result{'Description'} = $changes[$count+1];
- }
- }
-
- # Special case: Changes. Multi-line entry, starts one line after
- # '^Changes:', goes until we hit the Files header.
-
- my($found) = 0;
- my @changelines;
-
- for my $count (0..$#changes) {
- if ($found) {
- if ($changes[$count] =~ m/^Files:/) {
- $found = 0;
- } else {
- push(@changelines, $changes[$count]);
- }
- } else {
- if ($changes[$count] =~ m/^Changes:/) {
- $found = 1;
- }
- }
- }
-
- $result{'Changes'} = \@changelines;
-
- # The Files section is a special case. It starts on the line after the
- # 'Files:' header, and goes until we hit a blank line, or the end of
- # the data.
-
- my @files;
-
- for my $count (0..$#changes) {
- if ($found) {
- if ($changes[$count] =~ m/^(\s*$|\S)/) { # End of Files entry
- $found = 0; # No longer in Files
- } elsif ($changes[$count] =~ m/\s*([[:xdigit:]]+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
- my ($md5, $size, $sec, $pri, $file) = ($1, $2, $3, $4, $5);
- push(@files, {
- 'Filename' => $file,
- 'MD5Sum' => $md5,
- 'Priority' => $pri,
- 'Section' => $sec,
- 'Size' => $size,
- });
- } else { # What's this doing here?
- my $msg = 'Unrecognized data in Files section of changes file';
- $msg .= " '$file'";
- Log_Message($msg, LOG_PARSE, LOG_WARNING);
- }
- } else {
- if ($changes[$count] =~ m/^Files:/) {
- $found = 1;
- }
- }
- }
-
- $result{'Files'} = \@files;
-
- return \%result;
-}
-
-# Parse_DSC($dsc_filename)
-#
-# Parses the dsc file found at $dsc_filename (which should be a fully
-# qualified path and filename), and returns a hashref pointing to a DSC
-# hash. Returns undef in the case of a failure (and sets $Error).
-
-# DSC Hash format:
-# {
-# 'Format' => Format
-# 'Source' => Source
-# 'Binary' => \@Binaries
-# 'Maintainer' => Maintainer
-# 'Architecture' => \@Architectures
-# 'Standards-Version' => Standards-Version
-# 'Build-Depends' => Build-Depends
-# 'Build-Depends-Indep' => Build-Depends-Indep
-# 'Files' => \@\%Filehash
-# }
-
-# File Hash format:
-# {
-# 'Filename' => Filename (leaf node only)
-# 'MD5Sum' => File MD5Sum
-# 'Size' => File size (in bytes)
-# }
-
-sub Parse_DSC {
- use DebPool::GnuPG qw(:functions);
- use DebPool::Logging qw(:functions :facility :level);
-
- my($file) = @_;
- my %result;
-
- # Read in the entire DSC file, stripping GPG encoding if we find it. It
- # should be small, this is fine.
-
- my $dsc_fh;
- if (!open($dsc_fh, '<', $file)) {
- $Error = "Couldn't open dsc file '$file': $!";
- return;
- }
-
- my @dsc = <$dsc_fh>;
- chomp(@dsc);
- @dsc = Strip_GPG(@dsc);
- close($dsc_fh);
-
- # Go through each of the primary fields, stuffing it into the result
- # hash if we find it.
-
- foreach my $field (keys(%DSC_Fields)) {
- my @lines = grep(/^${field}:\s+/, @dsc);
- if (-1 == $#lines) { # No match
- next;
- } elsif (0 < $#lines) { # Multiple matches
- Log_Message("Duplicate entries for field '$field'",
- LOG_PARSE, LOG_WARNING);
- }
-
- $lines[0] =~ s/^${field}:\s+//;
-
- if ('string' eq $DSC_Fields{$field}) {
- $result{$field} = $lines[0];
- } elsif ('space_array' eq $DSC_Fields{$field}) {
- my @array = split(/\s+/, $lines[0]);
- $result{$field} = \@array;
- } elsif ('comma_array' eq $DSC_Fields{$field}) {
- my @array = split(/\s+,\s+/, $lines[0]);
- $result{$field} = \@array;
- }
- }
-
- # Now that we should have it, check to make sure we have a Format
- # header, and that it's format 1.0 (the only thing we grok).
-
- if (!defined($result{'Format'})) {
- Log_Message("No Format header found in dsc file '$file'",
- LOG_PARSE, LOG_ERROR);
- $Error = 'No Format header found';
- return;
- } elsif ('1.0' ne $result{'Format'}) {
- Log_Message("Unrecognized Format version '$result{'Format'}'",
- LOG_PARSE, LOG_ERROR);
- $Error = 'Unrecognized Format version';
- return;
- }
-
- # The Files section is a special case. It starts on the line after the
- # 'Files:' header, and goes until we hit a blank line, or the end of
- # the data.
-
- # In fact, it's even more special than that; it includes, first, an entry
- # for the DSC file itself...
-
- my $count;
- my $found = 0;
- my @files;
-
- my @temp = split(/\//, $file);
- my $dsc_leaf = pop(@temp);
-
- my $cmd_result = `/usr/bin/md5sum $file`;
- $cmd_result =~ m/^([[:xdigit:]]+)\s+/;
- my $dsc_md5 = $1;
-
- my @stat = stat($file);
- if (!@stat) {
- $Error = "Couldn't stat DSC file '$file'";
- return;
- }
- my $dsc_size = $stat[7];
-
- push(@files, {
- 'Filename' => $dsc_leaf,
- 'MD5Sum' => $dsc_md5,
- 'Size' => $dsc_size,
- });
-
- for my $count (0..$#dsc) {
- if ($found) {
- if ($dsc[$count] =~ m/^(\s*$|\S)/) { # End of Files entry
- $found = 0; # No longer in Files
- } elsif ($dsc[$count] =~ m/\s*([[:xdigit:]]+)\s+(\d+)\s+(\S+)/) {
- my($md5, $size, $file) = ($1, $2, $3);
- push(@files, {
- 'Filename' => $file,
- 'MD5Sum' => $md5,
- 'Size' => $size,
- });
- } else { # What's this doing here?
- my $msg = 'Unrecognized data in Files section of dsc file';
- $msg .= " '$file'";
- Log_Message($msg, LOG_PARSE, LOG_WARNING);
- }
- } else {
- if ($dsc[$count] =~ m/^Files:/) {
- $found = 1;
- }
- }
- }
-
- $result{'Files'} = \@files;
-
- return \%result;
-}
-
-# Generate_List($distribution, $section, $arch)
-#
-# Generates a Packages (or Sources) file for the given distribution,
-# section, and architecture (with 'source' being a special value for
-# Sources). Returns the filename of the generated file on success, or undef
-# (and sets $Error) on failure. Note that requests for an 'all' list are
-# ignored - however, every non-source arch gets 'all' files.
-
-sub Generate_List {
- use DebPool::Config qw(:vars);
- use DebPool::DB qw(:functions :vars);
- use DebPool::Dirs qw(:functions);
-
- my($distribution, $section, $arch) = @_;
-
- my %packages;
-
- if ('all' eq $arch) {
- $Error = "No point in generating Packages file for binary-all";
- return;
- }
-
- my @sources = grep($ComponentDB{$distribution}->{$_} eq $section,
- keys(%{$ComponentDB{$distribution}}));
-
- my($tmpfile_handle, $tmpfile_name) = tempfile();
-
- # Dump the data from pool/*/*/pkg_ver.{package,source} into the list.
-
- # FIXME: This needs to be refactored. Needs it pretty badly, in fact.
-
- if ('source' eq $arch) {
- foreach my $source (@sources) {
- my $pool = join('/',
- ($Options{'pool_dir'}, PoolDir($source, $section), $source));
- my $version = Get_Version($distribution, $source, 'meta');
- my $target = "$pool/${source}_" . Strip_Epoch($version);
- $target .= '.source';
-
- # Source files aren't always present.
- next if (!open(my $src_fh, '<', "$target"));
-
- $tmpfile_handle->print(<$src_fh>);
- close($src_fh);
- }
- } else {
- foreach my $source (@sources) {
- my $pool = join('/',
- ($Options{'pool_dir'}, PoolDir($source, $section), $source));
- my $version = Get_Version($distribution, $source, 'meta');
- my $target = "$pool/${source}_" . Strip_Epoch($version);
- $target .= "_$arch\.package";
- my $target_all = "$pool/${source}_" . Strip_Epoch($version);
- $target_all .= "_all\.package";
-
- my ($pkg_arch_fh, $pkg_all_fh);
-
- # Check for any binary-arch packages
- if (-e $target) {
- if (!open($pkg_arch_fh, '<', "$target")) {
- my $msg = "Skipping package entry for all packages from ";
- $msg .= "${source}: couldn't open '$target' for reading: $!";
-
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
- next;
- }
- }
-
- # Check for any binary-all packages
- if (-e $target_all) {
- if (!open($pkg_all_fh, '<', "$target_all")) {
- my $msg = "Skipping package entry for all packages ";
- $msg .= "from ${source}: couldn't open '$target_all' for";
- $msg .= " reading: $!";
-
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
- next;
- }
- }
-
- # Playing around with the record separator ($/) to make this
- # easier.
-
- my $backup_RS = $/;
- $/ = "";
-
- my @arch_entries;
- if (-e $target) { # Write entries from arch packages
- @arch_entries = <$pkg_arch_fh>;
- close($pkg_arch_fh);
- }
-
- my @all_entries;
- if (-e $target_all) { # Write entries from all packages
- @all_entries = <$pkg_all_fh>;
- close($pkg_all_fh);
- }
-
- $/ = $backup_RS;
-
- # Pare it down to the relevant entries, and print those out.
-
- @arch_entries = grep(/\nArchitecture: ($arch)\n/, @arch_entries);
- @all_entries = grep(/\nArchitecture: all\n/, @all_entries);
- print $tmpfile_handle @arch_entries;
- print $tmpfile_handle @all_entries;
- }
- }
-
- close($tmpfile_handle);
-
- return $tmpfile_name;
-}
-
-# Install_Package($changes, $Changes_hashref, $DSC, $DSC_hashref, \@distributions)
-#
-# Install all of the package files for $Changes_hashref (which should
-# be a Parse_Changes result hash) into the pool directory, and install
-# the file in $changes to the installed directory. Also generates (and
-# installes) .package and .source meta-data files. It also updates the
-# Version database for the listed distributions. Returns 1 if successful, 0
-# if not (and sets $Error).
-
-sub Install_Package {
- use DebPool::Config qw(:vars);
- use DebPool::Dirs qw(:functions);
- use DebPool::DB qw(:functions :vars);
- use DebPool::Util qw(:functions);
-
- my($changes, $chg_hashref, $dsc, $dsc_hashref, $distributions) = @_;
-
- my $incoming_dir = $Options{'incoming_dir'};
- my $installed_dir = $Options{'installed_dir'};
- my $pool_dir = $Options{'pool_dir'};
-
- my $pkg_name = $chg_hashref->{'Source'};
- my $pkg_ver = $chg_hashref->{'Version'};
-
- my $guess_section = Guess_Section($chg_hashref);
- my $pkg_pool_subdir = join('/',
- ($pool_dir, PoolDir($pkg_name, $guess_section)));
- my $pkg_dir = join('/', ($pkg_pool_subdir, $pkg_name));
-
- # Create the directory or error out
-
- if (!Tree_Mkdir($pkg_pool_subdir, $Options{'pool_dir_mode'})) {
- return 0;
- }
- if (!Tree_Mkdir($pkg_dir, $Options{'pool_dir_mode'})) {
- return 0;
- }
-
- # Walk the File Hash, trying to install each listed file into the
- # pool directory.
-
- foreach my $filehash (@{$chg_hashref->{'Files'}}) {
- my $file = $filehash->{'Filename'};
- if (!Move_File("${incoming_dir}/${file}", "${pkg_dir}/${file}",
- $Options{'pool_file_mode'})) {
- $Error = "Failed to move '${incoming_dir}/${file}' ";
- $Error .= "to '${pkg_dir}/${file}': ${DebPool::Util::Error}";
- return 0;
- }
- }
-
- # Generate and install .package and .source metadata files.
-
- my @pkg_archs = @{$chg_hashref->{'Architecture'}};
- @pkg_archs = grep(!/source/, @pkg_archs); # Source is on it's own.
-
- my $target;
- foreach my $pkg_arch (@pkg_archs) {
- my $pkg_file = Generate_Package($chg_hashref, $pkg_arch);
-
- if (!defined($pkg_file)) {
- $Error = "Failed to generate .package file: $Error";
- return;
- }
-
- $target = "$pkg_dir/${pkg_name}_" . Strip_Epoch($pkg_ver) . "_$pkg_arch" . '.package';
-
- if (!Move_File($pkg_file, $target, $Options{'pool_file_mode'})) {
- $Error = "Failed to move '$pkg_file' to '$target': ";
- $Error .= $DebPool::Util::Error;
- return 0;
- }
- }
-
- if (defined($dsc) && defined($dsc_hashref)) {
- my $src_file = Generate_Source($dsc, $dsc_hashref, $chg_hashref);
-
- if (!defined($src_file)) {
- $Error = "Failed to generate .source file: $Error";
- return;
- }
-
- $target = "$pkg_dir/${pkg_name}_" . Strip_Epoch($pkg_ver) . '.source';
-
- if (!Move_File($src_file, $target, $Options{'pool_file_mode'})) {
- $Error = "Failed to move '$src_file' to '$target': ";
- $Error .= $DebPool::Util::Error;
- return 0;
- }
- }
-
- # Finally, try to install the changes file to the installed directory.
-
- if (!Move_File("$incoming_dir/$changes", "$installed_dir/$changes",
- $Options{'installed_file_mode'})) {
- $Error = "Failed to move '$incoming_dir/$changes' to ";
- $Error .= "'$installed_dir/$changes': ${DebPool::Util::Error}";
- return 0;
- }
-
- # Update the various databases.
-
- my $distribution;
-
- # This whole block is just to calculate the component. What a stupid
- # setup - it should be in the changes file. Oh well.
-
- my @filearray = @{$chg_hashref->{'Files'}};
- my $fileref = $filearray[0];
- my $section = $fileref->{'Section'};
- my $component = Strip_Subsection($section);
-
- foreach my $distribution (@{$distributions}) {
- Set_Versions($distribution, $pkg_name, $pkg_ver,
- $chg_hashref->{'Files'});
- $ComponentDB{$distribution}->{$pkg_name} = $component;
- }
- if ( $section eq 'debian-installer' ) {
- $component .= '/debian-installer';
- }
-
- return 1;
-}
-
-# Reject_Package($changes, $chg_hashref)
-#
-# Move all of the package files for $chg_hashref (which should be a
-# Parse_Changes result hash) into the rejected directory, as well as the
-# file in $changes. Returns 1 if successful, 0 if not (and sets $Error).
-
-sub Reject_Package {
- use DebPool::Config qw(:vars);
- use DebPool::DB qw(:functions);
- use DebPool::Util qw(:functions);
-
- my($changes, $chg_hashref) = @_;
-
- my $incoming_dir = $Options{'incoming_dir'};
- my $reject_dir = $Options{'reject_dir'};
- my $reject_file_mode = $Options{'reject_file_mode'};
-
- # Walk the File Hash, moving each file to the rejected directory.
-
- foreach my $filehash (@{$chg_hashref->{'Files'}}) {
- my $file = $filehash->{'Filename'};
- if (!Move_File("$incoming_dir/$file", "$reject_dir/$file",
- $reject_file_mode)) {
- $Error = "Failed to move '$incoming_dir/$file' ";
- $Error .= "to '$reject_dir/$file': ${DebPool::Util::Error}";
- return 0;
- }
- }
-
- # Now move the changes file to the rejected directory, as well.
-
- if (!Move_File("$incoming_dir/$changes", "$reject_dir/$changes",
- $reject_file_mode)) {
- $Error = "Failed to move '$incoming_dir/$changes' to ";
- $Error .= "'$reject_dir/$changes': ${DebPool::Util::Error}";
- return 0;
- }
-
- return 1;
-}
-
-# Verify_MD5($file, $md5)
-#
-# Verifies the MD5 checksum of $file against $md5. Returns 1 if it matches,
-# 0 if it doesn't, and undef (also setting $Error) if an error occurs. This
-# routine uses the dpkg md5sum utility, to avoid pulling in a dependancy on
-# Digest::MD5.
-
-sub Verify_MD5 {
- use DebPool::Logging qw(:functions :facility :level);
-
- my($file, $md5) = @_;
-
- # Read in and mangle the md5 output.
-
- if (! -r $file) { # The file doesn't exist! Will be hard to checksum it...
- my $msg = "MD5 checksum unavailable: file '$file' does not exist!";
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
- return 0;
- }
-
- my $cmd_result = `/usr/bin/md5sum $file`;
- if (!$cmd_result) { # Failed to run md5sum for some reason
- my $msg = "MD5 checksum unavailable: file '$file'";
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
- return 0;
- }
-
- $cmd_result =~ m/^([[:xdigit:]]+)\s+/;
- my $check_md5 = $1;
-
- if ($md5 ne $check_md5) {
- my $msg = "MD5 checksum failure: file '$file', ";
- $msg .= "expected '$md5', got '$check_md5'";
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
- return 0;
- }
-
- return 1;
-}
-
-# Audit_Package($package, $chg_hashref)
-#
-# Delete a package and changes files for the named (source) package which
-# are not referenced by any version currently found in the various release
-# databases. Returns the number of files unlinked (which may be 0), or
-# undef (and sets $Error) on an error.
-
-sub Audit_Package {
- use DebPool::Config qw(:vars);
- use DebPool::Dirs qw(:functions);
- use DebPool::Logging qw(:functions :facility :level);
-
- my($package, $changes_hashref) = @_;
-
- # Checking for version of package being installed
- my $changes_version = $changes_hashref->{'Version'};
- # Checking for binary only upload
- my $with_source = undef;
- # Checking for binary-all packages in binary only upload
- my $with_indep = undef;
- for my $temp (@{$changes_hashref->{'Architecture'}}) {
- if ('source' eq $temp) {
- $with_source = 1;
- }
- if ('all' eq $temp) {
- $with_indep = 1;
- }
- }
-
- my $installed_dir = $Options{'installed_dir'};
- my $pool_dir = $Options{'pool_dir'};
-
- my $section = Guess_Section($changes_hashref);
- my $package_dir = join('/',
- ($pool_dir, PoolDir($package, $section), $package));
-
- my @changes = grep(/${package}_/, Scan_Changes($installed_dir));
-
- my $pool_scan = Scan_All($package_dir);
- if (!defined($pool_scan)) {
- $Error = $DebPool::Dirs::Error;
- return;
- }
- my @pool_files = @{$pool_scan};
-
- # Go through each file found in the pool directory, and determine its
- # version. If it isn't in the current version tables, unlink it.
-
- my $unlinked = 0;
- foreach my $file (@pool_files) {
- my $orig = 0;
- my $deb = 0;
- my $src = 0;
- my($bin_package, $version);
-
- if ($file =~ m/^([^_]+)_([^_]+)\.orig\.tar\.gz$/) { # orig.tar.gz
- $bin_package = $1;
- $version = $2;
- $src = 1;
- $orig = 1;
- } elsif ($file =~ m/^([^_]+)_([^_]+)\.tar\.gz$/) { # tar.gz
- $bin_package = $1;
- $version = $2;
- $src = 1;
- } elsif ($file =~ m/^([^_]+)_([^_]+)\.diff\.gz$/) { # diff.gz
- $bin_package = $1;
- $version = $2;
- $src = 1;
- } elsif ($file =~ m/^([^_]+)_([^_]+)\.dsc$/) { # dsc
- $bin_package = $1;
- $version = $2;
- $src = 1;
- } elsif ($file =~ m/^([^_]+)_([^_]+)_.+\.deb$/) { # deb
- $bin_package = $1;
- $version = $2;
- $deb = 1;
- } elsif ($file =~ m/^([^_]+)_([^_]+)_.+\.udeb$/) { # udeb
- $bin_package = $1;
- $version = $2;
- $deb = 1;
- } elsif ($file =~ m/^([^_]+)_([^_]+)_.+\.package$/) { # package metadata
- $bin_package = $1;
- $version = $2;
- } elsif ($file =~ m/^([^_]+)_([^_]+)\.source$/) { # source metadata
- $bin_package = $1;
- $version = $2;
- } else {
- Log_Message("Couldn't figure out filetype for '$package_dir/$file'",
- LOG_AUDIT, LOG_ERROR);
- next;
- }
-
- # Skip files if we recognize it as a valid version.
-
- # Skipping dsc, diff.gz, and orig tarball files if doing a binary only
- # upload
- if (!$with_source) {
- $src = 0;
- # Skip binary-all packages in a binary only upload without
- # binary-all packages as long as they're of the same changes
- # version
- if ((!$with_indep) &&
- ($file =~ m/\Q_${changes_version}_all.\Eu?deb/)) {
- $deb = 0;
- }
- }
- my $matched = 0;
- foreach my $dist (@{$Options{'realdists'}}) {
- my $ver_pkg;
- if ($src) {
- $ver_pkg = 'source';
- } elsif ($deb) {
- $ver_pkg = $bin_package;
- } else {
- $ver_pkg = 'meta';
- }
-
- my $dist_ver = Get_Version($dist, $package, $ver_pkg);
- next if (!defined($dist_ver)); # No version in specified dist
- $dist_ver = Strip_Epoch($dist_ver);
- if ($orig) { $dist_ver =~ s/-.+$//; }
- if ($version eq $dist_ver) { $matched = 1; }
- }
- next if $matched;
-
- # Otherwise, unlink it.
-
- if (unlink("$package_dir/$file")) {
- $unlinked += 1;
- Log_Message("Unlinked obsolete pool file '$package_dir/$file'",
- LOG_AUDIT, LOG_DEBUG);
- } else {
- Log_Message("Couldn't obsolete pool file '$package_dir/$file'",
- LOG_AUDIT, LOG_ERROR);
- }
- }
-
- foreach my $file (@changes) {
- $file =~ m/^[^_]+_([^_]+)_.+$/; # changes
- my $version = $1;
-
- my $matched = 0;
- foreach my $dist (@{$Options{'realdists'}}) {
- my $dist_ver = Get_Version($dist, $package, 'meta');
- next if (!defined($dist_ver)); # No version in specified dist
- $dist_ver = Strip_Epoch($dist_ver);
- if ($version eq $dist_ver) { $matched = 1; }
- }
- next if $matched;
-
- if (unlink("$installed_dir/$file")) {
- $unlinked += 1;
- Log_Message("Unlinked obsolete changes file " .
- "'$installed_dir/$file'", LOG_AUDIT, LOG_DEBUG);
- } else {
- Log_Message("Couldn't obsolete changes file " .
- "'$installed_dir/$file'", LOG_AUDIT, LOG_ERROR);
- }
- }
-
- return $unlinked;
-}
-
-# Generate_Package($chg_hashref)
-#
-# Generates a .package metadata file (Packages entries for each binary
-# package) in the tempfile area, and returns the filename. Returns undef
-# (and sets $Error) on failure.
-
-sub Generate_Package {
- use DebPool::Config qw(:vars);
- use DebPool::Dirs qw(:functions);
- use DebPool::Logging qw(:functions :facility :level);
-
- my($changes_data, $arch) = @_;
- my $source = $changes_data->{'Source'};
- my @files = @{$changes_data->{'Files'}};
- my $pool_base = PoolBasePath();
-
- # Grab a temporary file.
-
- my($tmpfile_handle, $tmpfile_name) = tempfile();
-
- my @packages = @{$changes_data->{'Binary'}};
-
- my $package;
-
- foreach my $package (@packages) {
- # Construct a pattern to match the filename and nothing else.
- # This used to be an exact match using the source version, but
- # Debian's standards are sort of insane, and the version number
- # on binary files is not always the same as that on the source
- # file (nor is it even something simple like "source version
- # without the epoch" -- it is more or less arbitrary, as long
- # as it is a well-formed version number).
- my $filepat = qr/^\Q${package}_\E.*\Q_${arch}.\Eu?deb/;
- my $section = Guess_Section($changes_data);
- my $pool = join('/', (PoolDir($source, $section), $source));
-
- my $marker = -1;
- # Step through each file, match against filename. Save matches
- # for later use.
-
- for my $count (0..$#files) {
- if ($files[$count]->{'Filename'} =~ m/^$filepat$/) {
- $marker = $count;
- }
- }
-
- # The changes file has a stupid quirk; it puts all binaries from
- # a package in the Binary: line, even if they weren't built (for
- # example, an Arch: all doc package when doing an arch-only build
- # for a port). So if we didn't find a .deb file for it, assume
- # that it's one of those, and skip, rather than choking on it.
-
- next if (-1 == $marker);
-
- # Run Dpkg_Info to grab the dpkg --info data on the package.
-
- my $file = $files[$marker]->{'Filename'};
- my $info = Dpkg_Info("$Options{'pool_dir'}/$pool/$file");
-
- # Dump all of our data into the metadata tempfile.
-
- print $tmpfile_handle "Package: $package\n";
-
- if (defined($info->{'Priority'})) {
- print $tmpfile_handle "Priority: $info->{'Priority'}\n";
- }
-
- if (defined($info->{'Section'})) {
- print $tmpfile_handle "Section: $info->{'Section'}\n";
- }
-
- if (defined($info->{'Essential'})) {
- print $tmpfile_handle "Essential: $info->{'Essential'}\n";
- }
-
- print $tmpfile_handle "Installed-Size: $info->{'Installed-Size'}\n";
-
- print $tmpfile_handle "Maintainer: $changes_data->{'Maintainer'}\n";
- print $tmpfile_handle "Architecture: $arch\n";
- print $tmpfile_handle "Source: $source\n";
- print $tmpfile_handle "Version: $changes_data->{'Version'}\n";
-
- # All of the inter-package relationships go together, and any
- # one of them can potentially be empty (and omitted).
-
- foreach my $field (@Relationship_Fields) {
- if (defined($info->{$field})) {
- print $tmpfile_handle "${field}: $info->{$field}\n";
- }
- }
-
- # And now, some stuff we can grab out of the parsed changes
- # data far more easily than anywhere else.
-
- print $tmpfile_handle "Filename: $pool_base/$pool/$file\n";
-
- print $tmpfile_handle "Size: $files[$marker]->{'Size'}\n";
- print $tmpfile_handle "MD5sum: $files[$marker]->{'MD5Sum'}\n";
-
- print $tmpfile_handle "Description: $info->{'Description'}";
-
- print $tmpfile_handle "\n";
- }
-
- # All done
-
- close($tmpfile_handle);
- return $tmpfile_name;
-}
-
-# Generate_Source($dsc, $dsc_hashref, $changes_hashref)
-#
-# Generates a .source metadata file (Sources entries for the source
-# package) in the tempfile area, and returns the filename. Returns undef
-# (and sets $Error) on failure.
-
-sub Generate_Source {
- use DebPool::Dirs qw(:functions);
- use DebPool::Logging qw(:functions :facility :level);
-
- my($dsc, $dsc_data, $changes_data) = @_;
- my $source = $dsc_data->{'Source'};
- my @files = @{$dsc_data->{'Files'}};
-
- # Figure out the priority and section, using the DSC filename and
- # the Changes file data.
-
- my ($section, $priority);
- foreach my $filehr (@{$changes_data->{'Files'}}) {
- if ($filehr->{'Filename'} eq $dsc) {
- $section = $filehr->{'Section'};
- $priority = $filehr->{'Priority'};
- }
- }
-
- # Grab a temporary file.
-
- my($tmpfile_handle, $tmpfile_name) = tempfile();
-
- # Dump out various metadata.
-
- print $tmpfile_handle "Package: $source\n";
- print $tmpfile_handle "Binary: " . join(', ', @{$dsc_data->{'Binary'}}) . "\n";
- print $tmpfile_handle "Version: $dsc_data->{'Version'}\n";
- print $tmpfile_handle "Priority: $priority\n";
- print $tmpfile_handle "Section: $section\n";
- print $tmpfile_handle "Maintainer: $dsc_data->{'Maintainer'}\n";
-
- if (defined($dsc_data->{'Build-Depends'})) {
- print $tmpfile_handle 'Build-Depends: ';
- print $tmpfile_handle join(', ', @{$dsc_data->{'Build-Depends'}}) . "\n";
- }
-
- if (defined($dsc_data->{'Build-Depends-Indep'})) {
- print $tmpfile_handle 'Build-Depends-Indep: ';
- print $tmpfile_handle join(', ', @{$dsc_data->{'Build-Depends-Indep'}}) . "\n";
- }
-
- print $tmpfile_handle 'Architecture: ';
- print $tmpfile_handle join(' ', @{$dsc_data->{'Architecture'}}) . "\n";
-
- print $tmpfile_handle "Standards-Version: $dsc_data->{'Standards-Version'}\n"
- if exists $dsc_data->{'Standards-Version'};
- print $tmpfile_handle "Format: $dsc_data->{'Format'}\n";
- print $tmpfile_handle "Directory: " . join('/',
- (PoolBasePath(), PoolDir($source, $section), $source)) . "\n";
-
- print $tmpfile_handle "Files:\n";
-
- foreach my $fileref (@files) {
- print $tmpfile_handle " $fileref->{'MD5Sum'}";
- print $tmpfile_handle " $fileref->{'Size'}";
- print $tmpfile_handle " $fileref->{'Filename'}\n";
- }
-
- print $tmpfile_handle "\n";
-
- # All done
-
- close($tmpfile_handle);
- return $tmpfile_name;
-}
-
-# Dpkg_Info($file)
-#
-# Runs dpkg --info on $file, and returns a hash of relevant information.
-#
-# Internal support function for Generate_Package.
-
-sub Dpkg_Info {
- my($file) = @_;
- my %result;
-
- # Grab the info from dpkg --info.
-
- my @info = `/usr/bin/dpkg --info $file`;
- my $smashed = join('', @info);
-
- # Look for each of these fields in the info. All are single line values,
- # so the matching is fairly easy.
-
- foreach my $field (@Info_Fields, @Relationship_Fields) {
- if ($smashed =~ m/\n ${field}:\s+(\S.*)\n/) {
- $result{$field} = $1;
- }
- }
-
- # And, finally, grab the description.
-
- my $found = 0;
- foreach my $line (@info) {
- if ($found) {
- $line =~ s/^ //;
- $result{'Description'} .= $line;
- } elsif ($line =~ m/^ Description: (.+)/) {
- $result{'Description'} = "$1\n";
- $found = 1;
- }
- }
-
- return \%result;
-}
-
-# Install_List($archive, $component, $architecture, $listfile, @zfiles)
-#
-# Installs a distribution list file (from Generate_List), along with an
-# optional gzipped version of the same file (if $gzfile is defined).
-# Returns 1 on success, or 0 (and sets $Error) on failure.
-
-sub Install_List {
- use DebPool::Config qw(:vars);
- use DebPool::Dirs qw(:functions);
-
- my($archive, $component, $architecture, $listfile, @zfiles) = @_;
-
- my $dists_file_mode = $Options{'dists_file_mode'};
- my $inst_file = "$Options{'dists_dir'}/";
- $inst_file .= Archfile($archive, $component, $architecture, 0);
-
- # Now install the file(s) into the appropriate place(s).
-
- if (!Move_File($listfile, $inst_file, $dists_file_mode)) {
- $Error = "Couldn't install distribution file '$listfile' ";
- $Error .= "to '${inst_file}': ${DebPool::Util::Error}";
- return 0;
- }
-
- foreach my $zfile (@zfiles) {
- my ($ext) = $zfile =~ m{\.([^/]+)$};
- if (!Move_File($zfile, "${inst_file}.${ext}",
- $dists_file_mode)) {
- $Error = "Couldn't install compressed distribution file '$zfile' ";
- $Error .= "to '${inst_file}.${ext}': ${DebPool::Util::Error}";
- return 0;
- }
- }
-
- return 1;
-}
-
-# Guess_Section($changes_hashref)
-#
-# Attempt to guess the freeness section of a package based on the data
-# for the first file listed in the changes.
-
-sub Guess_Section {
- # Pull out the primary section from the changes data. Note that this is
- # a cheap hack, but it is mostly used when needing the pool directory
- # section, which is based solely on freeness-sections (main, contrib,
- # non-free).
-
- my($changes_hashref) = @_;
-
- my @changes_files = @{$changes_hashref->{'Files'}};
- return $changes_files[0]->{'Section'};
-}
-
-# Strip_Epoch($version)
-#
-# Strips any epoch data off of the version.
-
-sub Strip_Epoch {
- my($version) = @_;
-
- $version =~ s/^[^:]://;
- return $version;
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Release.pm b/share/DebPool/Release.pm
deleted file mode 100644
index 066e4dc..0000000
--- a/share/DebPool/Release.pm
+++ /dev/null
@@ -1,374 +0,0 @@
-package DebPool::Release;
-
-###
-#
-# DebPool::Release - Module for generating and installing Release files
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Release.pm 27 2004-11-07 03:06:59Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-use POSIX; # strftime
-use File::Temp qw(tempfile);
-
-# We need the Digest modules so that we can calculate the proper checksums.
-
-use Digest::MD5;
-use Digest::SHA;
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- &Generate_Release_Triple
- &Install_Release
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Generate_Release_Triple &Install_Release)],
- 'vars' => [qw()],
- );
-}
-
-### Exported package globals
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-# Magic filenames - these are files we want to include hashes for in a
-# Release file.
-
-my(@SigFiles) = (
- 'Packages',
- 'Sources',
- 'Packages.gz',
- 'Sources.gz',
- 'Packages.bz2',
- 'Sources.bz2',
-);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# Generate_Release_Triple($archive, $component, $architecture, $version)
-#
-# Generate a Release file for a specific dist/component/arch, in the
-# temp/working area, and return the filename.
-#
-# Returns undef (and sets $Error) on error.
-
-sub Generate_Release_Triple {
- use DebPool::Config qw(:vars);
- use DebPool::Dirs qw(:functions);
-
- my($archive, $component, $architecture, $version) = @_;
-
- my(@Checksums);
-
- # Before we bother to do much else, generate the MD5 and SHA1 checksums
- # we'll need later. This is mostly so that we can catch errors before
- # ever bothering to open a tempfile.
-
- # First, grab a list of files from the directory.
-
- my($dirpath) = "${Options{'dists_dir'}}/";
- $dirpath .= Archfile($archive, $component, $architecture, 1);
-
- if (!opendir(RELDIR, $dirpath)) {
- $Error = "Couldn't open directory '$dirpath'.";
- return;
- }
-
- my(@dirfiles) = readdir(RELDIR);
- close(RELDIR);
-
- # Now, for each file, generate MD5 and SHA1 checksums, and put them
- # into Checksums for later use (assuming it's a file we care about).
-
- foreach my $ck_file (@dirfiles) {
- if (0 == grep(/^$ck_file$/, @SigFiles)) { # We don't care about it.
- next;
- }
-
- # Grab the filesize from stat()
-
- my(@stat) = stat("${dirpath}/${ck_file}");
- my($size) = $stat[7];
-
- # Open the file and read in the contents. This could be a very
- # large amount of data, but unfortunately, both Digest routines
- # require the entire thing at once.
-
- if (!open($ck_fh, '<', "${dirpath}/${ck_file}")) {
- $Error = "Couldn't open file '${dirpath}/${ck_file}' for reading.";
- return;
- }
-
- my(@filetext) = <$ck_fh>;
- close($ck_fh);
-
- # Now calculate the checksums and put them into the hashes.
-
- my($md5) = Digest::MD5::md5_hex(@filetext);
- my($sha1) = Digest::SHA::sha1_hex(@filetext);
- my($sha256) = Digest::SHA::sha256_hex(@filetext);
-
- push @Checksums, {
- 'File' => $ck_file,
- 'Size' => $size,
- 'MD5' => $md5,
- 'SHA1' => $sha1,
- 'SHA256' => $sha256,
- };
- }
-
- # Open a secure tempfile, and write the headers to it.
-
- my($tmpfile_handle, $tmpfile_name) = tempfile();
-
- print $tmpfile_handle "Archive: $archive\n";
- print $tmpfile_handle "Component: $component\n";
- print $tmpfile_handle "Version: $version\n";
- print $tmpfile_handle "Origin: $Options{'release_origin'}\n";
- print $tmpfile_handle "Label: $Options{'release_label'}\n";
- print $tmpfile_handle "Architecture: $architecture\n";
-
- # If the archive (aka distribution) appears in release_noauto, print
- # the appropriate directive.
-
- if (0 != grep(/^$archive$/, @{$Options{'release_noauto'}})) {
- print $tmpfile_handle "NotAutomatic: yes\n";
- }
-
- print $tmpfile_handle "Description: $Options{'release_description'}\n";
-
- # Now print MD5 and SHA1 checksum lists.
-
- print $tmpfile_handle "MD5Sum:\n";
- foreach my $checksum (@Checksums) {
- printf $tmpfile_handle " %s %8d %s\n", $checksum->{'MD5'},
- $checksum->{'Size'}, $checksum->{'File'};
- }
-
- print $tmpfile_handle "SHA1:\n";
- foreach my $checksum (@Checksums) {
- printf $tmpfile_handle " %s %8d %s\n", $checksum->{'SHA1'},
- $checksum->{'Size'}, $checksum->{'File'};
- }
-
- print $tmpfile_handle "SHA256:\n";
- foreach my $checksum (@Checksums) {
- printf $tmpfile_handle " %s %8d %s\n", $checksum->{'SHA256'},
- $checksum->{'Size'}, $checksum->{'File'};
- }
-
- close($tmpfile_handle);
-
- return $tmpfile_name;
-}
-
-# Generate_Release_Dist($archive, $version, @files)
-#
-# Generate top-level Release file for a specific distribution, covering the
-# given files, in the temp/working area, and return the filename.
-#
-# Filenames in @files should be relative to <dists_dir>/<archive>, with no
-# leading slash (ie, main/binary-i386/Packages).
-#
-# Returns undef (and sets $Error) on error.
-
-sub Generate_Release_Dist {
- use DebPool::Config qw(:vars);
-
- my($archive) = shift(@_);
- my($version) = shift(@_);
- my(@files) = @_;
-
- my(@Checksums);
- my($dists_dir) = $Options{'dists_dir'};
-
- # Before we bother to do much else, generate the MD5 and SHA1 checksums
- # we'll need later. This is mostly so that we can catch errors before
- # ever bothering to open a tempfile.
-
- for my $file (@files) {
- my($fullfile) = "${dists_dir}/${archive}/${file}";
-
- # Now, for each file, generate MD5 and SHA1 checksums, and put them
- # into Checksums for later use (assuming it's a file we care about).
-
- my(@stat) = stat($fullfile);
- my($size) = $stat[7];
-
- if (!open($hash_fh, '<', $fullfile)) {
- $Error = "Couldn't open file '${fullfile} for reading.";
- return;
- }
- my(@filetext) = <$hash_fh>;
- close($hash_fh);
-
- # Now calculate the checksums and put them into the hashes.
-
- my($md5) = Digest::MD5::md5_hex(@filetext);
- my($sha1) = Digest::SHA::sha1_hex(@filetext);
- my($sha256) = Digest::SHA::sha256_hex(@filetext);
-
- push @Checksums, {
- 'File' => $file,
- 'Size' => $size,
- 'MD5' => $md5,
- 'SHA1' => $sha1,
- 'SHA256' => $sha256,
- };
- }
-
- # Open a secure tempfile, and set up some variables.
-
- my($tmpfile_handle, $tmpfile_name) = tempfile();
-
- my($now_822) = strftime('%a, %d %b %Y %H:%M:%S %Z', localtime());
- my(@archs) = grep(!/^source$/, @{$Options{'archs'}});
- my($suite) = $Options{'reverse_dists'}->{$archive};
-
- # Write the headers into the Release tempfile
-
- print $tmpfile_handle "Origin: ${Options{'release_origin'}}\n";
- print $tmpfile_handle "Label: ${Options{'release_label'}}\n";
- print $tmpfile_handle "Suite: ${suite}\n";
- print $tmpfile_handle "Codename: ${archive}\n";
- print $tmpfile_handle "Date: ${now_822}\n";
- print $tmpfile_handle "Architectures: " . join(' ', @archs) . "\n";
- print $tmpfile_handle "Components: " . join(' ', @{$Options{'sections'}}) . "\n";
- print $tmpfile_handle "Description: $Options{'release_description'}\n";
-
- # Now print MD5 and SHA1 checksum lists.
-
- print $tmpfile_handle "MD5Sum:\n";
- foreach my $file (@Checksums) {
- printf $tmpfile_handle " %s %8d %s\n", $file->{'MD5'},
- $file->{'Size'}, $file->{'File'};
- }
-
- print $tmpfile_handle "SHA1:\n";
- foreach my $file (@Checksums) {
- printf $tmpfile_handle " %s %8d %s\n", $file->{'SHA1'},
- $file->{'Size'}, $file->{'File'};
- }
-
- print $tmpfile_handle "SHA256:\n";
- foreach my $file (@Checksums) {
- printf $tmpfile_handle " %s %8d %s\n", $file->{'SHA256'},
- $file->{'Size'}, $file->{'File'};
- }
-
- close($tmpfile_handle);
-
- return $tmpfile_name;
-}
-
-# Install_Release($archive, $component, $architecture, $release, $signature)
-#
-# Installs a release file and an optional signature file to the
-# distribution directory specified by the ($archive, $component,
-# $architecture) triple, or $archive if $component and $architecture are
-# undefined. Returns 0 (and sets $Error) on failure, 1 on
-# success.
-
-sub Install_Release {
- use DebPool::Config qw(:vars);
- use DebPool::Util qw(:functions);
-
- my($archive, $component, $architecture, $release, $signature) = @_;
-
- my($dists_file_mode) = $Options{'dists_file_mode'};
-
- my($inst_dir);
- if (defined($architecture) && defined($component)) {
- $inst_dir = "${Options{'dists_dir'}}/";
- $inst_dir .= Archfile($archive, $component, $architecture, 1);
- } else {
- $inst_dir = "${Options{'dists_dir'}}/${archive}";
- }
-
- # Now install the file(s) into the appropriate place(s).
-
- if (!Move_File($release, "${inst_dir}/Release", $dists_file_mode)) {
- $Error = "Couldn't install Release file '${release}' to ";
- $Error .= "'${inst_dir}': ${DebPool::Util::Error}";
- return 0;
- }
-
- if (defined($signature) && !Move_File($signature, "${inst_dir}/Release.gpg",
- $dists_file_mode)) {
- $Error = "Couldn't install Signature file '${signature}' to ";
- $Error .= "'${inst_dir}': ${DebPool::Util::Error}";
- return 0;
- }
-
- return 1;
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Signal.pm b/share/DebPool/Signal.pm
deleted file mode 100644
index a8c0fe8..0000000
--- a/share/DebPool/Signal.pm
+++ /dev/null
@@ -1,144 +0,0 @@
-package DebPool::Signal;
-
-###
-#
-# DebPool::DB - Module for handling inter-process signals
-#
-# Copyright 2003-2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Signal.pm 27 2004-11-07 03:06:59Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-# We do logging, so we need this.
-
-use DebPool::Logging qw(:functions :facility :level);
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- $Signal_Caught
- %ComponentDB
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw()],
- 'vars' => [qw($Signal_Caught)],
- );
-}
-
-### Exported package globals
-
-# Boolean value indicating whether we have caught one of the signals that
-# normally trigger clean termination (SIGHUP, SIGINT, SIGPIPE, SIGTERM).
-
-our($Signal_Caught) = 0;
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# None
-
-### Special
-
-# The purpose of this module is to handle signals usefully; therefore, we
-# set up a basic term-signal handler that catches the 'ordinary termination
-# requested' class of signals, and bind it via sigtrap.
-
-sub Handle_SIGtermrequest {
- my($signal) = shift(@_);
-
- $Signal_Caught = 1;
- Log_Message("Caught signal " . $signal, LOG_GENERAL, LOG_INFO);
-}
-
-sub Handle_SIGHUP {
- Handle_SIGtermrequest('SIGHUP');
-}
-
-use sigtrap qw(handler Handle_SIGHUP HUP);
-
-sub Handle_SIGINT {
- Handle_SIGtermrequest('SIGINT');
-}
-
-use sigtrap qw(handler Handle_SIGINT INT);
-
-sub Handle_SIGPIPE {
- Handle_SIGtermrequest('SIGPIPE');
-}
-
-use sigtrap qw(handler Handle_SIGPIPE PIPE);
-
-sub Handle_SIGTERM {
- Handle_SIGtermrequest('SIGTERM');
-}
-
-use sigtrap qw(handler Handle_SIGTERM TERM);
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
diff --git a/share/DebPool/Util.pm b/share/DebPool/Util.pm
deleted file mode 100644
index 2f8daa6..0000000
--- a/share/DebPool/Util.pm
+++ /dev/null
@@ -1,129 +0,0 @@
-package DebPool::Util;
-
-###
-#
-# DebPool::Util - Module to contain various utility routines
-#
-# Copyright 2004 Joel Aelwyn. All rights reserved.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-# 1. Redistributions of source code must retain the above copyright
-# notice, this list of conditions and the following disclaimer.
-# 2. Redistributions in binary form must reproduce the above copyright
-# notice, this list of conditions and the following disclaimer in the
-# documentation and/or other materials provided with the distribution.
-# 3. Neither the name of the Author nor the names of any contributors
-# may be used to endorse or promote products derived from this software
-# without specific prior written permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
-# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
-# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-# SUCH DAMAGE.
-#
-# $Id: Util.pm 27 2004-11-07 03:06:59Z joel $
-#
-###
-
-# We use 'our', so we must have at least Perl 5.6
-
-require 5.006_000;
-
-# Always good ideas.
-
-use strict;
-use warnings;
-
-use File::Copy;
-
-### Module setup
-
-BEGIN {
- use Exporter ();
- our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
- # Version checking
- $VERSION = '0.1.5';
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- );
-
- @EXPORT_OK = qw(
- &Move_File
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Move_File)],
- 'vars' => [qw()],
- );
-}
-
-### Exported package globals
-
-# None
-
-### Non-exported package globals
-
-# Thread-safe? What's that? Package global error value. We don't export
-# this directly, because it would conflict with other modules.
-
-our($Error);
-
-### File lexicals
-
-# None
-
-### Constant functions
-
-# None
-
-### Meaningful functions
-
-# Move_File($orig, $new, $mode)
-#
-# Move an file from $orig to $new by copying, and set the file mode
-# of the new file according to the variables given.
-#
-# Returns 1 if successful, 0 if not (and sets $Error)
-
-sub Move_File {
- my($orig) = shift(@_);
- my($new) = shift(@_);
- my($mode) = shift(@_);
-
- if (!copy($orig, $new)) {
- $Error = $!;
- return 0;
- }
-
- if (!chmod($mode, $new)) {
- $Error = $!;
- return 0;
- }
-
- if (!unlink($orig)) {
- $Error = $!;
- return 0;
- }
-
- return 1;
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
--
1.5.5.3
More information about the Debpool-devel
mailing list