Merge branch 'sourcev3'

debian/dpkg-dev.install

@@ -61,20 +61,4 @@ usr/share/man/*/*/dpkg-shlibdeps.1
 usr/share/man/*/dpkg-shlibdeps.1
 usr/share/man/*/*/dpkg-source.1
 usr/share/man/*/dpkg-source.1
-usr/share/perl5/Dpkg/Arch.pm
-usr/share/perl5/Dpkg/BuildOptions.pm
-usr/share/perl5/Dpkg/Cdata.pm
-usr/share/perl5/Dpkg/Checksums.pm
-usr/share/perl5/Dpkg/Compression.pm
-usr/share/perl5/Dpkg/Control.pm
-usr/share/perl5/Dpkg/Changelog.pm
-usr/share/perl5/Dpkg/Changelog/Debian.pm
-usr/share/perl5/Dpkg/Deps.pm
-usr/share/perl5/Dpkg/ErrorHandling.pm
-usr/share/perl5/Dpkg/Fields.pm
-usr/share/perl5/Dpkg/Path.pm
-usr/share/perl5/Dpkg/Shlibs
-usr/share/perl5/Dpkg/Shlibs.pm
-usr/share/perl5/Dpkg/Substvars.pm
-usr/share/perl5/Dpkg/Vars.pm
-usr/share/perl5/Dpkg/Version.pm
+usr/share/perl5/Dpkg

debian/rules

@@ -112,7 +112,7 @@ binary-arch: install
 binary-indep: install
 	dh_testdir -i
 	dh_testroot -i
-	dh_install --sourcedir=debian/tmp -i
+	dh_install --sourcedir=debian/tmp -i -XDpkg/Gettext.pm
 
 	dh_installchangelogs -i ChangeLog
 	dh_installdocs -i

man/dpkg-source.1

@@ -1,5 +1,5 @@
-.\" Authors: Ian Jackson
-.TH dpkg\-source 1 "2007-09-24" "Debian Project" "dpkg utilities"
+.\" Authors: Ian Jackson, Raphael Hertzog
+.TH dpkg\-source 1 "2008-03-16" "Debian Project" "dpkg utilities"
 .SH NAME
 dpkg\-source \- Debian source package (.dsc) manipulation tool
 .
@@ -42,22 +42,20 @@ extractors' umask; if the parent directory is setgid then the
 extracted directories will be too, and all the files and directories
 will inherit its group ownership.
 .TP
-.RI "\fB\-b\fP " directory " [" orig-directory | orig-targz |\(aq\(aq]
-Build a source package. One or two non-option arguments should
-be supplied. The first is taken as the name of the directory
-containing the debianized source tree (i.e. with a debian sub-directory
-and maybe changes to the original files). If a second argument is supplied
-it should be the name of the original source directory or tarfile or
-the empty string if the package is a Debian-specific one and so has no
-Debianisation diffs. If no second argument is supplied then
-.B dpkg\-source
-will look for the original source tarfile
-.IB package _ upstream-version .orig.tar. extension
-(where \fIextension\fP is one of
-.BR gz ", " bz2 ", and " lzma )
-or the original source directory
-.IB directory .orig
-depending on the \fB\-sX\fP arguments.
+.RI "\fB\-b\fP " directory " [" format-specific-parameters ]
+Build a source package. The first non-option argument is taken as the
+name of the directory containing the debianized source tree (i.e. with a
+debian sub-directory and maybe changes to the original files).
+Depending on the source package format used to build the package,
+additional parameters might be accepted.
+
+\fBdpkg\-source\fP will build the source package with the first format
+that works from this ordered list:
+the format indicated in the \fIFormat\fP field of \fBdebian/control\fP,
+the format(s) indicated with the \fI\-\-format\fP command-line option(s),
+"1.0", "3.0 (native)". See below for an extensive description of
+various source package formats.
+
 .TP
 .BR \-h ", " \-\-help
 Show the usage message and exit.
@@ -65,7 +63,7 @@ Show the usage message and exit.
 .BR \-\-version
 Show the version and exit.
 .
-.SH OPTIONS
+.SH GENERIC BUILD OPTIONS
 .TP
 .BI \-c controlfile
 Specifies the main source control file to read information from. The
@@ -86,12 +84,18 @@ Specifies the format of the changelog. By default the format is read
 from a special line near the bottom of the changelog or failing that
 defaults to the debian standard format.
 .TP
+.BI \-\-format= value
+Try first the given format for building the source package. If used
+multiple times, the last value is tried first and the first one is
+tried last just before trying the default formats. It doesn't override
+any explicit \fIFormat\fP field in \fBdebian/control\fP.
+.TP
 .BI \-V name = value
-Set an output substitution variable.
+\fBDeprecated\fP. Set an output substitution variable.
 See \fBdeb\-substvars\fP(5) for a discussion of output substitution.
 .TP
 .BI \-T substvarsfile
-Read substitution variables in
+\fBDeprecated\fP. Read substitution variables in
 .IR substvarsfile ;
 the default is to not read any file.
 .TP
@@ -101,13 +105,6 @@ Override or add an output control file field.
 .BI \-U field
 Remove an output control file field.
 .TP
-.BI \-E
-This option turns certain warnings into errors.
-.TP
-.BI \-W
-This option negates a previously set
-.BR \-E "."
-.TP
 .BR \-Z \fIcompression\fP
 Specify the compression to use for created files (tarballs and diffs).
 Note that this option will not cause existing tarballs to be recompressed,
@@ -124,7 +121,9 @@ files. Supported values are:
 .BR \-i [\fIregexp\fP]
 You may specify a perl regular expression to match files you want
 filtered out of the list of files for the diff. (This list is
-generated by a find command.) \fB\-i\fP by itself enables the option,
+generated by a find command.) (If the source package is being built as a
+version 3 source package using a VCS, this is instead used to
+ignore uncommitted files.) \fB\-i\fP by itself enables the option,
 with a default that will filter out control files and directories of the
 most common revision control systems, backup and swap files and Libtool
 build output directories. There can only be one active regexp, of multiple
@@ -168,9 +167,54 @@ documentation.
 
 The default regexp and patterns for both options can be seen
 in the output of the \fB\-\-help\fP command.
+.SH GENERIC EXTRACT OPTIONS
+.TP
+.BI \-\-no\-copy
+Do not copy original tarballs near the extracted source package.
+.TP
+.BI \-\-no\-check
+Do not check signatures and checksums before unpacking.
+
+.SH SOURCE PACKAGE FORMATS
+.SS Format: 1.0
+A source package in this format consists either of a \fB.orig.tar.gz\fP
+associated to a \fB.diff.gz\fP or a single \fB.tar.gz\fP (in that case
+the package is said to be \fInative\fP).
+
+.B Extracting
+
+Extracting a native package is a simple extraction of the single
+tarball in the target directory. Extracting a non-native package
+is done by first unpacking the \fB.orig.tar.gz\fP and then applying
+the patch contained in the \fB.diff.gz\fP file. The timestamp of
+all patched files is reset to the extraction time of the source
+package (this avoids timestamp skews leading to problems when
+autogenerated files are patched). The diff can create new files (the whole
+debian directory is created that way) but can't remove files (empty files
+will be left over).
+
+.B Building
+
+Building a native package is just creating a single tarball with
+the source directory. Building a non-native package involves
+extracting the original tarball in a separate ".orig" directory and
+regenerating the \fB.diff.gz\fP by comparing the source package
+\fIdirectory\fP with the .orig directory.
+
 .TP
-.B Build options (with -b):
+.B Build options (with \-b):
 .PP
+If a second non-option argument is supplied it should be the name of the
+original source directory or tarfile or the empty string if the package is
+a Debian-specific one and so has no Debianisation diffs. If no second
+argument is supplied then
+.B dpkg\-source
+will look for the original source tarfile
+.IB package _ upstream-version .orig.tar.gz
+or the original source directory
+.IB directory .orig
+depending on the \fB\-sX\fP arguments.
+
 .BR \-sa ", " \-sp ", " \-sk ", " \-su " and " \-sr
 will not overwrite existing tarfiles or directories. If this is
 desired then
@@ -267,17 +311,146 @@ All the
 options are mutually exclusive. If you specify more than one only the
 last one will be used.
 .
+.SS Format: 2.0
+Also known as wig&pen. A source package in this format contains at least
+an original tarball (\fB.orig.tar.\fP\fIext\fP where \fIext\fP can be
+\fBgz\fP, \fBbz2\fP and \fBlzma\fP) and a debian tarball
+(\fB.debian.tar.\fP\fIext\fP). It can also contain additional original
+tarballs (\fB.orig-\fP\fIcomponent\fP\fB.tar.\fP\fIext\fP).
+.PP
+.B Extracting
+.PP
+The main original tarball is extracted first, then all additional original
+tarballs are extracted in subdirectories named after the \fIcomponent\fP
+part of their filename (any pre-existing directory is replaced). The
+debian tarball is extracted on top of the source directory after prior
+removal of any pre-existing \fBdebian\fP directory). Note that the
+debian tarball must contain a \fBdebian\fP sub-directory but it
+can also contain binary files outside of that directory (see
+\fB\-\-include\-binaries\fP option).
+.PP
+All patches in \fBdebian/patches\fP matching the perl regular expression
+\fB[\\w\-]+\fP are then applied in alphabetical order. The timestamp of
+patched files are reset to the extraction time. The patches can remove
+files.
+.PP
+.B Building
+.PP
+All original tarballs found in the current directory are extracted in a
+temporary directory by following the same logic than the unpack, the
+debian directory is copied over in the temporary directory, and all
+patches except \fBzz_debian-diff-auto\fP are applied.
+The temporary directory is compared to the source package directory
+and the diff (if non-empty) is stored in
+\fBdebian/patches/zz_debian-diff-auto\fP. Any change on a binary file
+is not representable in a diff and will thus lead to a failure unless
+the maintainer deliberately decided to include that modified binary
+file in the debian tarball (by listing it in
+\fBdebian/source/include-binaries\fP).
+
+The updated debian directory and the list of modified binaries is then
+used to regenerate the debian tarball.
+
+The automatically generated diff doesn't include changes on VCS specific
+files as well as many temporary files (see default value associated to
+\fB-i\fP option in the \fB\-\-help\fP output).
+
+Note: it's very important to generate the source package with all
+patches applied, otherwise the generation of the automatic patch will lead to
+a patch that reverts the patches which were not applied.
+.PP
+.B Build options
+.TP
+.B \-\-include\-removal
+Do not ignore removed files and include them in the automatically
+generated patch.
+.TP
+.B \-\-include\-timestamp
+Include timestamp in the automatically generated patch.
+.SS Format: 3.0 (native)
+This format is an extension of the native package format as defined
+in the 1.0 format. It supports all compression methods and
+will ignore by default any VCS specific files and directories
+as well as many temporary files (see default value associated to
+\fB-I\fP option in the \fB\-\-help\fP output).
+.TP
+.B \-\-include\-binaries
+Add all modified binaries in the debian tarball. Also add them to
+\fBdebian/source/include-binaries\fP: they will be added by default
+in subsequent builds and this option is thus no more needed.
+.
+.SS Format: 3.0 (quilt)
+This is a variant of the 2.0 format. The differences concern the
+management of the patches. This format uses an explicit list of
+patches contained in \fBdebian/patches/debian.series\fP or
+\fBdebian/patches/series\fP.
+.PP
+.B Extracting
+.PP
+Unpacking of tarballs is done exactly like in the 2.0 format.
+.PP
+When it comes to patch application, the list of patches is taken from
+\fBdebian/patches/debian.series\fP or \fBdebian/patches/series\fP.
+If the former file is used and the latter one doesn't exist, then the
+latter is replaced with a symlink to the former. This is meant to simplify
+usage of quilt to manage the set of patches.
+.PP
+.B Building
+.PP
+It behaves like the 2.0 format except that the name of the automatically
+generated patch is \fBdebian-changes-\fP\fIversion\fP\fB.diff\fP and the
+\fBseries\fP file is obviously updated to add/remove the automatically
+generated patch as needed.
+
+The \fB.pc\fI directory used by quilt is ignored during generation of the
+automatic patch.
+.PP
+.B Build options
+.PP
+It supports all the options of the 2.0 format.
+.PP
+.B Extract options
+.TP
+.B \-\-without\-quilt
+Don't use quilt to apply patches but dpkg-source's own code. It won't be
+possible to use quilt directly on the unpacked directory but it will be
+free of quilt's temporary files as well.
+.
+.SS Format: 3.0 (custom)
+This format is particular. It doesn't represent a real source package
+format but can be used to create source packages with arbitrary files.
+.PP
+.B Build options
+.PP
+All non-option arguments are taken as files to integrate in the
+generated source package. They must exist and are preferrably
+in the current directory. At least one file must be given.
+.TP
+.BI \-\-target\-format= value
+\fBRequired\fP. Defines the real format of the generated source package.
+The generated .dsc file will contain this value in its \fIFormat\fP field
+and not "3.0 (custom)".
+.
+.SS Format: 3.0 (git) and 3.0 (bzr)
+Those formats are experimental. They generate a single tarball
+containing the corresponding VCS repository.
+.PP
+.B Extracting
+.PP
+The tarball is unpacked and then the VCS is used to checkout the current
+branch.
+.PP
+.B Building
+.PP
+Before going any further, some checks are done to ensure that we
+don't have any non-ignored uncommitted changes.
+.PP
+Then the VCS specific part of the source directory is copied over to a
+temporary directory. Before being packed in a tarball, various cleanup are
+done to save space.
 .SH BUGS
 The point at which field overriding occurs compared to certain
 standard output field settings is rather confused.
-
-The binary package entries in the
-.B debian/files
-file will be passed through variable substitution twice. This should
-not matter, since
-.BR $ ", " { " and " }
-are not legal in package names or version numbers.
-.
 .SH SEE ALSO
 .BR dpkg\-deb (1),
 .BR dpkg (1),
@@ -287,6 +460,8 @@ are not legal in package names or version numbers.
 Copyright (C) 1995-1996 Ian Jackson
 .br
 Copyright (C) 2000 Wichert Akkerman
+.br
+Copyright (C) 2008 Rapha\[:e]l Hertzog
 .sp
 This is free software; see the GNU General Public Licence version 2 or later
 for copying conditions. There is NO WARRANTY.

scripts/Dpkg/Compression.pm

@@ -4,11 +4,25 @@ use strict;
 use warnings;
 
 use base qw(Exporter);
-our @EXPORT = qw(@comp_supported %comp_supported %comp_ext $comp_regex);
+our @EXPORT = qw(@comp_supported %comp_supported %comp_ext $comp_regex
+		 %comp_prog %comp_decomp_prog
+		 get_compression_from_filename);
 
 our @comp_supported = qw(gzip bzip2 lzma);
 our %comp_supported = map { $_ => 1 } @comp_supported;
-our %comp_ext = ( gzip => 'gz', bzip2 => 'bz2', lzma => 'lzma' );
+our %comp_ext = (gzip => 'gz', bzip2 => 'bz2', lzma => 'lzma');
 our $comp_regex = '(?:gz|bz2|lzma)';
+our %comp_prog = (gzip => 'gzip', bzip2 => 'bzip2', lzma => 'lzma');
+our %comp_decomp_prog = (gzip => 'gunzip', bzip2 => 'bunzip2', lzma => 'unlzma');
+
+sub get_compression_from_filename {
+    my $filename = shift;
+    foreach my $comp (@comp_supported) {
+        if ($filename =~ /^(.*)\.\Q$comp_ext{$comp}\E$/) {
+	    return $comp;
+        }
+    }
+    return undef;
+}
 
 1;

scripts/Dpkg/ErrorHandling.pm

@@ -4,9 +4,9 @@ use Dpkg;
 use Dpkg::Gettext;
 
 use base qw(Exporter);
-our @EXPORT_OK = qw(warning warnerror error failure unknown syserr internerr
-                    subprocerr usageerr syntaxerr report
-		    $warnable_error $quiet_warnings);
+our @EXPORT_OK = qw(warning warnerror error errormsg failure unknown
+                    syserr internerr subprocerr usageerr syntaxerr report
+                    info $warnable_error $quiet_warnings);
 
 our $warnable_error = 1;
 our $quiet_warnings = 0;
@@ -19,6 +19,11 @@ sub report(@)
     return "$progname: $type: $msg\n";
 }
 
+sub info($;@)
+{
+    print report(_g("info"), @_) if (!$quiet_warnings);
+}
+
 sub warning($;@)
 {
     warn report(_g("warning"), @_) if (!$quiet_warnings);
@@ -49,6 +54,11 @@ sub error($;@)
     die report(_g("error"), @_);
 }
 
+sub errormsg($;@)
+{
+    print STDERR report(_g("error"), @_);
+}
+
 sub internerr($;@)
 {
     die report(_g("internal error"), @_);

scripts/Dpkg/Exit.pm

@@ -0,0 +1,17 @@
+package Dpkg::Exit;
+
+use strict;
+use warnings;
+
+our @handlers = ();
+sub exit_handler {
+    &$_() foreach (reverse @handlers);
+    exit(127);
+}
+
+$SIG{'INT'} = \&exit_handler;
+$SIG{'HUP'} = \&exit_handler;
+$SIG{'QUIT'} = \&exit_handler;
+
+# vim: set et sw=4 ts=8
+1;

scripts/Dpkg/IPC.pm

@@ -0,0 +1,297 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+# Copyright 2008 Frank Lichtenheld <djpig@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::IPC;
+
+use strict;
+use warnings;
+
+use Dpkg::ErrorHandling qw(error syserr subprocerr);
+use Dpkg::Gettext;
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(fork_and_exec wait_child);
+
+=head1 NAME
+
+Dpkg::IPC - helper functions for IPC
+
+=head1 DESCRIPTION
+
+Dpkg::IPC offers helper functions to allow you to execute
+other programs in an easy, yet flexible way, while hiding
+all the gory details of IPC (Inter-Process Communication)
+from you.
+
+=head1 METHODS
+
+=over 4
+
+=item fork_and_exec
+
+Creates a child process and executes another program in it.
+The arguments are interpreted as a hash of options, specifying
+how to handle the in and output of the program to execute.
+Returns the pid of the child process (unless the wait_child
+option was given).
+
+Any error will cause the function to exit with one of the
+Dpkg::ErrorHandling functions.
+
+Options:
+
+=over 4
+
+=item exec
+
+Can be either a scalar, i.e. the name of the program to be
+executed, or an array reference, i.e. the name of the program
+plus additional arguments. Note that the program will never be
+executed via the shell, so you can't specify additional arguments
+in the scalar string and you can't use any shell facilities like
+globbing.
+
+Mandatory Option.
+
+=item from_file, to_file
+
+Filename as scalar. Standard input and/or standard output of the
+child process will be redirected to the file specifed.
+
+=item from_handle, to_handle
+
+Filehandle. Standard input and/or standard output of the
+child process will be dup'ed from the handle.
+
+=item from_pipe, to_pipe
+
+Scalar reference. A pipe will be opened for each of the two options
+and either the reading (C<to_pipe>) or the writing end (C<from_pipe>)
+will be returned in the referenced scalar. Standard input and/or standard
+output of the child process will be dup'ed to the other ends of the
+pipes.
+
+=item from_string, to_string
+
+Scalar reference. Standard input and/or standard output of the child
+process will be redirected to the string given as reference. Note
+that it wouldn't be strictly necessary to use a scalar reference
+for C<from_string>, as the string is not modified in any way. This was
+chosen only for reasons of symmetry with C<to_string>. C<to_string>
+implies the C<wait_child> option.
+
+=item wait_child
+
+Scalar. If containing a true value, wait_child() will be called before
+returning. The return value will of fork_and_exec() will be a true value,
+but not the pid.
+
+=item chdir
+
+Scalar. The child process will chdir in the indicated directory before
+calling exec.
+
+=item env
+
+Hash reference. The child process will populate %ENV with the items of the
+hash before calling exec. This allows exporting environment variables.
+
+=item delete_env
+
+Array reference. The child process will remove all environment variables
+listed in the array before calling exec.
+
+=back
+
+=cut
+
+sub _sanity_check_opts {
+    my (%opts) = @_;
+
+    error("exec parameter is mandatory in fork_and_exec()")
+	unless $opts{"exec"};
+
+    my $to = my $from = 0;
+    foreach (qw(file handle string pipe)) {
+	$to++ if $opts{"to_$_"};
+	$from++ if $opts{"from_$_"};
+    }
+    error("not more than one of to_* parameters is allowed")
+	if $to > 1;
+    error("not more than one of from_* parameters is allowed")
+	if $from > 1;
+
+    foreach (qw(to_string from_string to_pipe from_pipe)) {
+	if (exists $opts{$_} and
+	    (!ref($opts{$_}) or ref($opts{$_}) ne 'SCALAR')) {
+	    error("parameter $_ must be a scalar reference");
+	}
+    }
+
+    if (exists $opts{"env"} and ref($opts{"env"}) ne 'HASH') {
+	error("parameter env must be a hash reference");
+    }
+
+    if (exists $opts{"delete_env"} and ref($opts{"delete_env"}) ne 'ARRAY') {
+	error("parameter delete_env must be an array reference");
+    }
+
+    return %opts;
+}
+
+sub fork_and_exec {
+    my (%opts) = _sanity_check_opts(@_);
+    $opts{"close_in_child"} ||= [];
+    my @prog;
+    if (ref($opts{"exec"}) =~ /ARRAY/) {
+	push @prog, @{$opts{"exec"}};
+    } elsif (not ref($opts{"exec"})) {
+	push @prog, $opts{"exec"};
+    } else {
+	error(_g("invalid exec parameter in fork_and_exec()"));
+    }
+    my ($from_string_pipe, $to_string_pipe);
+    if ($opts{"to_string"}) {
+	$opts{"to_pipe"} = \$to_string_pipe;
+	$opts{"wait_child"} = 1;
+    }
+    if ($opts{"from_string"}) {
+	$opts{"from_pipe"} = \$from_string_pipe;
+    }
+    # Create pipes if needed
+    my ($input_pipe, $output_pipe);
+    if ($opts{"from_pipe"}) {
+	pipe($opts{"from_handle"}, $input_pipe) ||
+		syserr(_g("pipe for %s"), "@prog");
+	${$opts{"from_pipe"}} = $input_pipe;
+	push @{$opts{"close_in_child"}}, $input_pipe;
+    }
+    if ($opts{"to_pipe"}) {
+	pipe($output_pipe, $opts{"to_handle"}) ||
+		syserr(_g("pipe for %s"), "@prog");
+	${$opts{"to_pipe"}} = $output_pipe;
+	push @{$opts{"close_in_child"}}, $output_pipe;
+    }
+    # Fork and exec
+    my $pid = fork();
+    syserr(_g("fork for %s"), "@prog") unless defined $pid;
+    if (not $pid) {
+	# Define environment variables
+	if ($opts{"env"}) {
+	    foreach (keys %{$opts{"env"}}) {
+		$ENV{$_} = $opts{"env"}{$_};
+	    }
+	}
+	if ($opts{"delete_env"}) {
+	    delete $ENV{$_} foreach (@{$opts{"delete_env"}});
+	}
+	# Change the current directory
+	if ($opts{"chdir"}) {
+	    chdir($opts{"chdir"}) || syserr(_g("chdir to %s"), $opts{"chdir"});
+	}
+	# Redirect STDIN if needed
+	if ($opts{"from_file"}) {
+	    open(STDIN, "<", $opts{"from_file"}) ||
+		syserr(_g("cannot open %s"), $opts{"from_file"});
+	} elsif ($opts{"from_handle"}) {
+	    open(STDIN, "<&", $opts{"from_handle"}) || syserr(_g("reopen stdin"));
+	    close($opts{"from_handle"}); # has been duped, can be closed
+	}
+	# Redirect STDOUT if needed
+	if ($opts{"to_file"}) {
+	    open(STDOUT, ">", $opts{"to_file"}) ||
+		syserr(_g("cannot write %s"), $opts{"to_file"});
+	} elsif ($opts{"to_handle"}) {
+	    open(STDOUT, ">&", $opts{"to_handle"}) || syserr(_g("reopen stdout"));
+	    close($opts{"to_handle"}); # has been duped, can be closed
+	}
+	# Close some inherited filehandles
+	close($_) foreach (@{$opts{"close_in_child"}});
+	# Execute the program
+	exec({ $prog[0] } @prog) or syserr(_g("exec %s"), "@prog");
+    }
+    # Close handle that we can't use any more
+    close($opts{"from_handle"}) if exists $opts{"from_handle"};
+    close($opts{"to_handle"}) if exists $opts{"to_handle"};
+
+    if ($opts{"from_string"}) {
+	print $from_string_pipe ${$opts{"from_string"}};
+	close($from_string_pipe);
+    }
+    if ($opts{"to_string"}) {
+	local $/ = undef;
+	${$opts{"to_string"}} = readline($to_string_pipe);
+    }
+    if ($opts{"wait_child"}) {
+	wait_child($pid, cmdline => "@prog");
+	return 1;
+    }
+
+    return $pid;
+}
+
+
+=item wait_child
+
+Takes as first argument the pid of the process to wait for.
+Remaining arguments are taken as a hash of options. Returns
+nothing. Fails if the child has been ended by a signal or
+if it exited non-zero.
+
+Options:
+
+=over 4
+
+=item cmdline
+
+String to identify the child process in error messages.
+Defaults to "child process".
+
+=item nocheck
+
+If true do not check the return status of the child (and thus
+do not fail it it has been killed or if it exited with a
+non-zero return code).
+
+=back
+
+=cut
+
+sub wait_child {
+    my ($pid, %opts) = @_;
+    $opts{"cmdline"} ||= _g("child process");
+    error(_g("no PID set, cannot wait end of process")) unless $pid;
+    $pid == waitpid($pid, 0) or syserr(_g("wait for %s"), $opts{"cmdline"});
+    unless ($opts{"nocheck"}) {
+	subprocerr($opts{"cmdline"}) if $?;
+    }
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHORS
+
+Written by Raphaël Hertzog <hertzog@debian.org> and
+Frank Lichtenheld <djpig@debian.org>.
+
+=head1 SEE ALSO
+
+Dpkg, Dpkg::ErrorHandling

scripts/Dpkg/Source/Archive.pm

@@ -0,0 +1,149 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Archive;
+
+use strict;
+use warnings;
+
+use Dpkg::Source::Functions qw(erasedir fixperms);
+use Dpkg::Gettext;
+use Dpkg::IPC;
+use Dpkg::ErrorHandling qw(error syserr warning);
+
+use POSIX;
+use File::Temp qw(tempdir);
+use File::Basename qw(basename);
+use File::Spec;
+
+use base 'Dpkg::Source::CompressedFile';
+
+sub create {
+    my ($self, %opts) = @_;
+    $opts{"options"} ||= [];
+    my %fork_opts;
+    # Possibly run tar from another directory
+    if ($opts{"chdir"}) {
+        $fork_opts{"chdir"} = $opts{"chdir"};
+        $self->{"chdir"} = $opts{"chdir"};
+    }
+    # Redirect input/output appropriately
+    $fork_opts{"to_handle"} = $self->open_for_write();
+    $fork_opts{"from_pipe"} = \$self->{'tar_input'};
+    # Call tar creation process
+    $fork_opts{'exec'} = [ 'tar', '--null', '-T', '-',
+			   @{$opts{"options"}}, '-cf', '-' ];
+    $self->{"pid"} = fork_and_exec(%fork_opts);
+    $self->{"cwd"} = getcwd();
+}
+
+sub _add_entry {
+    my ($self, $file) = @_;
+    error("call create first") unless $self->{"tar_input"};
+    $file = $2 if ($file =~ /^\Q$self->{'cwd'}\E\/(.+)$/); # Relative names
+    print({ $self->{'tar_input'} } "$file\0") ||
+	    syserr(_g("write on tar input"));
+}
+
+sub add_file {
+    my ($self, $file) = @_;
+    my $testfile = $file;
+    if ($self->{"chdir"}) {
+        $testfile = File::Spec->catfile($self->{"chdir"}, $file);
+    }
+    error("add_file() doesn't handle directories") if not -l $testfile and -d _;
+    $self->_add_entry($file);
+}
+
+sub add_directory {
+    my ($self, $file) = @_;
+    my $testfile = $file;
+    if ($self->{"chdir"}) {
+        $testfile = File::Spec->catdir($self->{"chdir"}, $file);
+    }
+    error("add_directory() only handles directories") unless not -l $testfile and -d _;
+    $self->_add_entry($file);
+}
+
+sub finish {
+    my ($self) = @_;
+    close($self->{'tar_input'}) or syserr(_g("close on tar input"));
+    wait_child($self->{'pid'}, cmdline => 'tar -cf -');
+    delete $self->{'pid'};
+    delete $self->{'tar_input'};
+    delete $self->{'cwd'};
+    delete $self->{'chdir'};
+    $self->cleanup_after_open();
+}
+
+sub extract {
+    my ($self, $dest, %opts) = @_;
+    $opts{"options"} ||= [];
+    $opts{"in_place"} ||= 0;
+    $opts{"no_fixperms"} ||= 0;
+    my %fork_opts = (wait_child => 1);
+
+    # Prepare destination
+    my $tmp;
+    if ($opts{"in_place"}) {
+        $fork_opts{"chdir"} = $dest;
+        $tmp = $dest; # So that fixperms call works
+    } else {
+        my $template = basename($self->get_filename()) .  ".tmp-extract.XXXXX";
+        $tmp = tempdir($template, DIR => getcwd(), CLEANUP => 1);
+        $fork_opts{"chdir"} = $tmp;
+    }
+
+    # Prepare stuff that handles the input of tar
+    $fork_opts{"from_handle"} = $self->open_for_read();
+
+    # Call tar extraction process
+    $fork_opts{'exec'} = [ 'tar', '--no-same-owner', '--no-same-permissions',
+                           @{$opts{"options"}}, '-xkf', '-' ];
+    fork_and_exec(%fork_opts);
+    $self->cleanup_after_open();
+
+    # Fix permissions on extracted files because tar insists on applying
+    # our umask _to the original permissions_ rather than mostly-ignoring
+    # the original permissions.
+    # We still need --no-same-permissions because otherwise tar might
+    # extract directory setgid (which we want inherited, not
+    # extracted); we need --no-same-owner because putting the owner
+    # back is tedious - in particular, correct group ownership would
+    # have to be calculated using mount options and other madness.
+    fixperms($tmp) unless $opts{"no_fixperms"};
+
+    # Stop here if we extracted in-place as there's nothing to move around
+    return if $opts{"in_place"};
+
+    # Rename extracted directory
+    opendir(D, $tmp) || syserr(_g("cannot opendir %s"), $tmp);
+    my @entries = grep { $_ ne "." && $_ ne ".." } readdir(D);
+    closedir(D);
+    my $done = 0;
+    erasedir($dest);
+    if (scalar(@entries) == 1 && -d "$tmp/$entries[0]") {
+	rename("$tmp/$entries[0]", $dest) ||
+		syserr(_g("Unable to rename %s to %s"),
+		       "$tmp/$entries[0]", $dest);
+    } else {
+	rename($tmp, $dest) ||
+		syserr(_g("Unable to rename %s to %s"), $tmp, $dest);
+    }
+    erasedir($tmp);
+}
+
+1;

scripts/Dpkg/Source/CompressedFile.pm

@@ -0,0 +1,141 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::CompressedFile;
+
+use strict;
+use warnings;
+
+use Dpkg::Compression;
+use Dpkg::Source::Compressor;
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(error syserr warning);
+
+# Object methods
+sub new {
+    my ($this, %args) = @_;
+    my $class = ref($this) || $this;
+    my $self = {
+	"compression" => "auto"
+    };
+    bless $self, $class;
+    $self->{"compressor"} = Dpkg::Source::Compressor->new();
+    $self->{"add_comp_ext"} = $args{"add_compression_extension"} ||
+	    $args{"add_comp_ext"} || 0;
+    if (exists $args{"filename"}) {
+	$self->set_filename($args{"filename"});
+    }
+    if (exists $args{"compression"}) {
+	$self->set_compression($args{"compression"});
+    }
+    if (exists $args{"compression_level"}) {
+	$self->set_compression_level($args{"compression_level"});
+    }
+    return $self;
+}
+
+sub reset {
+    my ($self) = @_;
+    %{$self} = ();
+}
+
+sub set_compression {
+    my ($self, $method) = @_;
+    if ($method ne "none" and $method ne "auto") {
+	$self->{"compressor"}->set_compression($method);
+    }
+    $self->{"compression"} = $method;
+}
+
+sub set_compression_level {
+    my ($self, $level) = @_;
+    $self->{"compressor"}->set_compression_level($level);
+}
+
+sub set_filename {
+    my ($self, $filename, $add_comp_ext) = @_;
+    $self->{"filename"} = $filename;
+    # Automatically add compression extension to filename
+    if (defined($add_comp_ext)) {
+	$self->{"add_comp_ext"} = $add_comp_ext;
+    }
+    if ($self->{"add_comp_ext"} and $filename =~ /\.$comp_regex$/) {
+	warning("filename %s already has an extension of a compressed file " .
+	        "and add_comp_ext is active", $filename);
+    }
+}
+
+sub get_filename {
+    my $self = shift;
+    my $comp = $self->{"compression"};
+    if ($self->{'add_comp_ext'}) {
+	if ($comp eq "auto") {
+	    error("automatic detection of compression is " .
+	          "incompatible with add_comp_ext");
+	} elsif ($comp eq "none") {
+	    return $self->{"filename"};
+	} else {
+	    return $self->{"filename"} . "." . $comp_ext{$comp};
+	}
+    } else {
+	return $self->{"filename"};
+    }
+}
+
+sub use_compression {
+    my ($self, $update) = @_;
+    my $comp = $self->{"compression"};
+    if ($comp eq "none") {
+	return 0;
+    } elsif ($comp eq "auto") {
+	$comp = get_compression_from_filename($self->get_filename());
+	$self->{"compressor"}->set_compression($comp) if $comp;
+    }
+    return $comp;
+}
+
+sub open_for_write {
+    my ($self) = @_;
+    my $handle;
+    if ($self->use_compression()) {
+	$self->{'compressor'}->compress(from_pipe => \$handle,
+		to_file => $self->get_filename());
+    } else {
+	open($handle, '>', $self->get_filename()) ||
+		syserr(_g("cannot write %s"), $self->get_filename());
+    }
+    return $handle;
+}
+
+sub open_for_read {
+    my ($self) = @_;
+    my $handle;
+    if ($self->use_compression()) {
+	$self->{'compressor'}->uncompress(to_pipe => \$handle,
+		from_file => $self->get_filename());
+    } else {
+	open($handle, '<', $self->get_filename()) ||
+		syserr(_g("cannot read %s"), $self->get_filename());
+    }
+    return $handle;
+}
+
+sub cleanup_after_open {
+    my ($self) = @_;
+    $self->{"compressor"}->wait_end_process();
+}
+
+1;

scripts/Dpkg/Source/Compressor.pm

@@ -0,0 +1,131 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Compressor;
+
+use strict;
+use warnings;
+
+use Dpkg::Compression;
+use Dpkg::Gettext;
+use Dpkg::IPC;
+use Dpkg::ErrorHandling qw(error);
+
+use POSIX;
+
+our $default_compression = "gzip";
+our $default_compression_level = 9;
+
+# Class methods
+sub set_default_compression {
+    my ($self, $method) = @_;
+    error(_g("%s is not a supported compression"), $method)
+	    unless $comp_supported{$method};
+    $default_compression = $method;
+}
+
+sub set_default_compression_level {
+    my ($self, $level) = @_;
+    error(_g("%s is not a compression level"), $level)
+	    unless $level =~ /^([1-9]|fast|best)$/;
+    $default_compression_level = $level;
+}
+
+# Object methods
+sub new {
+    my ($this, %args) = @_;
+    my $class = ref($this) || $this;
+    my $self = {};
+    bless $self, $class;
+    $self->set_compression($args{"compression"} || $default_compression);
+    $self->set_compression_level($args{"compression_level"} ||
+	    $default_compression_level);
+    return $self;
+}
+
+sub set_compression {
+    my ($self, $method) = @_;
+    error(_g("%s is not a supported compression method"), $method)
+	    unless $comp_supported{$method};
+    $self->{"compression"} = $method;
+}
+
+sub set_compression_level {
+    my ($self, $level) = @_;
+    error(_g("%s is not a compression level"), $level)
+	    unless $level =~ /^([1-9]|fast|best)$/;
+    $self->{"compression_level"} = $level;
+}
+
+sub get_compress_cmdline {
+    my ($self) = @_;
+    my @prog = ($comp_prog{$self->{"compression"}});
+    my $level = "-" . $self->{"compression_level"};
+    $level = "--" . $self->{"compression_level"}
+	    if $self->{"compression_level"} =~ m/best|fast/;
+    push @prog, $level;
+    return @prog;
+}
+
+sub get_uncompress_cmdline {
+    my ($self) = @_;
+    return ($comp_decomp_prog{$self->{"compression"}});
+}
+
+sub _sanity_check {
+    my ($self, %opts) = @_;
+    # Check for proper cleaning before new start
+    error(_g("Dpkg::Source::Compressor can only start one subprocess at a time"))
+	    if $self->{"pid"};
+    # Check options
+    my $to = my $from = 0;
+    foreach (qw(file handle string pipe)) {
+        $to++ if $opts{"to_$_"};
+        $from++ if $opts{"from_$_"};
+    }
+    error("exactly one to_* parameter is needed") if $to != 1;
+    error("exactly one from_* parameter is needed") if $from != 1;
+    return %opts;
+}
+
+sub compress {
+    my $self = shift;
+    my %opts = $self->_sanity_check(@_);
+    my @prog = $self->get_compress_cmdline();
+    $opts{"exec"} = \@prog;
+    $self->{"cmdline"} = "@prog";
+    $self->{"pid"} = fork_and_exec(%opts);
+    delete $self->{"pid"} if $opts{"to_string"}; # wait_child already done
+}
+
+sub uncompress {
+    my $self = shift;
+    my %opts = $self->_sanity_check(@_);
+    my @prog = $self->get_uncompress_cmdline();
+    $opts{"exec"} = \@prog;
+    $self->{"cmdline"} = "@prog";
+    $self->{"pid"} = fork_and_exec(%opts);
+    delete $self->{"pid"} if $opts{"to_string"}; # wait_child already done
+}
+
+sub wait_end_process {
+    my ($self) = @_;
+    wait_child($self->{"pid"}, cmdline => $self->{"cmdline"}) if $self->{'pid'};
+    delete $self->{"pid"};
+    delete $self->{"cmdline"};
+}
+
+1;

scripts/Dpkg/Source/Functions.pm

@@ -0,0 +1,53 @@
+package Dpkg::Source::Functions;
+
+use strict;
+use warnings;
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(erasedir fixperms);
+
+use Dpkg::ErrorHandling qw(syserr subprocerr failure);
+use Dpkg::Gettext;
+
+use POSIX;
+
+sub erasedir {
+    my ($dir) = @_;
+    if (not lstat($dir)) {
+        return if $! == ENOENT;
+        syserr(_g("cannot stat directory %s (before removal)"), $dir);
+    }
+    system 'rm','-rf','--',$dir;
+    subprocerr("rm -rf $dir") if $?;
+    if (not stat($dir)) {
+        return if $! == ENOENT;
+        syserr(_g("unable to check for removal of dir `%s'"), $dir);
+    }
+    failure(_g("rm -rf failed to remove `%s'"), $dir);
+}
+
+sub fixperms {
+    my ($dir) = @_;
+    my ($mode, $modes_set, $i, $j);
+    # Unfortunately tar insists on applying our umask _to the original
+    # permissions_ rather than mostly-ignoring the original
+    # permissions.  We fix it up with chmod -R (which saves us some
+    # work) but we have to construct a u+/- string which is a bit
+    # of a palaver.  (Numeric doesn't work because we need [ugo]+X
+    # and [ugo]=<stuff> doesn't work because that unsets sgid on dirs.)
+    $mode = 0777 & ~umask;
+    for ($i = 0; $i < 9; $i += 3) {
+        $modes_set .= ',' if $i;
+        $modes_set .= qw(u g o)[$i/3];
+        for ($j = 0; $j < 3; $j++) {
+            $modes_set .= $mode & (0400 >> ($i+$j)) ? '+' : '-';
+            $modes_set .= qw(r w X)[$j];
+        }
+    }
+    system('chmod', '-R', $modes_set, '--', $dir);
+    subprocerr("chmod -R $modes_set $dir") if $?;
+}
+
+# vim: set et sw=4 ts=8
+1;

scripts/Dpkg/Source/Package.pm

@@ -0,0 +1,415 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Package;
+
+use strict;
+use warnings;
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(error syserr warning internerr);
+use Dpkg::Fields;
+use Dpkg::Cdata;
+use Dpkg::Checksums;
+use Dpkg::Version qw(parseversion);
+use Dpkg::Deps qw(@src_dep_fields);
+use Dpkg::Compression;
+use Dpkg::Exit;
+use Dpkg::Path qw(check_files_are_the_same);
+
+use POSIX;
+use File::Basename;
+
+# Public variables
+our $diff_ignore_default_regexp = '
+# Ignore general backup files
+(?:^|/).*~$|
+# Ignore emacs recovery files
+(?:^|/)\.#.*$|
+# Ignore vi swap files
+(?:^|/)\..*\.swp$|
+# Ignore baz-style junk files or directories
+(?:^|/),,.*(?:$|/.*$)|
+# File-names that should be ignored (never directories)
+(?:^|/)(?:DEADJOE|\.cvsignore|\.arch-inventory|\.bzrignore|\.gitignore)$|
+# File or directory names that should be ignored
+(?:^|/)(?:CVS|RCS|\.deps|\{arch\}|\.arch-ids|\.svn|\.hg|_darcs|\.git|
+\.shelf|_MTN|\.bzr(?:\.backup|tags)?)(?:$|/.*$)
+';
+# Take out comments and newlines
+$diff_ignore_default_regexp =~ s/^#.*$//mg;
+$diff_ignore_default_regexp =~ s/\n//sg;
+no warnings 'qw';
+our @tar_ignore_default_pattern = qw(
+*.a
+*.la
+*.o
+*.so
+*.swp
+*~
+,,*
+.[#~]*
+.arch-ids
+.arch-inventory
+.bzr
+.bzr.backup
+.bzr.tags
+.bzrignore
+.cvsignore
+.deps
+.git
+.gitignore
+.hg
+.shelf
+.svn
+CVS
+DEADJOE
+RCS
+_MTN
+_darcs
+{arch}
+);
+
+# Private stuff
+my @dsc_fields = (qw(Format Source Binary Architecture Version Origin
+		     Maintainer Uploaders Dm-Upload-Allowed Homepage
+		     Standards-Version Vcs-Browser Vcs-Arch Vcs-Bzr
+		     Vcs-Cvs Vcs-Darcs Vcs-Git Vcs-Hg Vcs-Mtn Vcs-Svn),
+                  @src_dep_fields,
+                  qw(Files));
+
+# Object methods
+sub new {
+    my ($this, %args) = @_;
+    my $class = ref($this) || $this;
+    my $self = {
+        'fields' => Dpkg::Fields::Object->new(),
+        'options' => {},
+    };
+    bless $self, $class;
+    if (exists $args{"filename"}) {
+        $self->initialize($args{"filename"});
+    }
+    if (exists $args{"options"}) {
+        $self->{'options'} = $args{'options'};
+    }
+    $self->init_options();
+    return $self;
+}
+
+sub init_options {
+    my ($self) = @_;
+    # Use full ignore list by default
+    $self->{'options'}{'diff_ignore_regexp'} ||= $diff_ignore_default_regexp;
+    $self->{'options'}{'tar_ignore'} = [ @tar_ignore_default_pattern ]
+            unless @{$self->{'options'}{'tar_ignore'}};
+}
+
+sub initialize {
+    my ($self, $filename) = @_;
+    my ($fn, $dir) = fileparse($filename);
+    error(_g("%s is not the name of a file"), $filename) unless $fn;
+    $self->{'basedir'} = $dir || "./";
+    $self->{'filename'} = $fn;
+
+    # Check if it contains a signature
+    open(DSC, "<", $filename) || syserr(_g("cannot open %s"), $filename);
+    $self->{'is_signed'} = 0;
+    while (<DSC>) {
+        next if /^\s*$/o;
+        $self->{'is_signed'} = 1 if /^-----BEGIN PGP SIGNED MESSAGE-----$/o;
+        last;
+    }
+    close(DSC);
+    # Read the fields
+    open(CDATA, "<", $filename) || syserr(_g("cannot open %s"), $filename);
+    my $fields = parsecdata(\*CDATA,
+            sprintf(_g("source control file %s"), $filename),
+            allow_pgp => 1);
+    close(CDATA);
+    $self->{'fields'} = $fields;
+
+    foreach my $f (qw(Source Format Version Files)) {
+        unless (defined($fields->{$f})) {
+            error(_g("missing critical source control field %s"), $f);
+        }
+    }
+
+    $self->parse_files();
+
+    $self->upgrade_object_type();
+}
+
+sub upgrade_object_type {
+    my ($self) = @_;
+    my $format = $self->{'fields'}{'Format'};
+
+    if ($format =~ /^([\d\.]+)(?:\s+\((.*)\))?$/) {
+        my ($version, $variant) = ($1, $2);
+        $version =~ s/\./_/;
+        my $module = "Dpkg::Source::Package::V$version";
+        $module .= "::$variant" if defined $variant;
+        eval "require $module";
+        if ($@) {
+	    error(_g("source package format `%s' is not supported (Perl module %s is required)"), $format, $module);
+        }
+        bless $self, $module;
+    } else {
+        error(_g("invalid Format field `%s'"), $format);
+    }
+}
+
+sub get_filename {
+    my ($self) = @_;
+    return $self->{'basedir'} . $self->{'filename'};
+}
+
+sub get_files {
+    my ($self) = @_;
+    return keys %{$self->{'files'}};
+}
+
+sub parse_files {
+    my ($self) = @_;
+    my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/;
+    my $files = $self->{'fields'}{'Files'};
+    foreach my $file (split(/\n /, $files)) {
+        next if $file eq '';
+        $file =~ m/^($check_regex{md5})                    # checksum
+                    [ \t]+(\d+)                            # size
+                    [ \t]+($rx_fname)                      # filename
+                  $/x
+          || error(_g("Files field contains bad line `%s'"), $file);
+        if (exists $self->{'files'}{$3}) {
+            error(_g("file `%s' listed twice in Files field"), $3);
+        } else {
+            $self->{'files'}{$3} = $2;
+        }
+    }
+}
+
+sub check_checksums {
+    my ($self) = @_;
+    my ($fields, %checksum, %size) = $self->{'fields'};
+    my $has_md5 = 1;
+    if (not exists $fields->{'Checksums-Md5'}) {
+        $fields->{'Checksums-Md5'} = $fields->{'Files'};
+        $has_md5 = 0;
+    }
+    # extract the checksums from the fields in two hashes
+    readallchecksums($self->{'fields'}, \%checksum, \%size);
+    delete $fields->{'Checksums-Md5'} unless $has_md5;
+    # getchecksums verify the checksums if they are pre-filled
+    foreach my $file ($self->get_files()) {
+        getchecksums($self->{'basedir'} . $file, $checksum{$file},
+                     \$size{$file});
+    }
+}
+
+sub get_basename {
+    my ($self, $with_revision) = @_;
+    my $f = $self->{'fields'};
+    unless (exists $f->{'Source'} and exists $f->{'Version'}) {
+        error(_g("source and version are required to compute the source basename"));
+    }
+    my %v = parseversion($f->{'Version'});
+    my $basename = $f->{'Source'} . "_" . $v{"version"};
+    if ($with_revision and $f->{'Version'} =~ /-/) {
+        $basename .= "-" . $v{'revision'};
+    }
+    return $basename;
+}
+
+sub find_original_tarballs {
+    my ($self, $ext) = @_;
+    $ext ||= $comp_regex;
+    my $basename = $self->get_basename();
+    my @tar;
+    foreach my $dir (".", $self->{'basedir'}, $self->{'options'}{'origtardir'}) {
+        next unless defined($dir) and -d $dir;
+        opendir(DIR, $dir) || syserr(_g("cannot opendir %s"), $dir);
+        push @tar, map { "$dir/$_" }
+                  grep { /^\Q$basename\E\.orig(-\w+)?\.tar\.$ext$/ }
+                  readdir(DIR);
+        closedir(DIR);
+    }
+    return @tar;
+}
+
+sub is_signed {
+    my $self = shift;
+    return $self->{'is_signed'};
+}
+
+sub check_signature {
+    my ($self) = @_;
+    my $dsc = $self->get_filename();
+    if (-x '/usr/bin/gpg') {
+        my $gpg_command = 'gpg -q --verify ';
+        if (-r '/usr/share/keyrings/debian-keyring.gpg') {
+            $gpg_command = $gpg_command.'--keyring /usr/share/keyrings/debian-keyring.gpg ';
+        }
+        $gpg_command = $gpg_command.quotemeta($dsc).' 2>&1';
+
+        #TODO: cleanup here
+        my @gpg_output = `$gpg_command`;
+        my $gpg_status = $? >> 8;
+        if ($gpg_status) {
+            print STDERR join("",@gpg_output);
+            error(_g("failed to verify signature on %s"), $dsc)
+                if ($gpg_status == 1);
+        }
+    } else {
+        warning(_g("could not verify signature on %s since gpg isn't installed"),
+                $dsc);
+    }
+}
+
+sub parse_cmdline_options {
+    my ($self, @opts) = @_;
+    foreach (@opts) {
+        if (not $self->parse_cmdline_option($_)) {
+            warning(_g("%s is not a valid option for %s"), $_, ref($self));
+        }
+    }
+}
+
+sub parse_cmdline_option {
+    return 0;
+}
+
+sub extract {
+    my $self = shift;
+    my $newdirectory = $_[0];
+
+    # Copy orig tarballs
+    if ($self->{'options'}{'copy_orig_tarballs'}) {
+        my $basename = $self->get_basename();
+        my ($dirname, $destdir) = fileparse($newdirectory);
+        $destdir ||= "./";
+        foreach my $orig (grep { /^\Q$basename\E\.orig(-\w+)?\.tar\.$comp_regex$/ }
+                          $self->get_files())
+        {
+            my $src = File::Spec->catfile($self->{'basedir'}, $orig);
+            my $dst = File::Spec->catfile($destdir, $orig);
+            if (not check_files_are_the_same($src, $dst)) {
+                system('cp', '--', $src, $dst);
+                subprocerr("cp $src to $dst") if $?;
+            }
+        }
+    }
+
+    # Try extract
+    eval { $self->do_extract(@_) };
+    if ($@) {
+        &$_() foreach reverse @Dpkg::Exit::handlers;
+        die $@;
+    }
+
+    # Make sure debian/rules is executable
+    my $rules = File::Spec->catfile($newdirectory, "debian", "rules");
+    my @s = lstat($rules);
+    if (not scalar(@s)) {
+        unless ($! == ENOENT) {
+            syserr(_g("cannot stat %s"), $rules);
+        }
+        warning(_g("%s does not exist"), $rules);
+    } elsif (-f _) {
+        chmod($s[2] | 0111, $rules) ||
+            syserr(_g("cannot make %s executable"), $rules);
+    } else {
+        warning(_g("%s is not a plain file"), $rules);
+    }
+}
+
+sub do_extract {
+    error("Dpkg::Source::Package doesn't know how to unpack a source package. Use one of the subclasses.");
+}
+
+# Function used specifically during creation of a source package
+
+sub build {
+    my $self = shift;
+    eval { $self->do_build(@_) };
+    if ($@) {
+        &$_() foreach reverse @Dpkg::Exit::handlers;
+        die $@;
+    }
+}
+
+sub do_build {
+    error("Dpkg::Source::Package doesn't know how to build a source package. Use one of the subclasses.");
+}
+
+sub can_build {
+    my ($self, $dir) = @_;
+    return (0, "can_build() has not been overriden");
+}
+
+sub add_file {
+    my ($self, $filename) = @_;
+    my ($fn, $dir) = fileparse($filename);
+    if (exists $self->{'files'}{$fn}) {
+        internerr(_g("tried to add file `%s' twice"), $fn);
+    }
+    my (%sums, $size);
+    getchecksums($filename, \%sums, \$size);
+    $self->{'files'}{$fn} = $size;
+    foreach my $alg (sort keys %sums) {
+        $self->{'fields'}{"Checksums-$alg"} .= "\n $sums{$alg} $size $fn";
+    }
+    $self->{'fields'}{'Files'}.= "\n $sums{md5} $size $fn";
+}
+
+sub write_dsc {
+    my ($self, %opts) = @_;
+    my $fields = $self->{'fields'};
+
+    foreach my $f (keys %{$opts{'override'}}) {
+	$fields->{$f} = $opts{'override'}{$f};
+    }
+
+    unless($opts{'nocheck'}) {
+        foreach my $f (qw(Source Version)) {
+            unless (defined($fields->{$f})) {
+                error(_g("missing information for critical output field %s"), $f);
+            }
+        }
+        foreach my $f (qw(Maintainer Architecture Standards-Version)) {
+            unless (defined($fields->{$f})) {
+                warning(_g("missing information for output field %s"), $f);
+            }
+        }
+    }
+
+    foreach my $f (keys %{$opts{'remove'}}) {
+	delete $fields->{$f};
+    }
+
+    my $filename = $opts{'filename'};
+    unless (defined $filename) {
+        $filename = $self->get_basename(1) . ".dsc";
+    }
+    open(DSC, ">", $filename) || syserr(_g("cannot write %s"), $filename);
+
+    delete $fields->{'Checksums-Md5'}; # identical with Files field
+    tied(%{$fields})->set_field_importance(@dsc_fields);
+    tied(%{$fields})->output(\*DSC, $opts{'substvars'});
+    close(DSC);
+}
+
+# vim: set et sw=4 ts=8
+1;

scripts/Dpkg/Source/Package/V1_0.pm

@@ -0,0 +1,363 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Package::V1_0;
+
+use strict;
+use warnings;
+
+use base 'Dpkg::Source::Package';
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(error syserr warning usageerr subprocerr info);
+use Dpkg::Compression;
+use Dpkg::Source::Archive;
+use Dpkg::Source::Patch;
+use Dpkg::Version qw(check_version);
+use Dpkg::Exit;
+use Dpkg::Source::Functions qw(erasedir);
+use Dpkg::Source::Package::V3_0::native;
+use Dpkg::Path qw(check_files_are_the_same);
+
+use POSIX;
+use File::Basename;
+use File::Temp qw(tempfile);
+use File::Spec;
+
+sub init_options {
+    my ($self) = @_;
+    # Don't call $self->SUPER::init_options() on purpose, V1.0 has no
+    # ignore by default
+    $self->{'options'}{'sourcestyle'} ||= 'X';
+}
+
+sub parse_cmdline_option {
+    my ($self, $opt) = @_;
+    my $o = $self->{'options'};
+    if ($opt =~ m/^-s([akpursnAKPUR])$/) {
+        warning(_g("-s%s option overrides earlier -s%s option"), $1,
+                $o->{'sourcestyle'}) if $o->{'sourcestyle'} ne 'X';
+        $o->{'sourcestyle'} = $1;
+        $o->{'copy_orig_tarballs'} = 0 if $1 eq 'n'; # Extract option -sn
+        return 1;
+    }
+    return 0;
+}
+
+sub do_extract {
+    my ($self, $newdirectory) = @_;
+    my $sourcestyle = $self->{'options'}{'sourcestyle'};
+    my $fields = $self->{'fields'};
+
+    $sourcestyle =~ y/X/p/;
+    $sourcestyle =~ m/[pun]/ ||
+	usageerr(_g("source handling style -s%s not allowed with -x"),
+	         $sourcestyle);
+
+    my $dscdir = $self->{'basedir'};
+
+    check_version($fields->{'Version'});
+
+    my $basename = $self->get_basename();
+    my $basenamerev = $self->get_basename(1);
+
+    # V1.0 only supports gzip compression
+    my ($tarfile, $difffile);
+    foreach my $file ($self->get_files()) {
+	if ($file =~ /^(?:\Q$basename\E\.orig|\Q$basenamerev\E)\.tar\.gz$/) {
+            error(_g("multiple tarfiles in v1.0 source package")) if $tarfile;
+            $tarfile = $file;
+	} elsif ($file =~ /^\Q$basenamerev\E\.diff\.gz$/) {
+	    $difffile = $file;
+	} else {
+	    error(_g("unrecognized file for a %s source package: %s"),
+                  "v1.0", $file);
+	}
+    }
+
+    error(_g("no tarfile in Files field")) unless $tarfile;
+    my $native = $difffile ? 0 : 1;
+    if ($native and ($tarfile =~ /\.orig\.tar\.gz$/)) {
+        warning(_g("native package with .orig.tar"));
+        $native = 0; # V3_0::native doesn't handle orig.tar
+    }
+
+    if ($native) {
+        Dpkg::Source::Package::V3_0::native::do_extract($self, $newdirectory);
+    } else {
+        my $expectprefix = $newdirectory;
+        $expectprefix .= '.orig';
+
+        erasedir($newdirectory);
+        if (-e $expectprefix) {
+            rename($expectprefix, "$newdirectory.tmp-keep") ||
+                    syserr(_g("unable to rename `%s' to `%s'"), $expectprefix,
+                           "$newdirectory.tmp-keep");
+        }
+
+        info(_g("unpacking %s"), $tarfile);
+        my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
+        $tar->extract($expectprefix);
+
+        if ($sourcestyle =~ /u/) {
+            # -su: keep .orig directory unpacked
+            if (-e "$newdirectory.tmp-keep") {
+                error(_g("unable to keep orig directory (already exists)"));
+            }
+            system('cp', '-ar', '--', $expectprefix, "$newdirectory.tmp-keep");
+            subprocerr("cp $expectprefix to $newdirectory.tmp-keep") if $?;
+        }
+
+	rename($expectprefix, $newdirectory) ||
+	    syserr(_g("failed to rename newly-extracted %s to %s"),
+	           $expectprefix, $newdirectory);
+
+	# rename the copied .orig directory
+	if (-e "$newdirectory.tmp-keep") {
+	    rename("$newdirectory.tmp-keep", $expectprefix) ||
+                    syserr(_g("failed to rename saved %s to %s"),
+	                   "$newdirectory.tmp-keep", $expectprefix);
+        }
+    }
+
+    if ($difffile) {
+        my $patch = "$dscdir$difffile";
+	info(_g("applying %s"), $difffile);
+	my $patch_obj = Dpkg::Source::Patch->new(filename => $patch);
+	$patch_obj->apply($newdirectory, force_timestamp => 1,
+                          timestamp => time());
+    }
+}
+
+sub can_build {
+    my ($self, $dir) = @_;
+    # As long as we can use gzip, we can do it as we have
+    # native packages as fallback
+    return ($self->{'options'}{'compression'} eq "gzip",
+            _g("only supports gzip compression"));
+}
+
+sub do_build {
+    my ($self, $dir) = @_;
+    my $sourcestyle = $self->{'options'}{'sourcestyle'};
+    my @argv = @{$self->{'options'}{'ARGV'}};
+    my @tar_ignore = map { "--exclude=$_" } @{$self->{'options'}{'tar_ignore'}};
+    my $diff_ignore_regexp = $self->{'options'}{'diff_ignore_regexp'};
+
+    if (scalar(@argv) > 1) {
+        usageerr(_g("-b takes at most a directory and an orig source ".
+                    "argument (with v1.0 source package)"));
+    }
+
+    $sourcestyle =~ y/X/A/;
+    unless ($sourcestyle =~ m/[akpursnAKPUR]/) {
+        usageerr(_g("source handling style -s%s not allowed with -b"),
+                 $sourcestyle);
+    }
+
+    my $sourcepackage = $self->{'fields'}{'Source'};
+    my $basenamerev = $self->get_basename(1);
+    my $basename = $self->get_basename();
+    my $basedirname = $basename;
+    $basedirname =~ s/_/-/;
+
+    # Try to find a .orig tarball for the package
+    my $origdir = "$dir.orig";
+    my $origtargz = $self->get_basename() . ".orig.tar.gz";
+    if (-e $origtargz) {
+        unless (-f $origtargz) {
+            error(_g("packed orig `%s' exists but is not a plain file"), $origtargz);
+        }
+    } else {
+        $origtargz = undef;
+    }
+
+    if (@argv) {
+	# We have a second-argument <orig-dir> or <orig-targz>, check what it
+	# is to decide the mode to use
+        my $origarg = shift(@argv);
+        if (length($origarg)) {
+            stat($origarg) ||
+                syserr(_g("cannot stat orig argument %s"), $origarg);
+            if (-d _) {
+                $origdir = File::Spec->catdir($origarg);
+
+                $sourcestyle =~ y/aA/rR/;
+                unless ($sourcestyle =~ m/[ursURS]/) {
+                    error(_g("orig argument is unpacked but source handling " .
+                             "style -s%s calls for packed (.orig.tar.<ext>)"),
+                          $sourcestyle);
+                }
+            } elsif (-f _) {
+                $origtargz = $origarg;
+                $sourcestyle =~ y/aA/pP/;
+                unless ($sourcestyle =~ m/[kpsKPS]/) {
+                    error(_g("orig argument is packed but source handling " .
+                             "style -s%s calls for unpacked (.orig/)"),
+                          $sourcestyle);
+                }
+            } else {
+                error("orig argument $origarg is not a plain file or directory");
+            }
+        } else {
+            $sourcestyle =~ y/aA/nn/;
+            $sourcestyle =~ m/n/ ||
+                error(_g("orig argument is empty (means no orig, no diff) " .
+                         "but source handling style -s%s wants something"),
+                      $sourcestyle);
+        }
+    } elsif ($sourcestyle =~ m/[aA]/) {
+	# We have no explicit <orig-dir> or <orig-targz>, try to use
+	# a .orig tarball first, then a .orig directory and fall back to
+	# creating a native .tar.gz
+	if ($origtargz) {
+	    $sourcestyle =~ y/aA/pP/; # .orig.tar.<ext>
+	} else {
+	    if (stat($origdir)) {
+		unless (-d _) {
+                    error(_g("unpacked orig `%s' exists but is not a directory"),
+		          $origdir);
+                }
+		$sourcestyle =~ y/aA/rR/; # .orig directory
+	    } elsif ($! != ENOENT) {
+		syserr(_g("unable to stat putative unpacked orig `%s'"), $origdir);
+	    } else {
+		$sourcestyle =~ y/aA/nn/; # Native tar.gz
+	    }
+	}
+    }
+
+    my ($dirname, $dirbase) = fileparse($dir);
+    if ($dirname ne $basedirname) {
+	warning(_g("source directory '%s' is not <sourcepackage>" .
+	           "-<upstreamversion> '%s'"), $dir, $basedirname);
+    }
+
+    my ($tarname, $tardirname, $tardirbase, $origdirname);
+    if ($sourcestyle ne 'n') {
+	my ($origdirname, $origdirbase) = fileparse($origdir);
+
+        if ($origdirname ne "$basedirname.orig") {
+            warning(_g(".orig directory name %s is not <package>" .
+	               "-<upstreamversion> (wanted %s)"),
+	            $origdirname, "$basedirname.orig");
+        }
+        $tardirbase = $origdirbase;
+        $tardirname = $origdirname;
+
+	$tarname = $origtargz || "$basename.orig.tar.gz";
+	unless ($tarname =~ /\Q$basename\E\.orig\.tar\.gz/) {
+	    warning(_g(".orig.tar name %s is not <package>_<upstreamversion>" .
+	               ".orig.tar (wanted %s)"),
+	            $tarname, "$basename.orig.tar.gz");
+	}
+    }
+
+    if ($sourcestyle eq "n") {
+        $self->{'options'}{'ARGV'} = []; # ensure we have no error
+        Dpkg::Source::Package::V3_0::native::do_build($self, $dir);
+    } elsif ($sourcestyle =~ m/[nurUR]/) {
+        if (stat($tarname)) {
+            unless ($sourcestyle =~ m/[nUR]/) {
+		error(_g("tarfile `%s' already exists, not overwriting, " .
+		         "giving up; use -sU or -sR to override"), $tarname);
+            }
+        } elsif ($! != ENOENT) {
+	    syserr(_g("unable to check for existence of `%s'"), $tarname);
+        }
+
+	info(_g("building %s in %s"),
+	     $sourcepackage, $tarname);
+
+	my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX",
+				       DIR => getcwd(), UNLINK => 0);
+	my $tar = Dpkg::Source::Archive->new(filename => $newtar,
+		    compression => get_compression_from_filename($tarname),
+		    compression_level => $self->{'options'}{'comp_level'});
+	$tar->create(options => \@tar_ignore, 'chdir' => $tardirbase);
+	$tar->add_directory($tardirname);
+	$tar->finish();
+        rename($newtar, $tarname) ||
+            syserr(_g("unable to rename `%s' (newly created) to `%s'"),
+                   $newtar, $tarname);
+	chmod(0666 &~ umask(), $tarname) ||
+	    syserr(_g("unable to change permission of `%s'"), $tarname);
+    } else {
+	info(_g("building %s using existing %s"),
+	     $sourcepackage, $tarname);
+    }
+
+    $self->add_file($tarname) if $tarname;
+
+    if ($sourcestyle =~ m/[kpKP]/) {
+        if (stat($origdir)) {
+            unless ($sourcestyle =~ m/[KP]/) {
+                error(_g("orig dir `%s' already exists, not overwriting, ".
+                         "giving up; use -sA, -sK or -sP to override"),
+                      $origdir);
+            }
+	    push @Dpkg::Exit::handlers, sub { erasedir($origdir) };
+            erasedir($origdir);
+	    pop @Dpkg::Exit::handlers;
+        } elsif ($! != ENOENT) {
+            syserr(_g("unable to check for existence of orig dir `%s'"),
+                    $origdir);
+        }
+
+	my $tar = Dpkg::Source::Archive->new(filename => $origtargz);
+	$tar->extract($origdir);
+    }
+
+    my $ur; # Unrepresentable changes
+    if ($sourcestyle =~ m/[kpursKPUR]/) {
+	my $diffname = "$basenamerev.diff.gz";
+	info(_g("building %s in %s"),
+	     $sourcepackage, $diffname);
+	my ($ndfh, $newdiffgz) = tempfile("$diffname.new.XXXXXX",
+					DIR => getcwd(), UNLINK => 0);
+        push @Dpkg::Exit::handlers, sub { unlink($newdiffgz) };
+        my $diff = Dpkg::Source::Patch->new(filename => $newdiffgz,
+                                            compression => "gzip");
+        $diff->create();
+        $diff->add_diff_directory($origdir, $dir,
+                basedirname => $basedirname,
+                diff_ignore_regexp => $diff_ignore_regexp);
+        $diff->finish() || $ur++;
+        pop @Dpkg::Exit::handlers;
+
+	rename($newdiffgz, $diffname) ||
+	    syserr(_g("unable to rename `%s' (newly created) to `%s'"),
+	           $newdiffgz, $diffname);
+	chmod(0666 &~ umask(), $diffname) ||
+	    syserr(_g("unable to change permission of `%s'"), $diffname);
+
+	$self->add_file($diffname);
+    }
+
+    if ($sourcestyle =~ m/[prPR]/) {
+        erasedir($origdir);
+    }
+
+    if ($ur) {
+        printf(STDERR _g("%s: unrepresentable changes to source")."\n",
+               $progname);
+        exit(1);
+    }
+}
+
+# vim: set et sw=4 ts=8
+1;

scripts/Dpkg/Source/Package/V2_0.pm

@@ -0,0 +1,347 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Package::V2_0;
+
+use strict;
+use warnings;
+
+use base 'Dpkg::Source::Package';
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(error errormsg syserr warning usageerr subprocerr info);
+use Dpkg::Compression;
+use Dpkg::Source::Archive;
+use Dpkg::Source::Patch;
+use Dpkg::Version qw(check_version);
+use Dpkg::Exit;
+use Dpkg::Source::Functions qw(erasedir);
+
+use POSIX;
+use File::Basename;
+use File::Temp qw(tempfile tempdir);
+use File::Path;
+use File::Spec;
+use File::Find;
+
+sub init_options {
+    my ($self) = @_;
+    $self->SUPER::init_options();
+    $self->{'options'}{'include_removal'} = 0
+        unless exists $self->{'options'}{'include_removal'};
+    $self->{'options'}{'include_timestamp'} = 0
+        unless exists $self->{'options'}{'include_timestamp'};
+    $self->{'options'}{'include_binaries'} = 0
+        unless exists $self->{'options'}{'include_binaries'};
+}
+
+sub parse_cmdline_option {
+    my ($self, $opt) = @_;
+    if ($opt =~ /^--include-removal$/) {
+        $self->{'options'}{'include_removal'} = 1;
+        return 1;
+    } elsif ($opt =~ /^--include-timestamp$/) {
+        $self->{'options'}{'include_timestamp'} = 1;
+        return 1;
+    } elsif ($opt =~ /^--include-binaries$/) {
+        $self->{'options'}{'include_binaries'} = 1;
+        return 1;
+    }
+    return 0;
+}
+
+sub do_extract {
+    my ($self, $newdirectory) = @_;
+    my $fields = $self->{'fields'};
+
+    my $dscdir = $self->{'basedir'};
+
+    check_version($fields->{'Version'});
+
+    my $basename = $self->get_basename();
+    my $basenamerev = $self->get_basename(1);
+
+    my ($tarfile, $debianfile, %origtar, %seen);
+    foreach my $file ($self->get_files()) {
+        (my $uncompressed = $file) =~ s/\.$comp_regex$//;
+        error(_g("duplicate files in %s source package: %s.*"), "v2.0",
+              $uncompressed) if $seen{$uncompressed};
+        $seen{$uncompressed} = 1;
+        if ($file =~ /^\Q$basename\E\.orig\.tar\.$comp_regex$/) {
+            $tarfile = $file;
+        } elsif ($file =~ /^\Q$basename\E\.orig-(\w+)\.tar\.$comp_regex$/) {
+            $origtar{$1} = $file;
+        } elsif ($file =~ /^\Q$basenamerev\E\.debian\.tar\.$comp_regex$/) {
+            $debianfile = $file;
+        } else {
+            error(_g("unrecognized file for a %s source package: %s"),
+            "v2.0", $file);
+        }
+    }
+
+    unless ($tarfile and $debianfile) {
+        error(_g("missing orig.tar or debian.tar file in v2.0 source package"));
+    }
+
+    erasedir($newdirectory);
+
+    # Extract main tarball
+    info(_g("unpacking %s"), $tarfile);
+    my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
+    $tar->extract($newdirectory, no_fixperms => 1);
+
+    # Extract additional orig tarballs
+    foreach my $subdir (keys %origtar) {
+        my $file = $origtar{$subdir};
+        info(_g("unpacking %s"), $file);
+        if (-e "$newdirectory/$subdir") {
+            warning(_g("required removal of `%s' installed by original tarball"), $subdir);
+            erasedir("$newdirectory/$subdir");
+        }
+        $tar = Dpkg::Source::Archive->new(filename => "$dscdir$file");
+        $tar->extract("$newdirectory/$subdir", no_fixperms => 1);
+    }
+
+    # Extract debian tarball after removing the debian directory
+    info(_g("unpacking %s"), $debianfile);
+    erasedir("$newdirectory/debian");
+    # Exclude existing symlinks from extraction of debian.tar.gz as we
+    # don't want to overwrite something outside of $newdirectory due to a
+    # symlink
+    my @exclude_symlinks;
+    my $wanted = sub {
+        return if not -l $_;
+        my $fn = File::Spec->abs2rel($_, $newdirectory);
+        push @exclude_symlinks, "--exclude", $fn;
+    };
+    find({ wanted => $wanted, no_chdir => 1 }, $newdirectory);
+    $tar = Dpkg::Source::Archive->new(filename => "$dscdir$debianfile");
+    $tar->extract($newdirectory, in_place => 1,
+                  options => [ '--anchored', '--no-wildcards',
+                  @exclude_symlinks ]);
+
+    # Apply patches (in a separate method as it might be overriden)
+    $self->apply_patches($newdirectory);
+}
+
+sub get_autopatch_name {
+    return "zz_debian-diff-auto";
+}
+
+sub get_patches {
+    my ($self, $dir, $skip_auto) = @_;
+    my @patches;
+    my $pd = "$dir/debian/patches";
+    my $auto_patch = $self->get_autopatch_name();
+    if (-d $pd) {
+        opendir(DIR, $pd) || syserr(_g("cannot opendir %s"), $pd);
+        foreach my $patch (sort readdir(DIR)) {
+            # patches match same rules as run-parts
+            next unless $patch =~ /^[\w-]+$/ and -f "$pd/$patch";
+            next if $skip_auto and $patch eq $auto_patch;
+            push @patches, $patch;
+        }
+        closedir(DIR);
+    }
+    return @patches;
+}
+
+sub apply_patches {
+    my ($self, $dir, $skip_auto) = @_;
+    my $timestamp = time();
+    foreach my $patch ($self->get_patches($dir, $skip_auto)) {
+        my $path = File::Spec->catfile($dir, "debian", "patches", $patch);
+        info(_g("applying %s"), $patch) unless $skip_auto;
+        my $patch_obj = Dpkg::Source::Patch->new(filename => $path);
+        $patch_obj->apply($dir, force_timestamp => 1,
+                          timestamp => $timestamp,
+                          add_options => [ '-E' ]);
+    }
+}
+
+sub can_build {
+    my ($self, $dir) = @_;
+    foreach ($self->find_original_tarballs()) {
+        return 1 if /\.orig\.tar\.$comp_regex$/;
+    }
+    return (0, _g("no orig.tar file found"));
+}
+
+sub prepare_build {
+    my ($self, $dir) = @_;
+    $self->{'diff_options'} = {
+        diff_ignore_regexp => $self->{'options'}{'diff_ignore_regexp'},
+        include_removal => $self->{'options'}{'include_removal'},
+        include_timestamp => $self->{'options'}{'include_timestamp'},
+    };
+}
+
+sub do_build {
+    my ($self, $dir) = @_;
+    my @argv = @{$self->{'options'}{'ARGV'}};
+    my @tar_ignore = map { "--exclude=$_" } @{$self->{'options'}{'tar_ignore'}};
+    my $include_binaries = $self->{'options'}{'include_binaries'};
+
+    my ($dirname, $updir) = fileparse($dir);
+    if (scalar(@argv)) {
+        usageerr(_g("-b takes only one parameter with format `%s'"),
+                 $self->{'fields'}{'Format'});
+    }
+    $self->prepare_build($dir);
+
+    my $sourcepackage = $self->{'fields'}{'Source'};
+    my $basenamerev = $self->get_basename(1);
+    my $basename = $self->get_basename();
+    my $basedirname = $basename;
+    $basedirname =~ s/_/-/;
+
+    # Identify original tarballs
+    my ($tarfile, %origtar);
+    my @origtarballs;
+    foreach (sort $self->find_original_tarballs()) {
+        if (/\.orig\.tar\.$comp_regex$/) {
+            $tarfile = $_;
+            push @origtarballs, $_;
+            $self->add_file($_);
+        } elsif (/\.orig-(\w+)\.tar\.$comp_regex$/) {
+            $origtar{$1} = $_;
+            push @origtarballs, $_;
+            $self->add_file($_);
+        }
+    }
+
+    error(_g("no orig.tar file found")) unless $tarfile;
+
+    info(_g("building %s using existing %s"),
+	 $sourcepackage, "@origtarballs");
+
+    # Unpack a second copy for comparison
+    my $tmp = tempdir("$dirname.orig.XXXXXX", DIR => $updir);
+    push @Dpkg::Exit::handlers, sub { erasedir($tmp) };
+
+    # Extract main tarball
+    my $tar = Dpkg::Source::Archive->new(filename => $tarfile);
+    $tar->extract($tmp);
+
+    # Extract additional orig tarballs
+    foreach my $subdir (keys %origtar) {
+        my $file = $origtar{$subdir};
+        $tar = Dpkg::Source::Archive->new(filename => $file);
+        $tar->extract("$tmp/$subdir");
+    }
+
+    # Copy over the debian directory
+    system("cp", "-a", "--", "$dir/debian", "$tmp/");
+    subprocerr(_g("copy of the debian directory")) if $?;
+
+    # Apply all patches except the last automatic one
+    $self->apply_patches($tmp, 1);
+
+    # Prepare handling of binary files
+    my %auth_bin_files;
+    my $incbin_file = File::Spec->catfile($dir, "debian", "source", "include-binaries");
+    if (-f $incbin_file) {
+        open(INC, "<", $incbin_file) || syserr(_g("can't read %s"), $incbin_file);
+        while(defined($_ = <INC>)) {
+            chomp; s/^\s*//; s/\s*$//;
+            next if /^#/;
+            $auth_bin_files{$_} = 1;
+        }
+        close(INC);
+    }
+    my @binary_files;
+    my $handle_binary = sub {
+        my ($self, $old, $new) = @_;
+        my $relfn = File::Spec->abs2rel($new, $dir);
+        # Include binaries if they are whitelisted or if
+        # --include-binaries has been given
+        if ($include_binaries or $auth_bin_files{$relfn}) {
+            push @binary_files, $relfn;
+        } else {
+            errormsg(_g("cannot represent change to %s: %s"), $new,
+                     _g("binary file contents changed"));
+            errormsg(_g("add %s in debian/source/include-binaries if you want" .
+                     " to store the modified binary in the debian tarball"),
+                     $relfn);
+            $self->register_error();
+        }
+    };
+
+    # Create a patch
+    my ($difffh, $tmpdiff) = tempfile("$basenamerev.diff.XXXXXX",
+                                      DIR => $updir, UNLINK => 0);
+    push @Dpkg::Exit::handlers, sub { unlink($tmpdiff) };
+    my $diff = Dpkg::Source::Patch->new(filename => $tmpdiff,
+                                        compression => "none");
+    $diff->create();
+    $diff->add_diff_directory($tmp, $dir, basedirname => $basedirname,
+            %{$self->{'diff_options'}}, handle_binary_func => $handle_binary);
+    error(_g("unrepresentable changes to source")) if not $diff->finish();
+    # The previous auto-patch must be removed, it has not been used and it
+    # will be recreated if it's still needed
+    my $autopatch = File::Spec->catfile($dir, "debian", "patches",
+                                        $self->get_autopatch_name());
+    if (-e $autopatch) {
+        unlink($autopatch) || syserr(_g("cannot remove %s"), $autopatch);
+    }
+    # Install the diff as the new autopatch
+    if (not -s $tmpdiff) {
+        unlink($tmpdiff) || syserr(_g("cannot remove %s"), $tmpdiff);
+    } else {
+        mkpath(File::Spec->catdir($dir, "debian", "patches"));
+        rename($tmpdiff, $autopatch) ||
+                syserr(_g("cannot rename %s to %s"), $tmpdiff, $autopatch);
+    }
+    $self->register_autopatch($dir);
+    pop @Dpkg::Exit::handlers;
+
+    # Remove the temporary directory
+    erasedir($tmp);
+    pop @Dpkg::Exit::handlers;
+
+    # Update debian/source/include-binaries if needed
+    if (scalar(@binary_files) and $include_binaries) {
+        mkpath(File::Spec->catdir($dir, "debian", "source"));
+        open(INC, ">>", $incbin_file) || syserr(_g("can't write %s"), $incbin_file);
+        foreach my $binary (@binary_files) {
+            unless ($auth_bin_files{$binary}) {
+                print INC "$binary\n";
+                info(_g("adding %s to %s"), $binary, "debian/source/include-binaries");
+            }
+        }
+        close(INC);
+    }
+    # Create the debian.tar
+    my $debianfile = "$basenamerev.debian.tar." . $self->{'options'}{'comp_ext'};
+    info(_g("building %s in %s"), $sourcepackage, $debianfile);
+    $tar = Dpkg::Source::Archive->new(filename => $debianfile);
+    $tar->create(options => \@tar_ignore, 'chdir' => $dir);
+    $tar->add_directory("debian");
+    foreach my $binary (@binary_files) {
+        $tar->add_file($binary);
+    }
+    $tar->finish();
+
+    $self->add_file($debianfile);
+}
+
+sub register_autopatch {
+    my ($self, $dir) = @_;
+}
+
+# vim:et:sw=4:ts=8
+1;

