Subversion Repositories debpool

Compare Revisions

Ignore whitespace Rev 3 → Rev 4

/branches/magnus/trunk/examples/Config.pm
File deleted
/branches/magnus/trunk/LICENSE
File deleted
/branches/magnus/trunk/debian/README.User
File deleted
/branches/magnus/trunk/debian/debpool.docs
File deleted
/branches/magnus/trunk/debian/NEWS
File deleted
/branches/magnus/trunk/debian/README.GnuPG
File deleted
/branches/magnus/trunk/debian/README.Debian
File deleted
/branches/magnus/trunk/debian/debpool.manpages
File deleted
/branches/magnus/trunk/debian/control
File deleted
/branches/magnus/trunk/debian/compat
File deleted
/branches/magnus/trunk/debian/debpool.dirs
File deleted
/branches/magnus/trunk/debian/changelog
File deleted
/branches/magnus/trunk/debian/debpool.install
File deleted
/branches/magnus/trunk/debian/rules
File deleted
Property changes:
Deleted: svn:executable
Index: branches/magnus/trunk/debian/debpool.examples
===================================================================
--- branches/magnus/trunk/debian/debpool.examples (revision 3)
+++ branches/magnus/trunk/debian/debpool.examples (nonexistent)
@@ -1 +0,0 @@
-examples/Config.pm
Index: branches/magnus/trunk/debian/README.Why
===================================================================
--- branches/magnus/trunk/debian/README.Why (revision 3)
+++ branches/magnus/trunk/debian/README.Why (nonexistent)
@@ -1,33 +0,0 @@
-Why have yet another Debian package repository tool?
-
-* Most or all of the other tools require extensive non-core support.
-
- While many users may not find this problematic, those working on a new
- port, and trying to make it self-hosting, will often have a difficult
- time trying to get some of the more packages with a complex tree of
- Build-Dependancies (such as Python) to a point where they can be
- compiled. Conversely, a working shell, an installation of Perl, and
- a compiler are some of the first things that must be present, simply
- because so much of the rest of the system depends on these (and they are
- often available from another port or a non-Debian system).
-
- Therefore, I have attempted to keep the requirements for packages not
- found in the Debian core system (Essential packages, or those with
- Priority required) to an absolute minimum (ideally, 'none'), or at the
- very least, only require packages that can easily be compiled on a system
- with little more than a shell, perl, and a working C compiler.
-
- Note that some amount of significant functionality (such as Release
- files and signature checking) does depend on more complex packages (such
- as GnuPG or the perl Digest modules), which is why these are in the
- Recommends field; however, these functions that use these are niceties
- (if very useful ones), and an archive can operate without them, if
- necessary.
-
-* No other tool handles the new pool-style layout readily.
-
- As of this writing, none of the tools in Debian except for katie (part
- of the softare used to run the primary Debian archives) can handle a
- pool-style directory layout in any straightforward fashion, while setting
- up a full instance of katie requires significant support infrastructure
- (such as an SQL server, among other things).
Index: branches/magnus/trunk/debian/TODO
===================================================================
--- branches/magnus/trunk/debian/TODO (revision 3)
+++ branches/magnus/trunk/debian/TODO (nonexistent)
@@ -1,37 +0,0 @@
-Items which still need to be done:
-
-(general)
-
-* Support tools for manipulating metadata (which really means 'anything
- stored in database files').
-
-* Support rebuild-dbs (including invocation from rebuild-all)?
- - What can this do with stuff that has migrated between distributions?
-
-(for debian-installer support)
-
-* Handle udeb packages correctly (entries go into
- dists/<dist>/<section>/debian-installer/<binary>/Packages instead of
- dists/<dist>/<section>/<binary>/Packages)
-
-(for hooks)
-
-* Hooks
- - Installation
- - Rejection
- - Byhand (with some sort of requeue? Or "byhand MUST be missing"?)
-
-
-(for sane binary-all)
-
-* Support an external source for binary-all data (for example, snarfing it
- out of a Packages file from http.us.debian.org).
-
-(unknown)
-
-* Integrate with (or emulate) debsig-verify, to allow for verification of
- signed deb files (in addition to signed metadata).
-
-* Some way to double-parse values in $archive (allowing the equivalent of
- relative path references from archive_dir, so that changes are reflected
- in all other paths by default).
Index: branches/magnus/trunk/debian/copyright
===================================================================
--- branches/magnus/trunk/debian/copyright (revision 3)
+++ branches/magnus/trunk/debian/copyright (nonexistent)
@@ -1,34 +0,0 @@
-This is a Debian Native package.
-
-DebPool is Copyright © 2003-2004 by Joel Aelwyn (aka Joel Baker), and is
-released under the following license:
-
-#####
-#
-# 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.
-#
-#####
Index: branches/magnus/trunk/share/DebPool/Config.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/Config.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/Config.pm (nonexistent)
@@ -1,966 +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, though 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
-
-### 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') {
- require '/etc/debpool/Config.pm'; # System defaults
- }
-
- if (-r "$ENV{'HOME'}/.debpool/Config.pm") {
- require "$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 {
- require "$_[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) = @_;
- my($key);
-
- foreach $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($dummykey);
- my(@newarch);
-
- foreach $dummykey (@{$Options{'archs'}}) {
- $dummy{$dummykey} = 1;
- }
-
- $dummy{'all'} = undef;
- $dummy{'source'} = 1;
-
- foreach $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 $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 $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<compress_dists> = I<boolean>
-
-This determines whether or not compressed versions of the distribution
-files (Packages.gz, Sources.gz) are generated. Note that enabling this
-introduces a dependancy on gzip.
-
-=cut
-
-$Options{'compress_dists'} = 0;
-$OptionDefs{'compress_dists'} = 'compress_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' => 'woody',
- 'testing' => 'sarge',
- 'unstable' => 'sid',
- 'experimental' => 'experimental' }
-
-=cut
-
-$Options{'dists'} = {
- 'stable' => 'woody',
- 'testing' => 'sarge',
- '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:
-
-{
-}
-
-Exsample value:
-
-{ 'unstable-hostname' => 'unstable',
- 'testing-hostname' => 'sarge',
-}
-
-=cut
-
-$Options{'virtual_dists'} = {
-};
-
-=item B<sections> => I<array of section names>
-
-An arrayref pointing to an array which lists all sections we will accept
-packages for. Typically, these will be drawn from the set 'main',
-'contrib', 'non-free', 'experimental', 'alien', and 'local' (at least on
-the author's systems).
-
-Default value: [ 'main', 'contrib', 'non-free' ]
-
-=cut
-
-$Options{'sections'} = [ 'main', 'contrib', 'non-free' ];
-$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 all of the variables below are defined (release_origin, release_label,
-and release_description), Release files will be generated for each
-distribution directory.
-
-Please note that enabling Release files will introduce a dependancy on the
-packages 'libdigest-md5-perl' and 'libdigest-sha1-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',
-];
-
-=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.
-
-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 with 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: '/home/user/.gnupg'
-
-=cut
-
-$Options{'gpg_home'} = '/home/user/.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: '/home/user/.gnupg/passphrase';
-
-See also: sign_release, gpg_sign_key
-
-=cut
-
-$Options{'gpg_passfile'} = '/home/user/.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.
-
-=cut
-
-$Options{'log_file'} = '/home/user/.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<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. It should, of course, also not be used 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@debian.org>
-
-=cut
-
-# vim:set tabstop=4 expandtab:
Index: branches/magnus/trunk/share/DebPool/DB.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/DB.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/DB.pm (nonexistent)
@@ -1,262 +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
- &Set_Versions
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Open_Databases &Close_Databases &Get_Version
- &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'};
- my($dist);
-
- foreach $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 $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 {
- my($dist);
-
- foreach $dist (keys(%VersionDB)) {
- untie(%{$VersionDB{$dist}});
- }
-
- foreach $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) = @_;
-
- my($temp) = $VersionDB{$dist}->{$source};
- if (!defined($temp)) { return undef; }
-
- # 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 ($temp !~ m/\|/) {
- return $temp;
- }
-
- if ('meta' eq $package) {
- $temp =~ s/\|.*//;
- return $temp;
- } elsif ('source' eq $package) {
- return $VersionDB{$dist}->{"source_${source}"};
- } else {
- return $VersionDB{$dist}->{"binary_${source}_${package}"};
- }
-}
-
-# Set_Versions($dist, $source, $file_arrayref
-
-sub Set_Versions {
- my($dist, $source, $meta_version, $file_arrayref) = @_;
-
- my($oldbinlist) = $VersionDB{$dist}->{$source};
- if (defined($oldbinlist) && ($oldbinlist =~ m/\|/)) { # 0.2.2 or later
- $oldbinlist =~ s/.*\|//; # Strip meta version
- my(@oldbins) = split(/,/,$oldbinlist);
-
- my($oldbin);
- foreach $oldbin (@oldbins) {
- $VersionDB{$dist}->{"binary_${source}_${oldbin}"} = undef;
- }
-
- $VersionDB{$dist}->{"source_${source}"} = undef;
- $VersionDB{$dist}->{"${source}"} = undef;
- }
-
- # 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};
- my(@entries) = ();
-
- my($hashref);
- foreach $hashref (@files) {
- my($filename) = $hashref->{'Filename'};
-
- if ($filename =~ m/^([^_]+)_([^_]+)_.+\.deb/) {
- my($package) = $1;
- my($version) = $2;
-
- $VersionDB{$dist}->{"binary_${source}_${package}"} = $version;
- push(@entries, $package);
- } elsif ($filename =~ m/^[^_]+_([^_]+)\.dsc/) {
- my($version) = $1;
-
- $VersionDB{$dist}->{"source_${source}"} = $version;
- push(@entries, 'source');
- } # else skip
- }
-
- $VersionDB{$dist}->{$source} = "${meta_version}|" . join(',', @entries);
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
Index: branches/magnus/trunk/share/DebPool/Logging.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/Logging.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/Logging.pm (nonexistent)
@@ -1,172 +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).
-
- if (!open(LOG, ">>$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 strftime("%Y-%m-%d %H:%M:%S", localtime());
- print LOG " [$facility/$level] $msg\n";
- close(LOG);
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
Index: branches/magnus/trunk/share/DebPool/Gzip.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/Gzip.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/Gzip.pm (nonexistent)
@@ -1,164 +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
-use File::Temp qw(tempfile);
-
-# 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, 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_handle, $tmpfile_name) = tempfile();
-
- # Open the source file so that we have it available.
-
- if (!open(SOURCE, '<', $file)) {
- $Error = "Couldn't open source file '$file': $!";
- return undef;
- }
-
- # 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_handle);
-
- print GZIP_OUT <SOURCE>;
- close(GZIP_OUT);
- close(SOURCE);
-
- waitpid($child_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);
-
- print $tmpfile_handle <GZIP_IN>;
- close(GZIP_IN);
- close($tmpfile_handle);
-
- exit(0);
- }
-
- # And we're done
-
- return $tmpfile_name;
-}
-
-END {}
-
-1;
-
-__END__
-
-# vim:set tabstop=4 expandtab:
Index: branches/magnus/trunk/share/DebPool/Util.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/Util.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/Util.pm (nonexistent)
@@ -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:
Index: branches/magnus/trunk/share/DebPool/Signal.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/Signal.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/Signal.pm (nonexistent)
@@ -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:
Index: branches/magnus/trunk/share/DebPool/Packages.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/Packages.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/Packages.pm (nonexistent)
@@ -1,1253 +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) = @_;
- 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;
- }
-
- 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.
-
- if (!open(CHANGES, '<', $file)) {
- $Error = "Couldn't open changes file '$file': $!";
- return undef;
- }
-
- my(@changes) = <CHANGES>;
- chomp(@changes);
- @changes = Strip_GPG(@changes);
- close(CHANGES);
-
- # Go through each of the primary fields, stuffing it into the result
- # hash if we find it.
-
- my($field);
- foreach $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 (the only thing we grok).
-
- if (!defined($result{'Format'})) {
- Log_Message("No Format header found in changes file '$file'",
- LOG_PARSE, LOG_ERROR);
- $Error = 'No Format header found';
- return undef;
- } elsif ('1.7' ne $result{'Format'}) {
- Log_Message("Unrecognized Format version '$result{'Format'}'",
- LOG_PARSE, LOG_ERROR);
- $Error = 'Unrecognized Format version';
- return undef;
- }
-
- # Special case: Description. One-line entry, immediately after a line
- # with '^Description:'.
-
- my($count);
-
- for $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 $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 $count (0..$#changes) {
- if ($found) {
- if ($changes[$count] =~ m/^\s*$/) { # Blank line
- $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.
-
- if (!open(DSC, '<', $file)) {
- $Error = "Couldn't open dsc file '$file': $!";
- return undef;
- }
-
- my(@dsc) = <DSC>;
- chomp(@dsc);
- @dsc = Strip_GPG(@dsc);
- close(DSC);
-
- # Go through each of the primary fields, stuffing it into the result
- # hash if we find it.
-
- my($field);
- foreach $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 undef;
- } elsif ('1.0' ne $result{'Format'}) {
- Log_Message("Unrecognized Format version '$result{'Format'}'",
- LOG_PARSE, LOG_ERROR);
- $Error = 'Unrecognized Format version';
- return undef;
- }
-
- # 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 undef;
- }
- my($dsc_size) = $stat[7];
-
- push(@files, {
- 'Filename' => $dsc_leaf,
- 'MD5Sum' => $dsc_md5,
- 'Size' => $dsc_size,
- });
-
- for $count (0..$#dsc) {
- if ($found) {
- if ($dsc[$count] =~ m/^\s*$/) { # Blank line
- $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 undef;
- }
-
- my(@sources) = grep($ComponentDB{$distribution}->{$_} eq $section,
- keys(%{$ComponentDB{$distribution}}));
-
- my($tmpfile_handle, $tmpfile_name) = tempfile();
-
- my($source);
-
- # 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 $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(SRC, '<', "$target"));
-
- print $tmpfile_handle <SRC>;
- close(SRC);
- }
- } else {
- foreach $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 .= '.package';
-
- if (!open(PKG, '<', "$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;
- }
-
- # Playing around with the record separator ($/) to make this
- # easier.
-
- my($backup_RS) = $/;
- $/ = "";
-
- my(@entries) = <PKG>;
- close(PKG);
-
- $/ = $backup_RS;
-
- # Pare it down to the relevant entries, and print those out.
-
- @entries = grep(/\nArchitecture: ($arch|all)\n/, @entries);
- print $tmpfile_handle @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_dir) = join('/',
- ($pool_dir, PoolDir($pkg_name, $guess_section), $pkg_name));
-
- # Make sure the package directory exists (and is a directory!)
-
- if (! -e $pkg_dir) {
- if (!mkdir($pkg_dir)) {
- $Error = "Failed to mkdir '$pkg_dir': $!";
- return 0;
- }
- if (!chmod($Options{'pool_dir_mode'}, $pkg_dir)) {
- $Error = "Failed to chmod '$pkg_dir': $!";
- return 0;
- }
- } elsif (! -d $pkg_dir) {
- $Error = "Target '$pkg_dir' is not a directory.";
- return 0;
- }
-
- # Walk the File Hash, trying to install each listed file into the
- # pool directory.
-
- my($filehash);
-
- foreach $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_file) = Generate_Package($chg_hashref);
-
- if (!defined($pkg_file)) {
- $Error = "Failed to generate .package file: $Error";
- return undef;
- }
-
- my($target) = "$pkg_dir/${pkg_name}_" . Strip_Epoch($pkg_ver) . '.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 undef;
- }
-
- $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 $distribution (@{$distributions}) {
- Set_Versions($distribution, $pkg_name, $pkg_ver,
- $chg_hashref->{'Files'});
- $ComponentDB{$distribution}->{$pkg_name} = $component;
- }
-
- 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.
-
- my($filehash);
-
- foreach $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) = @_;
-
- 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 undef;
- }
- 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($file);
- my($unlinked) = 0;
- foreach $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 it if we recognize it as a valid version.
-
- my($matched) = 0;
- my($dist);
- foreach $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 $file (@changes) {
- $file =~ m/^[^_]+_([^_]+)_.+$/; # changes
- my($version) = $1;
-
- my($matched) = 0;
- my($dist);
- foreach $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) = @_;
- 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(@architectures) = @{$changes_data->{'Architecture'}};
- @architectures = grep(!/source/, @architectures); # Source is on it's own.
-
- my($package, $arch);
-
- foreach $package (@packages) {
- foreach $arch (@architectures) {
- # 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) = "${package}_.*_${arch}\\.deb";
- $filepat =~ s/\+/\\\+/;
-
- my($section) = Guess_Section($changes_data);
- my($pool) = join('/', (PoolDir($source, $section), $source));
-
- my($marker) = -1;
- my($count) = 0;
-
- # Step through each file, match against filename. Save matches
- # for later use.
-
- for $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).
-
- my($field);
- foreach $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);
- my($filehr);
- foreach $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";
- print $tmpfile_handle "Format: $dsc_data->{'Format'}\n";
- print $tmpfile_handle "Directory: " . join('/',
- (PoolBasePath(), PoolDir($source, $section), $source)) . "\n";
-
- print $tmpfile_handle "Files:\n";
-
- my($fileref);
- foreach $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.
-
- my($field);
-
- foreach $field (@Info_Fields, @Relationship_Fields) {
- if ($smashed =~ m/\n ${field}:\s+(\S.*)\n/) {
- $result{$field} = $1;
- }
- }
-
- # And, finally, grab the description.
-
- my($line);
- my($found) = 0;
- foreach $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, $gzfile)
-#
-# 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, $gzfile) = @_;
-
- 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;
- }
-
- if (defined($gzfile) && !Move_File($gzfile, "${inst_file}.gz",
- $dists_file_mode)) {
- $Error = "Couldn't install gzipped distribution file '$gzfile' ";
- $Error .= "to '${inst_file}.gz': ${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:
Index: branches/magnus/trunk/share/DebPool/GnuPG.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/GnuPG.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/GnuPG.pm (nonexistent)
@@ -1,305 +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 qw(tempfile);
-
-# We need these 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(
- &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) = ("--homedir=$Options{'gpg_home'}");
- push (@args, '--no-default-keyring', '--logger-fd=1');
-
- my($keyring);
-
- foreach $keyring (@{$Options{'gpg_keyrings'}}) {
- push(@args, "--keyring=$keyring");
- }
-
- push(@args, '--verify');
-
- if (defined($signature)) {
- push(@args, $signature);
- }
-
- push(@args, $file);
-
- my($pid) = IPC::Open2::open2(*GPG_IN, *GPG_OUT, $Options{'gpg_bin'}, @args);
- close(GPG_IN); # No input
- close(GPG_OUT); # Don't care about output, really, either
-
- waitpid($pid,0); # No flags, just wait.
- my($sysret) = WEXITSTATUS($?);
-
- if (0 != $sysret) { # Failure
- my($msg) = "Failed signature check on '$file' ";
- if (defined($signature)) {
- $msg .= "(signature file '$signature')";
- } else {
- $msg .= "(internal signature)";
- }
- Log_Message($msg, LOG_GPG, LOG_WARNING);
-
- return 0;
- }
-
- 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) = @_;
-
- # Check that we have everything we need
-
- if (!defined($Options{'gpg_sign_key'})) {
- $Error = "No GPG signature key enabled";
- return undef;
- }
-
- if (!defined($Options{'gpg_passfile'})) {
- $Error = "No GPG passphrase file enabled";
- return undef;
- }
-
- # Open a secure tempfile to write the signature to
-
- my($tmpfile_handle, $tmpfile_name) = tempfile();
-
- # Open the Release file and grab the data from it
-
- if (!open(RELEASE, '<', $release_file)) {
- $Error = "Couldn't open Release file '$release_file': $!";
- return undef;
- }
- my(@release_text) = <RELEASE>;
- close(RELEASE);
-
- # Open the passphrase file and grab the data from it
-
- if (!open(PASS, '<', $Options{'gpg_passfile'})) {
- $Error = "Couldn't open passphrase file '$Options{'gpg_passfile'}': $!";
- return undef;
- }
- my($passphrase) = <PASS>; # This is only safe because we don't care.
- close(PASS);
-
- # We are go for main engine start
-
- my(@args) = ("--homedir=$Options{'gpg_home'}");
- push(@args, "--default-key=$Options{'gpg_sign_key'}");
- push(@args, '--passphrase-fd=0', '--batch', '--no-tty', '--detach-sign');
- push(@args, '--armor', '--output=-');
-
- my($gnupg_pid) = IPC::Open2::open2(*GPG_IN, *GPG_OUT, $Options{'gpg_bin'}, @args);
-
- my($child_pid);
- my(@signature);
- if ($child_pid = fork) { # In the parent
- # Close filehandles used by the child.
-
- close(GPG_IN);
- close($tmpfile_handle);
-
- # Send all the data to GnuPG
-
- print GPG_OUT $passphrase;
- print GPG_OUT @release_text;
- close(GPG_OUT);
-
- waitpid($child_pid, 0);
- } else { # In the child - we hope
- if (!defined($child_pid)) {
- die "Couldn't fork: $!\n";
- }
-
- # Close filehandle used by the parent.
-
- close(GPG_OUT);
-
- # And read back the results
-
- @signature = <GPG_IN>;
- close(GPG_IN);
-
- # Finally, print the results to the tempfile
-
- print $tmpfile_handle @signature;
- close($tmpfile_handle);
-
- exit(0);
- }
-
-
- # And we're done
-
- return $tmpfile_name;
-}
-
-# 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($count);
- my($header, $firstblank, $sigstart, $sigend);
-
- for $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:
Index: branches/magnus/trunk/share/DebPool/Release.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/Release.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/Release.pm (nonexistent)
@@ -1,357 +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::SHA1;
-
-### 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',
-);
-
-### 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 undef;
- }
-
- 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).
-
- my($ck_file);
-
- foreach $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_FILE, '<', "${dirpath}/${ck_file}")) {
- $Error = "Couldn't open file '${dirpath}/${ck_file}' for reading.";
- return undef;
- }
-
- my(@filetext) = <CK_FILE>;
- close(CK_FILE);
-
- # Now calculate the checksums and put them into the hashes.
-
- my($md5) = Digest::MD5::md5_hex(@filetext);
- my($sha1) = Digest::SHA1::sha1_hex(@filetext);
-
- $Checksums{$ck_file} = {
- 'Size' => $size,
- 'MD5' => $md5,
- 'SHA1' => $sha1,
- };
- }
-
- # 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 $ck_file (keys(%Checksums)) {
- printf $tmpfile_handle " %s %8d %s\n", $Checksums{$ck_file}->{'MD5'},
- $Checksums{$ck_file}->{'Size'}, $ck_file;
- }
-
- print $tmpfile_handle "SHA1:\n";
- foreach $ck_file (keys(%Checksums)) {
- printf $tmpfile_handle " %s %8d %s\n", $Checksums{$ck_file}->{'SHA1'},
- $Checksums{$ck_file}->{'Size'}, $ck_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.
-
- my($file);
- for $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_FILE, '<', $fullfile)) {
- $Error = "Couldn't open file '${fullfile} for reading.";
- return undef;
- }
- my(@filetext) = <HASH_FILE>;
- close(HASH_FILE);
-
- # Now calculate the checksums and put them into the hashes.
-
- my($md5) = Digest::MD5::md5_hex(@filetext);
- my($sha1) = Digest::SHA1::sha1_hex(@filetext);
-
- $Checksums{$file} = {
- 'Size' => $size,
- 'MD5' => $md5,
- 'SHA1' => $sha1,
- };
- }
-
- # 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 $file (keys(%Checksums)) {
- printf $tmpfile_handle " %s %8d %s\n", $Checksums{$file}->{'MD5'},
- $Checksums{$file}->{'Size'}, $file;
- }
-
- print $tmpfile_handle "SHA1:\n";
- foreach $file (keys(%Checksums)) {
- printf $tmpfile_handle " %s %8d %s\n", $Checksums{$file}->{'SHA1'},
- $Checksums{$file}->{'Size'}, $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:
Index: branches/magnus/trunk/share/DebPool/Dirs.pm
===================================================================
--- branches/magnus/trunk/share/DebPool/Dirs.pm (revision 3)
+++ branches/magnus/trunk/share/DebPool/Dirs.pm (nonexistent)
@@ -1,457 +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
- &Monitor_Incoming
- &PoolBasePath
- &PoolDir
- &Scan_Changes
- &Scan_All
- &Strip_Subsection
- );
-
- %EXPORT_TAGS = (
- 'functions' => [qw(&Archfile &Create_Tree &Monitor_Incoming
- &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);
-
-### 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.
-
- my($dist);
- foreach $dist (@{$Options{'realdists'}}) {
- if (!Tree_Mkdir("$dists_dir/$dist", $dists_dir_mode)) {
- return 0;
- }
-
- my($section);
- foreach $section (@{$Options{'sections'}}) {
- if (!Tree_Mkdir("$dists_dir/$dist/$section", $dists_dir_mode)) {
- return 0;
- }
-
- my($arch);
- foreach $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 $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...
-
- my($section);
- foreach $section (@{$Options{'sections'}}) {
- if (!Tree_Mkdir("$pool_dir/$section", $pool_dir_mode)) {
- return 0;
- }
-
- my($letter);
- foreach $letter ('a' .. 'z') {
- if (!Tree_Mkdir("$pool_dir/$section/$letter", $pool_dir_mode)) {
- return 0;
- }
- if (!Tree_Mkdir("$pool_dir/$section/lib$letter", $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.
-#
-# Internal support function for Create_Tree
-
-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 undef;
- }
-
- # 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 undef;
- }
-
- my($direntry);
- my(@entries) = grep(!/^\./, readdir(DIR));
-
- my(@return);
-
- foreach $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 undef;
- }
-
- # I'd like to use map(), but Perl makes stooopid guesses.
-
- my($entry);
-
- foreach $entry (@{$recurse}) {
- push(@return, "$direntry/$entry");
- }
- }
- }
-
- return \@return;
-}
-
-# Monitor_Incoming()
-#
-# Monitors the incoming directory, looping until the directory is updated.
-# Returns 1 on success, 0 on failure (and sets $Error).
-
-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 1;
- }
-
- my(@stat) = stat($Options{'incoming_dir'});
- if (!@stat) {
- $Error = "Couldn't stat incoming_dir '$Options{'incoming_dir'}'";
- return 0;
- }
- 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 0;
- }
- } until (($stat[9] != $mtime) || ($DebPool::Signal::Signal_Caught));
-
- return 1;
-}
-
-# 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';
- }
-
- my($check_section);
- foreach $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:
Index: branches/magnus/trunk/bin/debpool
===================================================================
--- branches/magnus/trunk/bin/debpool (revision 3)
+++ branches/magnus/trunk/bin/debpool (nonexistent)
@@ -1,664 +0,0 @@
-#! /usr/bin/perl -w
-
-#####
-#
-# Copyright 2003-2004 Joel Baker. 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: debpool 54 2005-02-21 21:48:29Z joel $
-#
-#####
-
-# 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;
-use warnings;
-
-use POSIX; # This gets us strftime.
-
-# First things first - figure out how we need to be configured.
-
-use Getopt::Long qw(:config pass_through);
-use DebPool::Config qw(:functions :vars);
-
-# 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.
-
-my($config);
-
-foreach $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();
-
-# Okay. We're more or less ready to go. First, load some modules that we
-# know we'll be calling.
-
-use DebPool::Dirs qw(:functions :vars); # Directory management
-use DebPool::DB qw(:functions :vars); # Various databases
-use DebPool::GnuPG qw(:functions :vars); # GnuPG interaction routines
-use DebPool::Gzip qw(:functions :vars); # Gzip interaction routines
-use DebPool::Logging qw(:functions :facility :level); # Logging routines
-use DebPool::Packages qw(:functions :vars); # Distribution databases
-use DebPool::Signal qw(:functions :vars); # Handle signals
-
-# Before we do anything else, let's find out if we need to act as a daemon,
-# and if so, whether we can manage to pull it off.
-
-if ($Options{'daemon'}) {
- Log_Message("Trying to enter daemon mode.", LOG_GENERAL, LOG_DEBUG);
-
- require Proc::Daemon;
- Proc::Daemon::Init();
-
- Log_Message("Now running as a daemon.", LOG_GENERAL, LOG_DEBUG);
-}
-
-# Create the directory tree. This is clean even it it already exists,
-# so we can do it every time we start up. I believe the fancy word is
-# 'idempotent'. We do this before grabbing a lockfile because it should
-# never screw anything up, even if run multiple times at once, and our
-# lockfile may be (probably is, in fact) in one of these places.
-
-if (!Create_Tree()) {
- my($msg) = "Couldn't create directory tree: $DebPool::Dirs::Error";
- Log_Message($msg, LOG_GENERAL, LOG_FATAL);
- die "$msg\n";
-}
-
-# Obtain a lockfile. We should never run more than one occurance; it's too
-# likely that we'd step on our own toes.
-
-if (!sysopen(LOCK_FILE, $Options{'lock_file'}, O_WRONLY|O_CREAT|O_EXCL, 0644)) {
- my($msg) = "Couldn't obtain lockfile '$Options{'lock_file'}'; ";
-
- if (open(LOCK_FILE, '<', $Options{'lock_file'}) &&
- (my($pid) = <LOCK_FILE>)) {
- chomp($pid);
- $msg .= "(PID $pid)\n";
- } else {
- $msg .= "(unable to read PID)\n";
- }
-
- die $msg;
-} else { # Do something useful - like put our PID into the file.
- print LOCK_FILE "$$\n";
- close(LOCK_FILE);
-}
-
-# Start the main loop. We use a do/until loop so that we always fire off at
-# least once.
-
-MAIN_LOOP: do {
-
-Log_Message("Starting processing run", LOG_GENERAL, LOG_DEBUG);
-
-# First off, open up our databases. We do this each time through the loop,
-# so that they get flushed periodically if we're in daemon mode.
-
-Open_Databases();
-
-# This keeps track of what distributions need to have their Packages and
-# Sources files rebuilt. We force it to be 'everything' if the user has
-# requested a rebuild (normally from the command line).
-
-my(%rebuild) = ();
-
-if ($Options{'rebuild-files'}) {
- my($dist);
- foreach $dist (@{$Options{'realdists'}}) {
- $rebuild{$dist} = 1;
- }
-}
-
-# Check for any changes files in the incoming directory.
-
-my(@changefiles) = Scan_Changes($Options{'incoming_dir'});
-
-# Go through each of the changes files we found, and process it. This is the
-# heart of things.
-
-my($changefile);
-
-foreach $changefile (@changefiles) {
- Log_Message("Processing changefile '$changefile'", LOG_GENERAL, LOG_INFO);
-
- # .dsc = .changes, minus the part after the last _, plus .dsc
-
- my(@parts) = split(/_/, $changefile);
- pop(@parts);
- my($dscfile) = join('_', @parts) . '.dsc';
-
- my($changes_data) = Parse_Changes("$Options{'incoming_dir'}/$changefile");
- if (!defined($changes_data)) {
- Log_Message("Failure parsing changes file '$changefile': " .
- $DebPool::Packages::Error, LOG_GENERAL, LOG_ERROR);
- next;
- }
-
- my($with_source) = undef; # Upload with or without source?
- my($temp);
-
- for $temp (@{$changes_data->{'Architecture'}}) {
- if ('source' eq $temp) {
- $with_source = 1;
- }
- }
-
- my($has_orig) = undef; # Has an orig tarball?
- my($filehr);
-
- foreach $filehr (@{$changes_data->{'Files'}}) {
- if ($filehr->{'Filename'} =~ /orig\.tar\.gz/) {
- $has_orig = 1;
- }
- }
-
- my($dsc_data) = Parse_DSC("$Options{'incoming_dir'}/$dscfile");
- if ($with_source && !defined($dsc_data)) {
- Log_Message("Failure parsing dsc file '$dscfile': " .
- $DebPool::Packages::Error, LOG_GENERAL, LOG_ERROR);
- next;
- }
-
- my($package) = $changes_data->{'Source'};
- my($version) = $changes_data->{'Version'};
-
- if ($Options{'require_sigs'}) {
- # First, check the changefile signature
-
- if (!Check_Signature("$Options{'incoming_dir'}/$changefile")) {
- Reject_Package($changefile, $changes_data);
- Log_Message("GPG signature failure in changes file '$changefile'",
- LOG_REJECT, LOG_ERROR);
- next;
- } else {
- Log_Message("Successful changes signature: '$changefile'",
- LOG_GPG, LOG_DEBUG);
- }
-
- # Now check the dscfile signature
-
- if ($with_source && !Check_Signature("$Options{'incoming_dir'}/$dscfile")) {
- Reject_Package($changefile, $changes_data);
- Log_Message("GPG signature failure in dsc file '$dscfile'",
- LOG_REJECT, LOG_ERROR);
- next;
- } else {
- Log_Message("Successful dsc signature: '$dscfile'",
- LOG_GPG, LOG_DEBUG);
- }
- }
-
- # Verify MD5 checksums on all files.
-
- my($valid) = 1;
-
- foreach $filehr (@{$changes_data->{'Files'}}) {
- if (!(Verify_MD5("$Options{'incoming_dir'}/$filehr->{'Filename'}",
- $filehr->{'MD5Sum'}))) {
- $valid = undef;
- }
- }
-
- if (!$valid) {
- Reject_Package($changefile, $changes_data);
-
- my($msg) = "MD5 checksum failure in changes file '$changefile'";
- Log_Message($msg, LOG_REJECT, LOG_ERROR);
- next;
- }
-
- $valid = 1;
- my($rejected) = undef;
-
- if ($with_source) {
- foreach $filehr (@{$dsc_data->{'Files'}}) {
- # A bit of a special case here; if the Changes file lists an
- # orig tarball, we must *not* have one for that version in the
- # pool. If it doesn't, then we *must* have one. In either case,
- # as long as it's in the right place we use that file for the
- # MD5Sum check when the file is listed in the DSC.
-
- my($file) = $filehr->{'Filename'};
-
- if ($file =~ /orig\.tar\.gz/) {
- my($section) = Guess_Section($changes_data);
- my($pkg_pooldir) = join('/',
- ($Options{'pool_dir'}, PoolDir($package, $section),
- $package));
-
- if ($has_orig) { # Orig tarball uploaded
- if (-e "$pkg_pooldir/$file") {
- Reject_Package($changefile, $changes_data);
-
- my($msg) = "Duplicate orig tarball '$file'";
- Log_Message($msg, LOG_REJECT, LOG_ERROR);
-
- $rejected = 1;
- last; # Don't check other files, we just rejected
- } elsif (!(-e "$Options{'incoming_dir'}/$file")) {
- Reject_Package($changefile, $changes_data);
-
- my($msg) = "Missing orig tarball '$file'";
- Log_Message($msg, LOG_REJECT, LOG_ERROR);
-
- $rejected = 1;
- last; # Don't check other files, we just rejected
- } else {
- $file = "$Options{'incoming_dir'}/$file";
- }
- } else { # Orig tarball in pool - we hope
- if (!(-e "$pkg_pooldir/$file")) {
- Reject_Package($changefile, $changes_data);
-
- my($msg) = "Missing orig tarball '$file'";
- Log_Message($msg, LOG_REJECT, LOG_ERROR);
-
- $rejected = 1;
- last; # Don't check other files, we just rejected
- } else {
- $file = "$pkg_pooldir/$file";
- }
- }
- } else { # Not an orig tarball - must be in upload
- $file = "$Options{'incoming_dir'}/$file";
- }
-
- # Whatever it is, it must also pass the MD5 checksum test.
-
- if (!(Verify_MD5($file, $filehr->{'MD5Sum'}))) {
- $valid = undef;
- last; # Don't check other files, we already failed
- }
- }
- }
-
- next if ($rejected); # Reject message already logged, go to next package.
-
- if (!$valid) {
- Reject_Package($changefile, $changes_data);
-
- my($msg) = "MD5 checksum failure in dsc file '$dscfile'";
- Log_Message($msg, LOG_REJECT, LOG_ERROR);
- next;
- }
-
- # Go through each distribution in the changes file, and decide whether
- # the package is valid for that distribution.
-
- my($distribution, $realdist);
- my(@valid_dists);
-
- foreach $distribution (@{$changes_data->{'Distribution'}}) {
- $realdist = $distribution;
-
- if (defined($Options{'virtual_dists'}->{$realdist})) {
- $realdist = $Options{'virtual_dists'}->{$realdist};
- }
-
- if (defined($Options{'dists'}->{$realdist})) {
- $realdist = $Options{'dists'}->{$realdist};
- }
-
- if (!defined($realdist)) {
- Log_Message("Distribution $distribution does not exist",
- LOG_INSTALL, LOG_ERROR);
- next;
- }
-
- my($allow) = Allow_Version($package, $version, $realdist);
-
- if (!defined($allow)) {
- Log_Message("Version check for $version failed: " .
- $DebPool::Packages::Error, LOG_INSTALL, LOG_ERROR);
- next;
- }
-
- if (!$allow) {
- Log_Message("Cannot install version $version of $package to " .
- "$realdist", LOG_INSTALL, LOG_WARNING);
- next;
- }
-
- # It's valid. Put it in the list.
-
- push(@valid_dists, $realdist);
- }
-
- if (-1 == $#valid_dists) {
- Reject_Package($changefile, $changes_data);
- Log_Message("No valid distributions for version $version of $package",
- LOG_REJECT, LOG_ERROR);
- next;
- }
-
- # Install the package
-
- if (Install_Package($changefile, $changes_data, $dscfile, $dsc_data, \@valid_dists)) {
- my($dist);
- foreach $dist (@valid_dists) {
- $rebuild{$dist} = 1;
- }
-
- my($msg) = "Installed $package ($version) to ";
- $msg .= "distribution(s): " . join(', ', @valid_dists);
- Log_Message($msg, LOG_INSTALL, LOG_INFO);
- } else {
- # Something is very, very wrong.
- Log_Message("Couldn't install package '$package': " .
- $DebPool::Packages::Error, LOG_INSTALL, LOG_FATAL);
- Close_Databases();
- unlink($Options{'lock_file'}); # Release our lock
- die "Couldn't install package '$package'\n";
- }
-
- # And, now that that's done, audit the package area in the pool to get
- # rid of crufty, obsolete versions.
-
- Audit_Package($package, $changes_data);
-}
-
-# Regenerate {Packages,Sources}{,.gz} for distributions which need it. Also
-# rebuild Release files that need it, if we're doing them.
-
-my($dist, $section);
-
-foreach $dist (keys(%rebuild)) {
- my(@rel_filelist) = ();
- foreach $section (@{$Options{'sections'}}) {
- my(@archs) = @{$Options{'archs'}};
- @archs = grep(!/^all$/, @archs); # We don't build binary-all files.
-
- my($arch);
-
-ARCH_LOOP:
- foreach $arch (@{$Options{'archs'}}) {
- # We cheat, and use @triple for dist/section/arch inputs.
- # Perl lets us get away with this. I'd care, except that Perl
- # prototyping isn't, so it's useless to not do this.
-
- my(@triple) = ($dist, $section, $arch);
-
- # Generate a Packages/Sources file.
-
- my($file) = Generate_List(@triple);
-
- if (!defined($file)) {
- my($msg) = "Couldn't create list for $dist/$section/${arch}: ";
- $msg .= $DebPool::Packages::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
-
- next;
- }
-
- # If we're compressing distribution files, do that here.
-
- my($gzfile);
- if ($Options{'compress_dists'}) {
- $gzfile = Gzip_File($file);
-
- if (!defined($gzfile)) {
- my($msg) = "Couldn't create compressed file: ";
- $msg .= $DebPool::Gzip::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
-
- unlink($file);
- next;
- }
- }
-
- # If we're doing Release files, now is the time for triples.
-
- my($relfile);
- my($sigfile);
-
- if ($Options{'do_release'}) {
- require DebPool::Release;
-
- # Release versions are YYYY.MM.DD.HH.MM.SS (GMT) by default.
-
- my($release_version) = strftime('%Y.%m.%d.%H.%M.%S', gmtime());
- $relfile = DebPool::Release::Generate_Release_Triple(
- @triple, $release_version);
-
- if (!defined($relfile)) {
- my($msg) = "Couldn't create Release file: ";
- $msg .= $DebPool::Release::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
-
- unlink($file);
- if (defined($gzfile)) {
- unlink($gzfile);
- }
- next;
- }
-
- if ($Options{'sign_release'}) {
- $sigfile = Sign_Release($relfile);
-
- if (!defined($sigfile)) {
- my($msg) = "Couldn't create Release signature file: ";
- $msg .= $DebPool::GnuPG::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
-
- unlink($file);
-
- if (defined($gzfile)) {
- unlink($gzfile);
- }
-
- if (defined($relfile)) {
- unlink($relfile);
- }
-
- next;
- }
- }
- }
-
- # Install {Packages,Sources}{,.gz}
-
- if (!Install_List(@triple, $file, $gzfile)) {
-
- my($msg) = "Couldn't install distribution files for ";
- $msg .= "$dist/$section/${arch}: " . $DebPool::Packages::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
-
- if (-e $file) {
- unlink($file);
- }
-
- if (defined($gzfile) && -e $gzfile) {
- unlink($gzfile);
- }
-
- if (defined($relfile) && -e $relfile) {
- unlink($relfile);
- }
-
- if (defined($sigfile) && -e $sigfile) {
- unlink($sigfile);
- }
-
- next;
- }
-
- # Install Release{,.gpg}
-
- if (defined($relfile) &&
- !DebPool::Release::Install_Release(@triple, $relfile, $sigfile)) {
-
- my($msg) = "Couldn't install release files for ";
- $msg .= "$dist/$section/${arch}: " . $DebPool::Release::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
-
- if (-e $relfile) {
- unlink($relfile);
- }
-
- if (defined($sigfile) && -e $sigfile) {
- unlink($sigfile);
- }
-
- next;
- }
-
- my($pushfile) = Archfile(@triple, 0);
- $pushfile =~ s/${dist}\///;
- push(@rel_filelist, $pushfile);
-
- if (defined($gzfile)) {
- push(@rel_filelist, $pushfile . '.gz');
- }
-
- if (defined($relfile)) {
- $pushfile = Archfile(@triple, 1);
- $pushfile =~ s/${dist}\///;
- $pushfile .= '/Release';
- push(@rel_filelist, $pushfile);
-
- if (defined($sigfile)) {
- push(@rel_filelist, $pushfile . '.gpg');
- }
- }
- }
- }
-
- # If we're doing Release files, now is the time for the general dist one.
-
- my($relfile);
- my($sigfile);
-
- if ($Options{'do_release'}) {
- require DebPool::Release;
-
- # Release versions are YYYY.MM.DD.HH.MM.SS (GMT) by default.
-
- my($release_version) = strftime('%Y.%m.%d.%H.%M.%S', gmtime());
- $relfile = DebPool::Release::Generate_Release_Dist(
- $dist, $release_version, @rel_filelist);
-
- if (!defined($relfile)) {
- my($msg) = "Couldn't create Release file: ";
- $msg .= $DebPool::Release::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
- } else {
- if ($Options{'sign_release'}) {
- $sigfile = Sign_Release($relfile);
-
- if (!defined($sigfile)) {
- my($msg) = "Couldn't create Release signature file: ";
- $msg .= $DebPool::GnuPG::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
- unlink($relfile);
- $relfile = undef;
- }
- }
- }
- }
-
- # Install Release{,.gpg}
-
- if (defined($relfile) &&
- !DebPool::Release::Install_Release($dist, undef, undef,
- $relfile, $sigfile)) {
- my($msg) = "Couldn't install release files for ";
- $msg .= "${dist}: " . $DebPool::Release::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
-
- if (-e $relfile) {
- unlink($relfile);
- }
-
- if (defined($sigfile) && -e $sigfile) {
- unlink($sigfile);
- }
- }
-}
-
-# Close out the databases, ensuring that they're flushed to disk. We'll
-# just reopen them in a moment, if we're in daemon mode; it's still good to
-# write them out.
-
-Close_Databases();
-
-# This will short-circuit if we catch a signal while sleeping.
-
-if ($Options{'daemon'}) {
- Log_Message("Waiting on changes to incoming dir.", LOG_GENERAL, LOG_DEBUG);
-
- if (!Monitor_Incoming()) {
- my($msg) = "Error in Monitor_Incoming: " . $DebPool::Dirs::Error;
- Log_Message($msg, LOG_GENERAL, LOG_ERROR);
- }
-}
-
-# End of MAIN_LOOP; we loop back until either we're not in daemon mode
-# (that is, we've been told to single-pass), or until we catch a signal.
-
-} until ((!$Options{'daemon'}) || $Signal_Caught);
-
-# Release our lock
-
-unlink($Options{'lock_file'});
-
-Log_Message("Exiting.", LOG_GENERAL, LOG_DEBUG);
-
-exit(0);
-
-__END__
-
-# vim:set tabstop=4 expandtab:
/branches/magnus/trunk/bin/debpool
Property changes:
Deleted: svn:executable
Index: branches/magnus/trunk/man/man1/debpool.1
===================================================================
--- branches/magnus/trunk/man/man1/debpool.1 (revision 3)
+++ branches/magnus/trunk/man/man1/debpool.1 (nonexistent)
@@ -1,60 +0,0 @@
-'\" t
-.\" ** The above line should force tbl to be a preprocessor **
-.\" Man page for debpool
-.\"
-.\" Copyright 2003-2004 Joel Aelwyn
-.\"
-.\" $Id: debpool.1 27 2004-11-07 03:06:59Z joel $
-.\"
-.TH debpool 1 "07 October 2003" "0.1.5" "Debian Pool Archive Manager"
-.SH NAME
-debpool \- pool-based Debian package archive manager
-.SH SYNOPSIS
-.\" The general command line
-.B debpool
-[\|
-.I options
-\|]
-.SH DESCRIPTION
-.B debpool
-is a utility for managing pool-based archives of Debian packages. It
-can be run by individual users, and/or under a dedicated system user
-configuration.
-.SH EXAMPLES
-None
-.SH OVERVIEW
-None
-.SH DEFAULTS
-See the
-.BR DebPool::Config(5)
-manpage for details on configuration option defaults.
-.SH OPTIONS
-See the
-.BR DebPool::Config(5)
-manpage for details on all configuration options.
-.SH "EXIT STATUS"
-.TP
-.B 0
-Successful program execution
-.TP
-.B 1
-Failure of any kind
-.SH ENVIRONMENT
-Nothing useful
-.SH FILES
-.TP
-.I /usr/share/debpool/perl5/DebPool/Config.pm
-Program (internal) defaults file.
-.TP
-.I /etc/debpool/Config.pm
-System defaults file.
-.TP
-.I $HOME/.debpool/Config.pm
-User defaults file.
-.SH SEE ALSO
-.BR DebPool::Config(5)
-.SH BUGS
-The entire manpage sucks, because the author hasn't taken the time
-to make it look nicer, and most of the important information really
-lives in the pod2man output for the configuration file (also known as
-DebPool::Config(5)).
Index: branches/magnus/trunk/man/man5/DebPool::Config.5
===================================================================
--- branches/magnus/trunk/man/man5/DebPool::Config.5 (revision 3)
+++ branches/magnus/trunk/man/man5/DebPool::Config.5 (nonexistent)
@@ -1,531 +0,0 @@
-.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.14
-.\"
-.\" Standard preamble:
-.\" ========================================================================
-.de Sh \" Subsection heading
-.br
-.if t .Sp
-.ne 5
-.PP
-\fB\\$1\fR
-.PP
-..
-.de Sp \" Vertical space (when we can't use .PP)
-.if t .sp .5v
-.if n .sp
-..
-.de Vb \" Begin verbatim text
-.ft CW
-.nf
-.ne \\$1
-..
-.de Ve \" End verbatim text
-.ft R
-.fi
-..
-.\" Set up some character translations and predefined strings. \*(-- will
-.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
-.\" double quote, and \*(R" will give a right double quote. | will give a
-.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to
-.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C'
-.\" expand to `' in nroff, nothing in troff, for use with C<>.
-.tr \(*W-|\(bv\*(Tr
-.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
-.ie n \{\
-. ds -- \(*W-
-. ds PI pi
-. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
-. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
-. ds L" ""
-. ds R" ""
-. ds C` ""
-. ds C' ""
-'br\}
-.el\{\
-. ds -- \|\(em\|
-. ds PI \(*p
-. ds L" ``
-. ds R" ''
-'br\}
-.\"
-.\" If the F register is turned on, we'll generate index entries on stderr for
-.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index
-.\" entries marked with X<> in POD. Of course, you'll have to process the
-.\" output yourself in some meaningful fashion.
-.if \nF \{\
-. de IX
-. tm Index:\\$1\t\\n%\t"\\$2"
-..
-. nr % 0
-. rr F
-.\}
-.\"
-.\" For nroff, turn off justification. Always turn off hyphenation; it makes
-.\" way too many mistakes in technical documents.
-.hy 0
-.if n .na
-.\"
-.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
-.\" Fear. Run. Save yourself. No user-serviceable parts.
-. \" fudge factors for nroff and troff
-.if n \{\
-. ds #H 0
-. ds #V .8m
-. ds #F .3m
-. ds #[ \f1
-. ds #] \fP
-.\}
-.if t \{\
-. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
-. ds #V .6m
-. ds #F 0
-. ds #[ \&
-. ds #] \&
-.\}
-. \" simple accents for nroff and troff
-.if n \{\
-. ds ' \&
-. ds ` \&
-. ds ^ \&
-. ds , \&
-. ds ~ ~
-. ds /
-.\}
-.if t \{\
-. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
-. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
-. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
-. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
-. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
-. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
-.\}
-. \" troff and (daisy-wheel) nroff accents
-.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
-.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
-.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
-.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
-.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
-.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
-.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
-.ds ae a\h'-(\w'a'u*4/10)'e
-.ds Ae A\h'-(\w'A'u*4/10)'E
-. \" corrections for vroff
-.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
-.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
-. \" for low resolution devices (crt and lpr)
-.if \n(.H>23 .if \n(.V>19 \
-\{\
-. ds : e
-. ds 8 ss
-. ds o a
-. ds d- d\h'-1'\(ga
-. ds D- D\h'-1'\(hy
-. ds th \o'bp'
-. ds Th \o'LP'
-. ds ae ae
-. ds Ae AE
-.\}
-.rm #[ #] #H #V #F C
-.\" ========================================================================
-.\"
-.IX Title "DebPool::Config 5"
-.TH DebPool::Config 5 "2005-01-20" "perl v5.8.4" "DebPool Configuration"
-.SH "NAME"
-DebPool::Config \- configuration file format for debpool
-.SH "SYNOPSIS"
-.IX Header "SYNOPSIS"
-package DebPool::Config;
-.PP
-%Options = (
- 'option1' => value1,
- 'option2' => value2,
- ...
-);
-.PP
-1;
-.SH "DESCRIPTION"
-.IX Header "DESCRIPTION"
-The DebPool::Config file is normally found in three places;
-\&\fI/usr/share/debpool/Config.pm\fR, \fI/etc/debpool/Config.pm\fR, and
-\&\fI$HOME/.debpool/Config.pm\fR (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.
-.PP
-The config files in /etc/debpool and \f(CW$HOME\fR/.debpool are not required to be
-full Perl modules, though they must still declare a package namespace of
-\&'DebPool::Config' and return a true value.
-.Sh "File/Directory configuration"
-.IX Subsection "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.
-.PP
-\&\s-1NOTE:\s0 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.
-.PP
-\&\s-1WARNING:\s0 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.
-.IP "\fBarchive_dir\fR => \fIarchive directory\fR" 4
-.IX Item "archive_dir => 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.
-.Sp
-\&\s-1WARNING:\s0 See the section documentation for important details about
-redefining this value.
-.Sp
-Default value: '/var/cache/debpool'
-.IP "\fBdb_dir\fR => \fIdists directory\fR" 4
-.IX Item "db_dir => dists directory"
-\&\s-1DB\s0 directory, where the database files for each distribution are kept.
-.Sp
-Default value: \*(L"$Options{'archive_dir'}/db\*(R"
-.IP "\fBdb_dir_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "db_dir_mode = permissions (octal)"
-Permissions for db_dir.
-.Sp
-Default value: 0750
-.IP "\fBdb_file_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "db_file_mode = permissions (octal)"
-Permissions for database files in db_dir.
-.Sp
-Default value: 0640
-.IP "\fBdists_dir\fR => \fIdists directory\fR" 4
-.IX Item "dists_dir => dists directory"
-Dists directory, where distribution files (\fI{Packages,Sources}{,.gz}\fR live.
-.Sp
-Default value: \*(L"$Options{'archive_dir'}/dists\*(R"
-.IP "\fBdists_dir_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "dists_dir_mode = permissions (octal)"
-Permissions for dists_dir and all of it's subdirectories.
-.Sp
-Default value: 0755
-.IP "\fBdists_file_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "dists_file_mode = permissions (octal)"
-Permissions for distribution files ({Packages,Sources}{,.gz}.
-.Sp
-Default value: 0644
-.IP "\fBincoming_dir\fR => \fIincoming directory\fR" 4
-.IX Item "incoming_dir => incoming directory"
-Incoming directory, where new packages are uploaded.
-.Sp
-Default value: \*(L"$Options{'archive_dir'}/incoming\*(R";
-.IP "\fBincoming_dir_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "incoming_dir_mode = permissions (octal)"
-Permissions for incoming_dir. Should have the sticky bit set if you want a
-system archive.
-.Sp
-Default value: 01775
-.IP "\fBinstalled_dir\fR => \fIinstalled directory\fR" 4
-.IX Item "installed_dir => installed directory"
-Incoming directory, where new packages are uploaded.
-.Sp
-Default value: \*(L"$Options{'archive_dir'}/installed\*(R";
-.IP "\fBinstalled_dir_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "installed_dir_mode = permissions (octal)"
-Permissions for installed_dir. Should have the sticky bit set if you want a
-system archive.
-.Sp
-Default value: 0755
-.IP "\fBinstalled_file_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "installed_file_mode = permissions (octal)"
-Permissions for installed Changes files.
-.Sp
-Default value: 0644
-.IP "\fBpool_dir\fR => \fIpool directory\fR" 4
-.IX Item "pool_dir => pool directory"
-Pool directory where all .deb files are stored after being accepted. Normally
-this is constructed as a relative path from archive_dir.
-.Sp
-Default value: \*(L"$Options{'archive_dir'}/pool\*(R"
-.IP "\fBpool_dir_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "pool_dir_mode = permissions (octal)"
-Permissions for pool_dir and all of it's subdirectories.
-.Sp
-Default value: 0755
-.IP "\fBpool_file_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "pool_file_mode = permissions (octal)"
-Permissions for files installed into the pool area (orig.tar.gz, tar.gz,
-diff.gz, dsc, deb).
-.Sp
-Default value: 0644
-.IP "\fBreject_dir\fR => \fIreject directory\fR" 4
-.IX Item "reject_dir => reject directory"
-Reject directory, where rejected packages are placed.
-.Sp
-Default value: \*(L"$Options{'archive_dir'}/reject\*(R"
-.IP "\fBreject_dir_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "reject_dir_mode = permissions (octal)"
-Permissions for reject_dir.
-.Sp
-Default value: 0750
-.IP "\fBreject_file_mode\fR = \fIpermissions (octal)\fR" 4
-.IX Item "reject_file_mode = permissions (octal)"
-Permissions for rejected package files.
-.Sp
-Default value: 0640
-.IP "\fBlock_file\fR => \fIlockfile\fR" 4
-.IX Item "lock_file => lockfile"
-Location of the lockfile to use when running.
-.Sp
-Default value: \*(L"$Options{'archive_dir'}/.lock\*(R"
-.IP "\fBcompress_dists\fR = \fIboolean\fR" 4
-.IX Item "compress_dists = boolean"
-This determines whether or not compressed versions of the distribution
-files (Packages.gz, Sources.gz) are generated. Note that enabling this
-introduces a dependancy on gzip.
-.Sh "Archive configuration"
-.IX Subsection "Archive configuration"
-These values control which distributions, components, and architectures the
-archive will support.
-.IP "\fBdists\fR => \fIhash of distribution names and codenames\fR" 4
-.IX Item "dists => 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.
-.Sp
-Default value:
-.Sp
-{ 'stable' => 'woody',
- 'testing' => 'sarge',
- 'unstable' => 'sid',
- 'experimental' => 'experimental' }
-.IP "\fBvirtual_dists\fR => \fIhash of virtual distribution names and targets\fR" 4
-.IX Item "virtual_dists => 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 (\*(L"unstable\*(R") or codename (\*(L"sid\*(R")
-which appears in the 'dists' hash.
-.Sp
-Default value:
-.Sp
-{
-}
-.Sp
-Exsample value:
-.Sp
-{ 'unstable\-hostname' => 'unstable',
- 'testing\-hostname' => 'sarge',
-}
-.IP "\fBsections\fR => \fIarray of section names\fR" 4
-.IX Item "sections => array of section names"
-An arrayref pointing to an array which lists all sections we will accept
-packages for. Typically, these will be drawn from the set 'main',
-\&'contrib', 'non\-free', 'experimental', 'alien', and 'local' (at least on
-the author's systems).
-.Sp
-Default value: [ 'main', 'contrib', 'non\-free' ]
-.IP "\fBarchs\fR => \fIarray of architecture names\fR" 4
-.IX Item "archs => 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).
-.Sp
-Default value: [ 'i386' ]
-.Sh "Release configuration"
-.IX Subsection "Release configuration"
-If all of the variables below are defined (release_origin, release_label,
-and release_description), Release files will be generated for each
-distribution directory.
-.PP
-Please note that enabling Release files will introduce a dependancy on the
-packages 'libdigest\-md5\-perl' and 'libdigest\-sha1\-perl'.
-.PP
-See also: sign_release
-.IP "\fBrelease_origin\fR => \fIorigin tag\fR" 4
-.IX Item "release_origin => origin tag"
-A string to be used for the Origin tag in the Release file.
-.Sp
-Default value: undef
-.IP "\fBrelease_label\fR => \fIlabel tag\fR" 4
-.IX Item "release_label => label tag"
-A string to be used for the Label tag in the Release file.
-.Sp
-Default value: undef
-.IP "\fBrelease_description\fR => \fIdescription tag\fR" 4
-.IX Item "release_description => description tag"
-A string to be used for the Description tag in the Release file. (Note that
-this should be a single line.)
-.Sp
-Default value: undef
-.IP "\fBrelease_noauto\fR = <array of NonAutomatic release names>" 4
-.IX Item "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 \s-1APT\s0 from ever automatically
-selecting a package from that archive as an installation candidate.
-.Sp
-Default value: [ 'experimental' ]
-.Sh "Signature configuration"
-.IX Subsection "Signature configuration"
-Please note that enabling any of these options will cause a dependancy on
-the 'gnupg' package. See \fI/usr/share/doc/debpool/README.GnuPG\fR for more
-information.
-.IP "\fBrequire_sigs_debs\fR = \fIboolean\fR" 4
-.IX Item "require_sigs_debs = 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.
-.Sp
-Default value: 0 (false)
-.Sp
-See also: gpg_keyrings
-.IP "\fBrequire_sigs_meta\fR = \fIboolean\fR" 4
-.IX Item "require_sigs_meta = 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.
-.Sp
-Default value: 0 (false)
-.Sp
-See also: gpg_keyrings
-.IP "\fBsign_release\fR = \fIboolean\fR" 4
-.IX Item "sign_release = boolean"
-If true, generated Release files with be GPG-signed with the key specified
-in 'gpg_sign_key'.
-.Sp
-Note that this will have no effect unless 'gpg_sign_key' is also defined at
-some point.
-.Sp
-Default value: 0 (false)
-.Sp
-See also: \*(L"Release configuration\*(R", gpg_sign_key
-.Sh "GnuPG configuration"
-.IX Subsection "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\*(R" being
-enabled) , and thus do not (in themselves) trigger a dependancy on GnuPG.
-Please see \fI/usr/share/doc/debpool/README.GnuPG\fR for more information.
-.IP "\fBgpg_bin\fR = \fIGnuPG binary\fR" 4
-.IX Item "gpg_bin = GnuPG binary"
-This is used to specify the GnuPG binary to run.
-.Sp
-Default value: '/usr/bin/gpg'
-.IP "\fBgpg_home\fR = \fIGnuPG homedir\fR" 4
-.IX Item "gpg_home = GnuPG homedir"
-This is used to specify the GnuPG homedir (via the \-\-homedir option).
-.Sp
-Default value: '/home/user/.gnupg'
-.IP "\fBgpg_keyrings\fR = \fIarray of keyring filenames\fR" 4
-.IX Item "gpg_keyrings = array of keyring filenames"
-An arrayref pointing to an array which lists all of the \s-1GPG\s0 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.
-.Sp
-Default value: [ 'uploaders.gpg' ]
-.Sp
-See also: require_sigs_debs, require_sigs_meta
-.IP "\fBgpg_sign_key\fR = \fIsignature keyID\fR" 4
-.IX Item "gpg_sign_key = signature keyID"
-A string which contains the \s-1ID\s0 of the key which we will sign Release files
-with. Note that this will have no effect unless 'sign_release' is true.
-.Sp
-Default value: undef
-.Sp
-See also: sign_release
-.IP "\fBgpg_passfile\fR = \fIpassphrase file\fR" 4
-.IX Item "gpg_passfile = 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.
-.Sp
-Default value: '/home/user/.gnupg/passphrase';
-.Sp
-See also: sign_release, gpg_sign_key
-.Sh "Logging configuration"
-.IX Subsection "Logging configuration"
-These are values which control the logging system.
-.IP "\fBlog_file\fR = \fIfilename\fR" 4
-.IX Item "log_file = 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.
-.Sh "Misc. configuration"
-.IX Subsection "Misc. configuration"
-These are values which don't particularly fit into any of the other
-sections.
-.RS 4
-.IP "\fBdaemon\fR = \fIboolean\fR" 4
-.IX Item "daemon = 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.
-.Sp
-Default value: 0 (false)
-.IP "\fBsleep\fR = \fIdelay\fR" 4
-.IX Item "sleep = delay"
-This option determines how long the daemon sleeps for, between each
-processing run. Note that signals (such as \s-1SIGHUP\s0, \s-1SIGINT\s0, or \s-1SIGTERM\s0)
-will force the daemon to wake up before this expires, so don't worry about
-setting it too long.
-.Sp
-Default value: 300 (5 minutes)
-.IP "\fBrollback\fR = \fIboolean\fR" 4
-.IX Item "rollback = 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).
-.Sp
-Default value: 0 (false)
-.IP "\fBrebuild-files\fR = \fIboolean\fR" 4
-.IX Item "rebuild-files = 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.
-.Sp
-Default value: 0 (false)
-.IP "\fBrebuild-dbs\fR = \fIboolean\fR" 4
-.IX Item "rebuild-dbs = 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. It should, of course, also not be used with the daemon option.
-.Sp
-\&\s-1WARNING:\s0 This feature is not yet implemented, and will (silently) fail to
-do anything, at this time. It will be implemented in a future version.
-.Sp
-Default value: 0 (false)
-.IP "\fBrebuild-all\fR = \fIboolean\fR" 4
-.IX Item "rebuild-all = 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).
-.Sp
-\&\s-1WARNING:\s0 This feature depends on rebuild\-dbs, which is not yet implemented;
-only the \-\-rebuild\-files section will be triggered.
-.Sp
-Default value: 0 (false)
-.IP "\fBconfig\fR = \fIconfigfile\fR" 4
-.IX Item "config = 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).
-.Sp
-Default value: N/A
-.RE
-.RS 4
-.SH "CAVEATS"
-.IX Header "CAVEATS"
-Command line options will override all Config.pm declarations.
-.SH "SEE ALSO"
-.IX Header "SEE ALSO"
-\&\fIdebpool\fR\|(1)
-.SH "AUTHOR"
-.IX Header "AUTHOR"
-Joel Baker <fenton@debian.org>