scripts/Dpkg/Source/Package/V3_0/bzr.pm

@@ -0,0 +1,207 @@
+#!/usr/bin/perl
+#
+# bzr support for dpkg-source
+#
+# Copyright © 2007 Colin Watson <cjwatson@debian.org>.
+# Based on Dpkg::Source::Package::V3_0::git, which is:
+# Copyright © 2007 Joey Hess <joeyh@debian.org>.
+# Copyright © 2008 Frank Lichtenheld <djpig@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
+package Dpkg::Source::Package::V3_0::bzr;
+
+use strict;
+use warnings;
+
+use base 'Dpkg::Source::Package';
+
+use Cwd;
+use File::Basename;
+use File::Find;
+use File::Temp qw(tempdir);
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::Compression;
+use Dpkg::ErrorHandling qw(error subprocerr syserr info);
+use Dpkg::Version qw(check_version);
+use Dpkg::Source::Archive;
+use Dpkg::Exit;
+use Dpkg::Source::Functions qw(erasedir);
+
+sub import {
+    foreach my $dir (split(/:/, $ENV{PATH})) {
+        if (-x "$dir/bzr") {
+            return 1;
+        }
+    }
+    error(_g("This source package can only be manipulated using bzr, which is not in the PATH."));
+}
+
+sub sanity_check {
+    my $srcdir = shift;
+
+    if (! -d "$srcdir/.bzr") {
+        error(_g("source directory is not the top directory of a bzr repository (%s/.bzr not present), but Format bzr was specified"),
+              $srcdir);
+    }
+
+    # Symlinks from .bzr to outside could cause unpack failures, or
+    # point to files they shouldn't, so check for and don't allow.
+    if (-l "$srcdir/.bzr") {
+        error(_g("%s is a symlink"), "$srcdir/.bzr");
+    }
+    my $abs_srcdir = Cwd::abs_path($srcdir);
+    find(sub {
+        if (-l $_) {
+            if (Cwd::abs_path(readlink($_)) !~ /^\Q$abs_srcdir\E(\/|$)/) {
+                error(_g("%s is a symlink to outside %s"),
+                      $File::Find::name, $srcdir);
+            }
+        }
+    }, "$srcdir/.bzr");
+
+    return 1;
+}
+
+sub can_build {
+    my ($self, $dir) = @_;
+    return (-d "$dir/.bzr", _g("doesn't contain a bzr repository"));
+}
+
+sub do_build {
+    my ($self, $dir) = @_;
+    my @argv = @{$self->{'options'}{'ARGV'}};
+    # TODO: warn here?
+    #my @tar_ignore = map { "--exclude=$_" } @{$self->{'options'}{'tar_ignore'}};
+    my $diff_ignore_regexp = $self->{'options'}{'diff_ignore_regexp'};
+
+    $dir =~ s{/+$}{}; # Strip trailing /
+    my ($dirname, $updir) = fileparse($dir);
+
+    if (scalar(@argv)) {
+        usageerr(_g("-b takes only one parameter with format `%s'"),
+                 $self->{'fields'}{'Format'});
+    }
+
+    my $sourcepackage = $self->{'fields'}{'Source'};
+    my $basenamerev = $self->get_basename(1);
+    my $basename = $self->get_basename();
+    my $basedirname = $basename;
+    $basedirname =~ s/_/-/;
+
+    sanity_check($dir);
+
+    my $old_cwd = getcwd();
+    chdir($dir) ||
+            syserr(_g("unable to chdir to `%s'"), $dir);
+
+    # Check for uncommitted files.
+    # To support dpkg-source -i, remove any ignored files from the
+    # output of bzr status.
+    open(BZR_STATUS, '-|', "bzr", "status") ||
+            subprocerr("bzr status");
+    my @files;
+    while (<BZR_STATUS>) {
+        chomp;
+        next unless s/^ +//;
+        if (! length $diff_ignore_regexp ||
+            ! m/$diff_ignore_regexp/o) {
+            push @files, $_;
+        }
+    }
+    close(BZR_STATUS) || syserr(_g("bzr status exited nonzero"));
+    if (@files) {
+        error(_g("uncommitted, not-ignored changes in working directory: %s"),
+              join(" ", @files));
+    }
+
+    chdir($old_cwd) ||
+            syserr(_g("unable to chdir to `%s'"), $old_cwd);
+
+    my $tmp = tempdir("$dirname.bzr.XXXXXX", DIR => $updir);
+    push @Dpkg::Exit::handlers, sub { erasedir($tmp) };
+    my $tardir = "$tmp/$dirname";
+
+    system("bzr", "branch", $dir, $tardir);
+    $? && subprocerr("bzr branch $dir $tardir");
+
+    # Remove the working tree.
+    system("bzr", "remove-tree", $tardir);
+
+    # Some branch metadata files are unhelpful.
+    unlink("$tardir/.bzr/branch/branch-name",
+           "$tardir/.bzr/branch/parent");
+
+    # Create the tar file
+    my $debianfile = "$basenamerev.bzr.tar." . $self->{'options'}{'comp_ext'};
+    info(_g("building %s in %s"),
+         $sourcepackage, $debianfile);
+    my $tar = Dpkg::Source::Archive->new(filename => $debianfile,
+                                         compression => $self->{'options'}{'compression'},
+                                         compression_level => $self->{'options'}{'comp_level'});
+    $tar->create('chdir' => $tmp);
+    $tar->add_directory($dirname);
+    $tar->finish();
+
+    erasedir($tmp);
+    pop @Dpkg::Exit::handlers;
+
+    $self->add_file($debianfile);
+}
+
+# Called after a tarball is unpacked, to check out the working copy.
+sub do_extract {
+    my ($self, $newdirectory) = @_;
+    my $fields = $self->{'fields'};
+
+    my $dscdir = $self->{'basedir'};
+
+    check_version($fields->{'Version'});
+
+    my $basename = $self->get_basename();
+    my $basenamerev = $self->get_basename(1);
+
+    my @files = $self->get_files();
+    if (@files > 1) {
+        error(_g("format v3.0 uses only one source file"));
+    }
+    my $tarfile = $files[0];
+    if ($tarfile !~ /^\Q$basenamerev\E\.bzr\.tar\.$comp_regex$/) {
+        error(_g("expected %s, got %s"),
+              "$basenamerev.bzr.tar.$comp_regex", $tarfile);
+    }
+
+    erasedir($newdirectory);
+
+    # Extract main tarball
+    info(_g("unpacking %s"), $tarfile);
+    my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
+    $tar->extract($newdirectory);
+
+    sanity_check($newdirectory);
+
+    my $old_cwd = getcwd();
+    chdir($newdirectory) ||
+            syserr(_g("unable to chdir to `%s'"), $newdirectory);
+
+    # Reconstitute the working tree.
+    system("bzr", "checkout");
+
+    chdir($old_cwd) ||
+            syserr(_g("unable to chdir to `%s'"), $old_cwd);
+}
+
+1;

scripts/Dpkg/Source/Package/V3_0/custom.pm

@@ -0,0 +1,59 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Package::V3_0::custom;
+
+use strict;
+use warnings;
+
+use base 'Dpkg::Source::Package';
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(error);
+
+sub parse_cmdline_option {
+    my ($self, $opt) = @_;
+    if ($opt =~ /^--target-format=(.*)$/) {
+        $self->{'options'}{'target_format'} = $1;
+        return 1;
+    }
+    return 0;
+}
+sub do_extract {
+    error(_g("Format `3.0 (custom)' is only used to create source packages"));
+}
+
+sub can_build {
+    my ($self, $dir) = @_;
+    return (scalar(@{$self->{'options'}{'ARGV'}}),
+            _g("no files indicated on command line"));
+}
+
+sub do_build {
+    my ($self, $dir) = @_;
+    # Update real target format
+    my $format = $self->{'options'}{'target_format'};
+    error(_g("--target-format option is missing")) unless $format;
+    $self->{'fields'}{'Format'} = $format;
+    # Add all files
+    foreach my $file (@{$self->{'options'}{'ARGV'}}) {
+        $self->add_file($file);
+    }
+}
+
+# vim:et:sw=4:ts=8
+1;

scripts/Dpkg/Source/Package/V3_0/git.pm

@@ -0,0 +1,335 @@
+#!/usr/bin/perl
+#
+# git support for dpkg-source
+#
+# Copyright © 2007 Joey Hess <joeyh@debian.org>.
+# Copyright © 2008 Frank Lichtenheld <djpig@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
+package Dpkg::Source::Package::V3_0::git;
+
+use strict;
+use warnings;
+
+use base 'Dpkg::Source::Package';
+
+use Cwd;
+use File::Basename;
+use File::Find;
+use File::Temp qw(tempdir);
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::Compression;
+use Dpkg::ErrorHandling qw(error warning subprocerr syserr info);
+use Dpkg::Version qw(check_version);
+use Dpkg::Source::Archive;
+use Dpkg::Exit;
+use Dpkg::Source::Functions qw(erasedir);
+
+# Remove variables from the environment that might cause git to do
+# something unexpected.
+delete $ENV{GIT_DIR};
+delete $ENV{GIT_INDEX_FILE};
+delete $ENV{GIT_OBJECT_DIRECTORY};
+delete $ENV{GIT_ALTERNATE_OBJECT_DIRECTORIES};
+delete $ENV{GIT_WORK_TREE};
+
+sub import {
+    foreach my $dir (split(/:/, $ENV{PATH})) {
+        if (-x "$dir/git") {
+            return 1;
+        }
+    }
+    error(_g("This source package can only be manipulated using git, which is not in the PATH."));
+}
+
+sub sanity_check {
+    my $srcdir = shift;
+
+    if (! -d "$srcdir/.git") {
+        error(_g("source directory is not the top directory of a git repository (%s/.git not present), but Format git was specified"),
+              $srcdir);
+    }
+    if (-s "$srcdir/.gitmodules") {
+        error(_g("git repository %s uses submodules. This is not yet supported."),
+              $srcdir);
+    }
+
+    # Symlinks from .git to outside could cause unpack failures, or
+    # point to files they shouldn't, so check for and don't allow.
+    if (-l "$srcdir/.git") {
+        error(_g("%s is a symlink"), "$srcdir/.git");
+    }
+    my $abs_srcdir = Cwd::abs_path($srcdir);
+    find(sub {
+        if (-l $_) {
+            if (Cwd::abs_path(readlink($_)) !~ /^\Q$abs_srcdir\E(\/|$)/) {
+                error(_g("%s is a symlink to outside %s"),
+                      $File::Find::name, $srcdir);
+            }
+        }
+    }, "$srcdir/.git");
+
+    return 1;
+}
+
+# Returns a hash of arrays of git config values.
+sub read_git_config {
+    my $file = shift;
+
+    my %ret;
+    open(GIT_CONFIG, '-|', "git", "config", "--file", $file, "--null", "-l") ||
+        subprocerr("git config");
+    local $/ = "\0";
+    while (<GIT_CONFIG>) {
+        chomp;
+        my ($key, $value) = split(/\n/, $_, 2);
+        push @{$ret{$key}}, $value;
+    }
+    close(GIT_CONFIG) || syserr(_g("git config exited nonzero"));
+
+    return \%ret;
+}
+
+sub can_build {
+    my ($self, $dir) = @_;
+    return (-d "$dir/.git", _g("doesn't contain a git repository"));
+}
+
+sub do_build {
+    my ($self, $dir) = @_;
+    my @argv = @{$self->{'options'}{'ARGV'}};
+#TODO: warn here?
+#    my @tar_ignore = map { "--exclude=$_" } @{$self->{'options'}{'tar_ignore'}};
+    my $diff_ignore_regexp = $self->{'options'}{'diff_ignore_regexp'};
+
+    $dir =~ s{/+$}{}; # Strip trailing /
+    my ($dirname, $updir) = fileparse($dir);
+
+    if (scalar(@argv)) {
+        usageerr(_g("-b takes only one parameter with format `%s'"),
+                 $self->{'fields'}{'Format'});
+    }
+
+    my $sourcepackage = $self->{'fields'}{'Source'};
+    my $basenamerev = $self->get_basename(1);
+    my $basename = $self->get_basename();
+    my $basedirname = $basename;
+    $basedirname =~ s/_/-/;
+
+    sanity_check($dir);
+
+    my $old_cwd = getcwd();
+    chdir($dir) ||
+	syserr(_g("unable to chdir to `%s'"), $dir);
+
+    # Check for uncommitted files.
+    # To support dpkg-source -i, get a list of files
+    # equivalent to the ones git status finds, and remove any
+    # ignored files from it.
+    my @ignores = "--exclude-per-directory=.gitignore";
+    my $core_excludesfile = `git config --get core.excludesfile`;
+    chomp $core_excludesfile;
+    if (length $core_excludesfile && -e $core_excludesfile) {
+	push @ignores, "--exclude-from='$core_excludesfile'";
+    }
+    if (-e ".git/info/exclude") {
+	push @ignores, "--exclude-from=.git/info/exclude";
+    }
+    open(GIT_LS_FILES, '-|', "git", "ls-files", "--modified", "--deleted",
+	 "-z", "--others", @ignores) ||
+	     subprocerr("git ls-files");
+    my @files;
+    { local $/ = "\0";
+      while (<GIT_LS_FILES>) {
+	  chomp;
+	  if (! length $diff_ignore_regexp ||
+	      ! m/$diff_ignore_regexp/o) {
+	      push @files, $_;
+	  }
+      }
+    }
+    close(GIT_LS_FILES) || syserr(_g("git ls-files exited nonzero"));
+    if (@files) {
+	error(_g("uncommitted, not-ignored changes in working directory: %s"),
+	      join(" ", @files));
+    }
+
+    # git clone isn't used to copy the repo because the it might be an
+    # unclonable shallow copy.
+    chdir($old_cwd) ||
+	syserr(_g("unable to chdir to `%s'"), $old_cwd);
+
+    my $tmp = tempdir("$dirname.git.XXXXXX", DIR => $updir);
+    push @Dpkg::Exit::handlers, sub { erasedir($tmp) };
+    my $tardir = "$tmp/$dirname";
+    mkdir($tardir) ||
+	syserr(_g("cannot create directory %s"), $tardir);
+
+    system("cp", "-a", "$dir/.git", $tardir);
+    $? && subprocerr("cp -a $dir/.git $tardir");
+    chdir($tardir) ||
+	syserr(_g("unable to chdir to `%s'"), $tardir);
+
+    # TODO support for creating a shallow clone for those cases where
+    # uploading the whole repo history is not desired
+
+    # Clean up the new repo to save space.
+    # First, delete the whole reflog, which is not needed in a
+    # distributed source package.
+    system("rm", "-rf", ".git/logs");
+    $? && subprocerr("rm -rf .git/logs");
+    system("git", "gc", "--prune");
+    $? && subprocerr("git gc --prune");
+
+    # .git/gitweb is created and used by git instaweb and should not be
+    # transferwed by source package.
+    system("rm", "-rf", ".git/gitweb");
+    $? && subprocerr("rm -rf .git/gitweb");
+
+    # As an optimisation, remove the index. It will be recreated by git
+    # reset during unpack. It's probably small, but you never know, this
+    # might save a lot of space. (Also, the index file may not be
+    # portable.)
+    unlink(".git/index"); # error intentionally ignored
+
+    chdir($old_cwd) ||
+	syserr(_g("unable to chdir to `%s'"), $old_cwd);
+
+    # Create the tar file
+    my $debianfile = "$basenamerev.git.tar." . $self->{'options'}{'comp_ext'};
+    info(_g("building %s in %s"),
+	 $sourcepackage, $debianfile);
+    my $tar = Dpkg::Source::Archive->new(filename => $debianfile,
+					 compression => $self->{'options'}{'compression'},
+					 compression_level => $self->{'options'}{'comp_level'});
+    $tar->create('chdir' => $tmp);
+    $tar->add_directory($dirname);
+    $tar->finish();
+
+    erasedir($tmp);
+    pop @Dpkg::Exit::handlers;
+
+    $self->add_file($debianfile);
+}
+
+# Called after a tarball is unpacked, to check out the working copy.
+sub do_extract {
+    my ($self, $newdirectory) = @_;
+    my $fields = $self->{'fields'};
+
+    my $dscdir = $self->{'basedir'};
+
+    check_version($fields->{'Version'});
+
+    my $basename = $self->get_basename();
+    my $basenamerev = $self->get_basename(1);
+
+    my @files = $self->get_files();
+    if (@files > 1) {
+	error(_g("format v3.0 uses only one source file"));
+    }
+    my $tarfile = $files[0];
+    if ($tarfile !~ /^\Q$basenamerev\E\.git\.tar\.$comp_regex$/) {
+	error(_g("expected %s, got %s"),
+	      "$basenamerev.git.tar.$comp_regex", $tarfile);
+    }
+
+    erasedir($newdirectory);
+
+    # Extract main tarball
+    info(_g("unpacking %s"), $tarfile);
+    my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
+    $tar->extract($newdirectory);
+
+    sanity_check($newdirectory);
+
+    my $old_cwd = getcwd();
+    chdir($newdirectory) ||
+	syserr(_g("unable to chdir to `%s'"), $newdirectory);
+
+    # Disable git hooks, as unpacking a source package should not
+    # involve running code.
+    foreach my $hook (glob("./.git/hooks/*")) {
+	if (-x $hook) {
+	    warning(_g("executable bit set on %s; clearing"), $hook);
+	    chmod(0666 &~ umask(), $hook) ||
+		syserr(_g("unable to change permission of `%s'"), $hook);
+	}
+    }
+
+    # This is a paranoia measure, since the index is not normally
+    # provided by possibly-untrusted third parties, remove it if
+    # present (git will recreate it as needed).
+    if (-e ".git/index" || -l ".git/index") {
+	unlink(".git/index") ||
+	    syserr(_g("unable to remove `%s'"), ".git/index");
+    }
+
+    # Comment out potentially probamatic or annoying stuff in
+    # .git/config.
+    my $safe_fields = qr/^(
+		core\.autocrlf			|
+		branch\..*			|
+		remote\..*			|
+		core\.repositoryformatversion	|
+		core\.filemode			|
+		core\.logallrefupdates		|
+		core\.bare
+		)$/x;
+    my %config = %{read_git_config(".git/config")};
+    foreach my $field (keys %config) {
+	if ($field =~ /$safe_fields/) {
+	    delete $config{$field};
+	}
+	else {
+	    system("git", "config", "--file", ".git/config",
+		   "--unset-all", $field);
+	    $? && subprocerr("git config --file .git/config --unset-all $field");
+	}
+    }
+    if (%config) {
+	warning(_g("modifying .git/config to comment out some settings"));
+	open(GIT_CONFIG, ">>", ".git/config") ||
+	    syserr(_g("unstable to append to %s"), ".git/config");
+	print GIT_CONFIG "\n# "._g("The following setting(s) were disabled by dpkg-source").":\n";
+	foreach my $field (sort keys %config) {
+	    foreach my $value (@{$config{$field}}) {
+		if (defined($value)) {
+		    print GIT_CONFIG "# $field=$value\n";
+		} else {
+		    print GIT_CONFIG "# $field\n";
+		}
+	    }
+	}
+	close GIT_CONFIG;
+    }
+
+    # .git/gitweb is created and used by git instaweb and should not be
+    # transferwed by source package.
+    system("rm", "-rf", ".git/gitweb");
+    $? && subprocerr("rm -rf .git/gitweb");
+
+    # git checkout is used to repopulate the WC with files
+    # and recreate the index.
+    system("git", "checkout", "-f");
+    $? && subprocerr("git checkout -f");
+
+    chdir($old_cwd) ||
+	syserr(_g("unable to chdir to `%s'"), $old_cwd);
+}
+
+1;

scripts/Dpkg/Source/Package/V3_0/native.pm

@@ -0,0 +1,105 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Package::V3_0::native;
+
+use strict;
+use warnings;
+
+use base 'Dpkg::Source::Package';
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(error syserr info usageerr);
+use Dpkg::Compression;
+use Dpkg::Source::Archive;
+use Dpkg::Source::Functions qw(erasedir);
+
+use POSIX;
+use File::Basename;
+use File::Temp qw(tempfile);
+
+sub do_extract {
+    my ($self, $newdirectory) = @_;
+    my $sourcestyle = $self->{'options'}{'sourcestyle'};
+    my $fields = $self->{'fields'};
+
+    my $dscdir = $self->{'basedir'};
+    my $basename = $self->get_basename();
+    my $basenamerev = $self->get_basename(1);
+
+    my $tarfile;
+    foreach my $file ($self->get_files()) {
+	if ($file =~ /^\Q$basenamerev\E\.tar\.$comp_regex$/) {
+            error(_g("multiple tarfiles in v1.0 source package")) if $tarfile;
+            $tarfile = $file;
+	} else {
+	    error(_g("unrecognized file for a native source package: %s"), $file);
+	}
+    }
+
+    error(_g("no tarfile in Files field")) unless $tarfile;
+
+    erasedir($newdirectory);
+    info(_g("unpacking %s"), $tarfile);
+    my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile");
+    $tar->extract($newdirectory);
+}
+
+sub can_build {
+    return 1;
+}
+
+sub do_build {
+    my ($self, $dir) = @_;
+    my @tar_ignore = map { "--exclude=$_" } @{$self->{'options'}{'tar_ignore'}};
+    my @argv = @{$self->{'options'}{'ARGV'}};
+
+    if (scalar(@argv)) {
+        usageerr(_g("-b takes only one parameter with format `%s'"),
+                 $self->{'fields'}{'Format'});
+    }
+
+    my $sourcepackage = $self->{'fields'}{'Source'};
+    my $basenamerev = $self->get_basename(1);
+    my $tarname = "$basenamerev.tar." . $self->{'options'}{'comp_ext'};
+
+    info(_g("building %s in %s"), $sourcepackage, $tarname);
+
+    my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX",
+                                   DIR => getcwd(), UNLINK => 0);
+
+    my ($dirname, $dirbase) = fileparse($dir);
+    my $tar = Dpkg::Source::Archive->new(filename => $newtar,
+                compression => get_compression_from_filename($tarname),
+                compression_level => $self->{'options'}{'comp_level'});
+    $tar->create(options => \@tar_ignore, 'chdir' => $dirbase);
+    $tar->add_directory($dirname);
+    $tar->finish();
+    rename($newtar, $tarname) ||
+        syserr(_g("unable to rename `%s' (newly created) to `%s'"),
+               $newtar, $tarname);
+
+    $self->add_file($tarname);
+
+    # For backward compatibility, drop version to 1.0 if we can
+    if ($self->{'options'}{'compression'} eq "gzip") {
+        $self->{'fields'}{'Format'} = "1.0";
+    }
+}
+
+# vim: set et sw=4 ts=8
+1;

scripts/Dpkg/Source/Package/V3_0/quilt.pm

@@ -0,0 +1,182 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Package::V3_0::quilt;
+
+use strict;
+use warnings;
+
+# Based on wig&pen implementation
+use base 'Dpkg::Source::Package::V2_0';
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(error syserr warning usageerr subprocerr info);
+use Dpkg::Source::Patch;
+use Dpkg::IPC;
+
+use POSIX;
+use File::Basename;
+use File::Spec;
+
+sub init_options {
+    my ($self) = @_;
+    $self->SUPER::init_options();
+    $self->{'options'}{'without_quilt'} = 0
+        unless exists $self->{'options'}{'without_quilt'};
+}
+
+sub parse_cmdline_option {
+    my ($self, $opt) = @_;
+    return 1 if $self->SUPER::parse_cmdline_option($opt);
+    if ($opt =~ /^--without-quilt$/) {
+        $self->{'options'}{'without_quilt'} = 1;
+        return 1;
+    }
+    return 0;
+}
+
+sub get_autopatch_name {
+    my ($self) = @_;
+    return "debian-changes-" . $self->{'fields'}{'Version'} . ".diff";
+}
+
+sub get_series_file {
+    my ($self, $dir) = @_;
+    my $pd = File::Spec->catdir($dir, "debian", "patches");
+    # TODO: replace "debian" with the current distro name once we have a
+    # way to figure it out
+    foreach (File::Spec->catfile($pd, "debian.series"),
+             File::Spec->catfile($pd, "series")) {
+        return $_ if -e $_;
+    }
+    return undef;
+}
+
+sub get_patches {
+    my ($self, $dir, $skip_auto) = @_;
+    my @patches;
+    my $auto_patch = $self->get_autopatch_name();
+    my $series = $self->get_series_file($dir);
+    if (defined($series)) {
+        open(SERIES, "<" , $series) || syserr(_g("cannot read %s"), $series);
+        while(defined($_ = <SERIES>)) {
+            chomp; s/^\s+//; s/\s+$//; # Strip leading/trailing spaces
+            s/\s#.*$//; # Strip trailing comment
+            next unless $_;
+            next if $skip_auto and $_ eq $auto_patch;
+            push @patches, $_;
+        }
+        close(SERIES);
+    }
+    return @patches;
+}
+
+sub apply_patches {
+    my ($self, $dir, $skip_auto) = @_;
+
+    # Check if quilt is available
+    my $have_quilt = (-x "/usr/bin/quilt") ? 1 : 0;
+
+    # Update debian/patches/series symlink if needed to allow quilt usage
+    my $series = $self->get_series_file($dir);
+    return unless $series; # No series, no patches
+    my $basename = basename($series);
+    if ($basename ne "series") {
+        my $dest = File::Spec->catfile($dir, "debian", "patches", "series");
+        unlink($dest) if -l $dest;
+        unless (-f _) { # Don't overwrite real files
+            symlink($basename, $dest) ||
+                syserr(_g("can't create symlink %s"), $dest);
+        }
+    }
+
+    # Apply patches
+    my $now = time();
+    foreach my $patch ($self->get_patches($dir, $skip_auto)) {
+        my $path = File::Spec->catfile($dir, "debian", "patches", $patch);
+        my $patch_obj = Dpkg::Source::Patch->new(filename => $path);
+        if ($have_quilt and not $self->{'options'}{'without_quilt'}) {
+            info(_g("applying %s with quilt"), $patch) unless $skip_auto;
+            my $analysis = $patch_obj->analyze($dir);
+            foreach my $dir (keys %{$analysis->{'dirtocreate'}}) {
+                eval { mkpath($dir); };
+                syserr(_g("cannot create directory %s"), $dir) if $@;
+            }
+            my %opts = (
+                env => { QUILT_PATCHES => 'debian/patches' },
+                delete_env => [ 'QUILT_PATCH_OPTS' ],
+                'chdir' => $dir,
+                'exec' => [ 'quilt', '--quiltrc', '/dev/null', 'push', $patch ],
+                wait_child => 1,
+                to_file => '/dev/null',
+            );
+            fork_and_exec(%opts);
+            foreach my $fn (keys %{$analysis->{'filepatched'}}) {
+                utime($now, $now, $fn) || $! == ENOENT ||
+                    syserr(_g("cannot change timestamp for %s"), $fn);
+            }
+        } else {
+            info(_g("applying %s"), $patch) unless $skip_auto;
+            $patch_obj->apply($dir, timestamp => $now,
+                    force_timestamp => 1, create_dirs => 1,
+                    add_options => [ '-E' ]);
+        }
+    }
+}
+
+sub prepare_build {
+    my ($self, $dir) = @_;
+    $self->SUPER::prepare_build($dir);
+    # Skip .pc directories of quilt by default and ignore difference
+    # on debian/patches/series symlinks
+    my $func = sub {
+        return 1 if $_[0] =~ m{^debian/patches/series$} and -l $_[0];
+        return 1 if $_[0] =~ /^.pc(\/|$)/;
+        return 1 if $_[0] =~ /$self->{'options'}{'diff_ignore_regexp'}/;
+        return 0;
+    };
+    $self->{'diff_options'}{'diff_ignore_func'} = $func;
+}
+
+sub register_autopatch {
+    my ($self, $dir) = @_;
+    my $auto_patch = $self->get_autopatch_name();
+    my $has_patch = (grep { $_ eq $auto_patch } $self->get_patches($dir)) ? 1 : 0;
+    my $series = $self->get_series_file($dir);
+    $series ||= File::Spec->catfile($dir, "debian", "patches", "series");
+    if (-e "$dir/debian/patches/$auto_patch") {
+        # Add auto_patch to series file
+        if (not $has_patch) {
+            open(SERIES, ">>", $series) || syserr(_g("cannot write %s"), $series);
+            print SERIES "$auto_patch\n";
+            close(SERIES);
+        }
+    } else {
+        # Remove auto_patch from series
+        if ($has_patch) {
+            open(SERIES, "<", $series) || syserr(_g("cannot read %s"), $series);
+            my @lines = <SERIES>;
+            close(SERIES);
+            open(SERIES, ">", $series) || syserr(_g("cannot write %s"), $series);
+            print(SERIES $_) foreach grep { not /^\Q$auto_patch\E\s*$/ } @lines;
+            close(SERIES);
+        }
+    }
+}
+
+# vim:et:sw=4:ts=8
+1;

scripts/Dpkg/Source/Patch.pm

@@ -0,0 +1,442 @@
+# Copyright 2008 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Source::Patch;
+
+use strict;
+use warnings;
+
+use Dpkg;
+use Dpkg::Source::CompressedFile;
+use Dpkg::Source::Compressor;
+use Dpkg::Compression;
+use Dpkg::Gettext;
+use Dpkg::IPC;
+use Dpkg::ErrorHandling qw(error errormsg syserr warning subprocerr);
+
+use POSIX;
+use File::Find;
+use File::Basename;
+use File::Spec;
+use File::Path;
+use Fcntl ':mode';
+#XXX: Needed for sub-second timestamps, require recent perl
+#use Time::HiRes qw(stat);
+
+use base 'Dpkg::Source::CompressedFile';
+
+sub create {
+    my ($self, %opts) = @_;
+    $self->{'handle'} = $self->open_for_write();
+    $self->{'errors'} = 0;
+    if ($opts{'old'} and $opts{'new'}) {
+        $opts{'old'} = "/dev/null" unless -e $opts{'old'};
+        $opts{'new'} = "/dev/null" unless -e $opts{'new'};
+        if (-d $opts{'old'} and -d $opts{'new'}) {
+            $self->add_diff_directory($opts{'old'}, $opts{'new'}, %opts);
+        } elsif (-f $opts{'old'} and -f $opts{'new'}) {
+            $self->add_diff_file($opts{'old'}, $opts{'new'}, %opts);
+        } else {
+            $self->_fail_not_same_type($opts{'old'}, $opts{'new'});
+        }
+        $self->finish() unless $opts{"nofinish"};
+    }
+}
+
+sub add_diff_file {
+    my ($self, $old, $new, %opts) = @_;
+    $opts{"include_timestamp"} = 0 unless exists $opts{"include_timestamp"};
+    my $handle_binary = $opts{"handle_binary_func"} || sub {
+        my ($self, $old, $new) = @_;
+        $self->_fail_with_msg($new, _g("binary file contents changed"));
+    };
+    # Default diff options
+    my @options;
+    if ($opts{"options"}) {
+        push @options, @{$opts{"options"}};
+    } else {
+        push @options, '-p';
+    }
+    # Add labels
+    if ($opts{"label_old"} and $opts{"label_new"}) {
+	if ($opts{"include_timestamp"}) {
+	    my $ts = (stat($old))[9];
+	    my $t = POSIX::strftime("%Y-%m-%d %H:%M:%S", gmtime($ts));
+	    $opts{"label_old"} .= sprintf("\t%s.%09d +0000", $t,
+					    ($ts-int($ts))*1000000000);
+	    $ts = (stat($new))[9];
+	    $t = POSIX::strftime("%Y-%m-%d %H:%M:%S", gmtime($ts));
+	    $opts{"label_new"} .= sprintf("\t%s.%09d +0000", $t,
+					    ($ts-int($ts))*1000000000);
+	} else {
+	    # Space in filenames need special treatment
+	    $opts{"label_old"} .= "\t" if $opts{"label_old"} =~ / /;
+	    $opts{"label_new"} .= "\t" if $opts{"label_new"} =~ / /;
+	}
+        push @options, "-L", $opts{"label_old"},
+                       "-L", $opts{"label_new"};
+    }
+    # Generate diff
+    my $diffgen;
+    my $diff_pid = fork_and_exec(
+        'exec' => [ 'diff', '-u', @options, '--', $old, $new ],
+        'env' => { LC_ALL => 'C', LANG => 'C', TZ => 'UTC0' },
+        'to_pipe' => \$diffgen
+    );
+    # Check diff and write it in patch file
+    my $difflinefound = 0;
+    my $binary = 0;
+    while (<$diffgen>) {
+        if (m/^binary/i) {
+            $binary = 1;
+            &$handle_binary($self, $old, $new);
+            last;
+        } elsif (m/^[-+\@ ]/) {
+            $difflinefound++;
+        } elsif (m/^\\ No newline at end of file$/) {
+            warning(_g("file %s has no final newline (either " .
+                       "original or modified version)"), $new);
+        } else {
+            chomp;
+            internerr(_g("unknown line from diff -u on %s: `%s'"),
+                      $new, $_);
+        }
+        print({ $self->{'handle'} } $_) || syserr(_g("failed to write"));
+    }
+    close($diffgen) or syserr("close on diff pipe");
+    wait_child($diff_pid, nocheck => 1,
+               cmdline => "diff -u @options -- $old $new");
+    # Verify diff process ended successfully
+    # Exit code of diff: 0 => no difference, 1 => diff ok, 2 => error
+    # Ignore error if binary content detected
+    my $exit = WEXITSTATUS($?);
+    unless (WIFEXITED($?) && ($exit == 0 || $exit == 1 || $binary)) {
+        subprocerr(_g("diff on %s"), $new);
+    }
+    return ($exit == 0 || $exit == 1);
+}
+
+sub add_diff_directory {
+    my ($self, $old, $new, %opts) = @_;
+    # TODO: make this function more configurable
+    # - offer to disable some checks
+    my $basedir = $opts{"basedirname"} || basename($new);
+    my $inc_removal = $opts{"include_removal"} || 0;
+    my $diff_ignore;
+    if ($opts{"diff_ignore_func"}) {
+        $diff_ignore = $opts{"diff_ignore_func"};
+    } elsif ($opts{"diff_ignore_regexp"}) {
+        $diff_ignore = sub { return $_[0] =~ /$opts{"diff_ignore_regexp"}/o };
+    } else {
+        $diff_ignore = sub { return 0 };
+    }
+
+    my %files_in_new;
+    my $scan_new = sub {
+        my $fn = File::Spec->abs2rel($_, $new);
+        return if &$diff_ignore($fn);
+        $files_in_new{$fn} = 1;
+        lstat("$new/$fn") || syserr(_g("cannot stat file %s"), "$new/$fn");
+        my $mode = S_IMODE((lstat(_))[2]);
+        my $size = (lstat(_))[7];
+        if (-l _) {
+            unless (-l "$old/$fn") {
+                $self->_fail_not_same_type("$old/$fn", "$new/$fn");
+                return;
+            }
+            defined(my $n = readlink("$new/$fn")) ||
+                syserr(_g("cannot read link %s"), "$new/$fn");
+            defined(my $n2 = readlink("$old/$fn")) ||
+                syserr(_g("cannot read link %s"), "$old/$fn");
+            unless ($n eq $n2) {
+                $self->_fail_not_same_type("$old/$fn", "$new/$fn");
+            }
+        } elsif (-f _) {
+            my $old_file = "$old/$fn";
+            if (not lstat("$old/$fn")) {
+                $! == ENOENT ||
+                    syserr(_g("cannot stat file %s"), "$old/$fn");
+                $old_file = '/dev/null';
+            } elsif (not -f _) {
+                $self->_fail_not_same_type("$old/$fn", "$new/$fn");
+                return;
+            }
+
+            my $success = $self->add_diff_file($old_file, "$new/$fn",
+                label_old => "$basedir.orig/$fn",
+                label_new => "$basedir/$fn",
+                %opts);
+
+            if ($success and ($old_file eq "/dev/null")) {
+                if (not $size) {
+                    warning(_g("newly created empty file '%s' will not " .
+                               "be represented in diff"), $fn);
+                } else {
+                    if ($mode & (S_IXUSR | S_IXGRP | S_IXOTH)) {
+                        warning(_g("executable mode %04o of '%s' will " .
+                                   "not be represented in diff"), $mode, $fn)
+                            unless $fn eq 'debian/rules';
+                    }
+                    if ($mode & (S_ISUID | S_ISGID | S_ISVTX)) {
+                        warning(_g("special mode %04o of '%s' will not " .
+                                   "be represented in diff"), $mode, $fn);
+                    }
+                }
+            }
+        } elsif (-p _) {
+            unless (-p "$old/$fn") {
+                $self->_fail_not_same_type("$old/$fn", "$new/$fn");
+            }
+        } elsif (-b _ || -c _ || -S _) {
+            $self->_fail_with_msg("$new/$fn",
+                _g("device or socket is not allowed"));
+        } elsif (-d _) {
+            if (not lstat("$old/$fn")) {
+                $! == ENOENT ||
+                    syserr(_g("cannot stat file %s"), "$old/$fn");
+            } elsif (not -d _) {
+                $self->_fail_not_same_type("$old/$fn", "$new/$fn");
+            }
+        } else {
+            $self->_fail_with_msg("$new/$fn", _g("unknown file type"));
+        }
+    };
+    my $scan_old = sub {
+        my $fn = File::Spec->abs2rel($_, $old);
+        return if &$diff_ignore($fn);
+        return if $files_in_new{$fn};
+        lstat("$old/$fn") || syserr(_g("cannot stat file %s"), "$old/$fn");
+        if (-f _) {
+            if ($inc_removal) {
+                $self->add_diff_file("$old/$fn", "/dev/null",
+                    label_old => "$basedir.orig/$fn",
+                    label_new => "/dev/null",
+                    %opts);
+            } else {
+                warning(_g("ignoring deletion of file %s"), $fn);
+            }
+        } elsif (-d _) {
+            warning(_g("ignoring deletion of directory %s"), $fn);
+        } elsif (-l _) {
+            warning(_g("ignoring deletion of symlink %s"), $fn);
+        } else {
+            $self->_fail_not_same_type("$old/$fn", "$new/$fn");
+        }
+    };
+
+    find({ wanted => $scan_new, no_chdir => 1 }, $new);
+    find({ wanted => $scan_old, no_chdir => 1 }, $old);
+}
+
+sub finish {
+    my ($self) = @_;
+    close($self->{'handle'}) ||
+            syserr(_g("cannot close %s"), $self->get_filename());
+    delete $self->{'handle'};
+    $self->cleanup_after_open();
+    return not $self->{'errors'};
+}
+
+sub register_error {
+    my ($self) = @_;
+    $self->{'errors'}++;
+}
+sub _fail_with_msg {
+    my ($self, $file, $msg) = @_;
+    errormsg(_g("cannot represent change to %s: %s"), $file, $msg);
+    $self->register_error();
+}
+sub _fail_not_same_type {
+    my ($self, $old, $new) = @_;
+    my $old_type = get_type($old);
+    my $new_type = get_type($new);
+    errormsg(_g("cannot represent change to %s:"), $new);
+    errormsg(_g("  new version is %s"), $old_type);
+    errormsg(_g("  old version is %s"), $new_type);
+    $self->register_error();
+}
+
+# check diff for sanity, find directories to create as a side effect
+sub analyze {
+    my ($self, $destdir, %opts) = @_;
+
+    my $diff = $self->get_filename();
+    my $diff_handle = $self->open_for_read();
+    my %filepatched;
+    my %dirtocreate;
+    my $diff_count = 0;
+
+    $_ = <$diff_handle>;
+
+  HUNK:
+    while (defined($_) || not eof($diff_handle)) {
+	# skip comments leading up to patch (if any)
+	until (/^--- /) {
+	    last HUNK if not defined($_ = <$diff_handle>);
+	}
+	chomp;
+	$diff_count++;
+	# read file header (---/+++ pair)
+	unless(s/^--- //) {
+	    error(_g("expected ^--- in line %d of diff `%s'"), $., $diff);
+	}
+	s/\t.*//; # Strip any timestamp at the end
+	unless ($_ eq '/dev/null' or s{^(\./)?[^/]+/}{$destdir/}) {
+	    error(_g("diff `%s' patches file with no subdirectory"), $diff);
+	}
+	if (/\.dpkg-orig$/) {
+	    error(_g("diff `%s' patches file with name ending .dpkg-orig"), $diff);
+	}
+	my $fn = $_;
+
+	unless (defined($_= <$diff_handle>) and chomp) {
+	    error(_g("diff `%s' finishes in middle of ---/+++ (line %d)"), $diff, $.);
+	}
+	s/\t.*//; # Strip any timestamp at the end
+	unless (s/^\+\+\+ // and ($_ eq '/dev/null' or s!^(\./)?[^/]+/!!)) {
+	    error(_g("line after --- isn't as expected in diff `%s' (line %d)"),
+	          $diff, $.);
+	}
+
+	if ($fn eq '/dev/null') {
+	    error(_g("original and modified files are /dev/null in diff `%s' (line %d)"),
+		  $diff, $.) if $_ eq '/dev/null';
+	    $fn = "$destdir/$_";
+	} else {
+	    unless ($_ eq '/dev/null' or $_ eq substr($fn, length($destdir) + 1)) {
+	        error(_g("line after --- isn't as expected in diff `%s' (line %d)"),
+	              $diff, $.);
+	    }
+	}
+
+	my $dirname = $fn;
+	if ($dirname =~ s{/[^/]+$}{} && not -d $dirname) {
+	    $dirtocreate{$dirname} = 1;
+	}
+	if (-e $fn and not -f _) {
+	    error(_g("diff `%s' patches something which is not a plain file"), $diff);
+	}
+
+	if ($filepatched{$fn}) {
+	    error(_g("diff `%s' patches file %s twice"), $diff, $fn);
+	}
+	$filepatched{$fn} = 1;
+
+	# read hunks
+	my $hunk = 0;
+	while (defined($_ = <$diff_handle>)) {
+	    # read hunk header (@@)
+	    chomp;
+	    next if /^\\ No newline/;
+	    last unless (/^@@ -\d+(,(\d+))? \+\d+(,(\d+))? @\@( .*)?$/);
+	    my ($olines, $nlines) = ($1 ? $2 : 1, $3 ? $4 : 1);
+	    # read hunk
+	    while ($olines || $nlines) {
+		unless (defined($_ = <$diff_handle>)) {
+		    error(_g("unexpected end of diff `%s'"), $diff);
+		}
+		unless (chomp) {
+		    error(_g("diff `%s' is missing trailing newline"), $diff);
+		}
+		next if /^\\ No newline/;
+		# Check stats
+		if    (/^ /)  { --$olines; --$nlines; }
+		elsif (/^-/)  { --$olines; }
+		elsif (/^\+/) { --$nlines; }
+		else {
+		    error(_g("expected [ +-] at start of line %d of diff `%s'"),
+		          $., $diff);
+		}
+	    }
+	    $hunk++;
+	}
+	unless($hunk) {
+	    error(_g("expected ^\@\@ at line %d of diff `%s'"), $., $diff);
+	}
+    }
+    close($diff_handle);
+    unless ($diff_count) {
+	warning(_g("diff `%s' doesn't contain any patch"), $diff);
+    }
+    $self->cleanup_after_open();
+    $self->{'analysis'}{$destdir}{"dirtocreate"} = \%dirtocreate;
+    $self->{'analysis'}{$destdir}{"filepatched"} = \%filepatched;
+    return $self->{'analysis'}{$destdir};
+}
+
+sub apply {
+    my ($self, $destdir, %opts) = @_;
+    # Set default values to options
+    $opts{"force_timestamp"} = 1 unless exists $opts{"force_timestamp"};
+    $opts{"remove_backup"} = 1 unless exists $opts{"remove_backup"};
+    $opts{"create_dirs"} = 1 unless exists $opts{"create_dirs"};
+    $opts{"options"} ||= [ '-s', '-t', '-F', '0', '-N', '-p1', '-u',
+            '-V', 'never', '-g0', '-b', '-z', '.dpkg-orig'];
+    $opts{"add_options"} ||= [];
+    push @{$opts{"options"}}, @{$opts{"add_options"}};
+    # Check the diff and create missing directories
+    my $analysis = $self->analyze($destdir, %opts);
+    if ($opts{"create_dirs"}) {
+	foreach my $dir (keys %{$analysis->{'dirtocreate'}}) {
+	    eval { mkpath($dir, 0, 0777); };
+	    syserr(_g("cannot create directory %s"), $dir) if $@;
+	}
+    }
+    # Apply the patch
+    my $diff_handle = $self->open_for_read();
+    fork_and_exec(
+	'exec' => [ 'patch', @{$opts{"options"}} ],
+	'chdir' => $destdir,
+	'env' => { LC_ALL => 'C', LANG => 'C' },
+	'delete_env' => [ 'POSIXLY_CORRECT' ], # ensure expected patch behaviour
+	'wait_child' => 1,
+	'from_handle' => $diff_handle
+    );
+    $self->cleanup_after_open();
+    # Reset the timestamp of all the patched files
+    # and remove .dpkg-orig files
+    my $now = $opts{"timestamp"} || time;
+    foreach my $fn (keys %{$analysis->{'filepatched'}}) {
+	if ($opts{"force_timestamp"}) {
+	    utime($now, $now, $fn) || $! == ENOENT ||
+		syserr(_g("cannot change timestamp for %s"), $fn);
+	}
+	if ($opts{"remove_backup"}) {
+	    $fn .= ".dpkg-orig";
+	    unlink($fn) || syserr(_g("remove patch backup file %s"), $fn);
+	}
+    }
+}
+
+# Helper functions
+sub get_type {
+    my $file = shift;
+    if (not lstat($file)) {
+        return _g("nonexistent") if $! == ENOENT;
+        syserr(_g("cannot stat %s"), $file);
+    } else {
+        -f _ && return _g("plain file");
+        -d _ && return _g("directory");
+        -l _ && return sprintf(_g("symlink to %s"), readlink($file));
+        -b _ && return _g("block device");
+        -c _ && return _g("character device");
+        -p _ && return _g("named pipe");
+        -S _ && return _g("named socket");
+    }
+}
+
+1;
+# vim: set et sw=4 ts=8

scripts/Makefile.am

@@ -76,7 +76,8 @@ EXTRA_DIST = \
 	t/600_Dpkg_Changelog/misplaced-tz \
 	t/600_Dpkg_Changelog/shadow \
 	t/700_Dpkg_Control.t \
-	t/700_Dpkg_Control/control-1
+	t/700_Dpkg_Control/control-1 \
+	t/800_Dpkg_IPC.t
 
 CLEANFILES = \
 	$(bin_SCRIPTS) $(sbin_SCRIPTS) $(changelog_SCRIPTS) \
@@ -94,8 +95,10 @@ nobase_dist_perllib_DATA = \
 	Dpkg/Control.pm \
 	Dpkg/Deps.pm \
 	Dpkg/ErrorHandling.pm \
+	Dpkg/Exit.pm \
 	Dpkg/Fields.pm \
 	Dpkg/Gettext.pm \
+	Dpkg/IPC.pm \
 	Dpkg/Path.pm \
 	Dpkg/Shlibs.pm \
 	Dpkg/Shlibs/Objdump.pm \
@@ -103,6 +106,19 @@ nobase_dist_perllib_DATA = \
 	Dpkg/Substvars.pm \
 	Dpkg/Vars.pm \
 	Dpkg/Version.pm \
+	Dpkg/Source/Archive.pm \
+	Dpkg/Source/CompressedFile.pm \
+	Dpkg/Source/Compressor.pm \
+	Dpkg/Source/Functions.pm \
+	Dpkg/Source/Package.pm \
+	Dpkg/Source/Package/V1_0.pm \
+	Dpkg/Source/Package/V2_0.pm \
+	Dpkg/Source/Package/V3_0/bzr.pm \
+	Dpkg/Source/Package/V3_0/custom.pm \
+	Dpkg/Source/Package/V3_0/native.pm \
+	Dpkg/Source/Package/V3_0/git.pm \
+	Dpkg/Source/Package/V3_0/quilt.pm \
+	Dpkg/Source/Patch.pm \
 	Dpkg.pm
 
 do_perl_subst = sed -e "s:^\#![:space:]*/usr/bin/perl:\#!$(PERL):" \

scripts/po/POTFILES.in

@@ -23,9 +23,23 @@ scripts/Dpkg/Control.pm
 scripts/Dpkg/Deps.pm
 scripts/Dpkg/ErrorHandling.pm
 scripts/Dpkg/Fields.pm
+scripts/Dpkg/IPC.pm
 scripts/Dpkg/Shlibs.pm
 scripts/Dpkg/Shlibs/Objdump.pm
 scripts/Dpkg/Shlibs/SymbolFile.pm
+scripts/Dpkg/Source/Archive.pm
+scripts/Dpkg/Source/CompressedFile.pm
+scripts/Dpkg/Source/Compressor.pm
+scripts/Dpkg/Source/Functions.pm
+scripts/Dpkg/Source/Patch.pm
+scripts/Dpkg/Source/Package.pm
+scripts/Dpkg/Source/Package/V1_0.pm
+scripts/Dpkg/Source/Package/V2_0.pm
+scripts/Dpkg/Source/Package/V3_0/bzr.pm
+scripts/Dpkg/Source/Package/V3_0/custom.pm
+scripts/Dpkg/Source/Package/V3_0/native.pm
+scripts/Dpkg/Source/Package/V3_0/git.pm
+scripts/Dpkg/Source/Package/V3_0/quilt.pm
 scripts/Dpkg/Substvars.pm
 scripts/Dpkg/Vars.pm
 scripts/Dpkg/Version.pm

scripts/t/800_Dpkg_IPC.t

@@ -0,0 +1,56 @@
+# -*- mode: cperl -*-
+
+use Test::More tests => 7;
+
+use strict;
+use warnings;
+use File::Temp qw(tempfile);
+
+use_ok('Dpkg::IPC');
+
+$/ = undef;
+
+my ($tmp_fh, $tmp_name) = tempfile;
+my ($tmp2_fh, $tmp2_name) = tempfile;
+
+my $string = "foo\nbar\n";
+my $string2;
+
+open TMP, '>', $tmp_name;
+print TMP $string;;
+close TMP;
+
+my $pid = fork_and_exec(exec => "cat",
+			from_string => \$string,
+			to_string => \$string2);
+
+ok($pid);
+
+is($string2, $string, "{from,to}_string");
+
+$pid = fork_and_exec(exec => "cat",
+		     from_handle => $tmp_fh,
+		     to_handle => $tmp2_fh);
+
+ok($pid);
+
+wait_child($pid);
+
+open TMP, '<', $tmp2_name;
+$string2 = <TMP>;
+close TMP;
+
+is($string2, $string, "{from,to}_handle");
+
+$pid = fork_and_exec(exec => "cat",
+		     from_file => $tmp_name,
+		     to_file => $tmp2_name,
+		     wait_child => 1);
+
+ok($pid);
+
+open TMP, '<', $tmp2_name;
+$string2 = <TMP>;
+close TMP;
+
+is($string2, $string, "{from,to}_file");