Dpkg::Source::Patch: New module to generate and apply patches

* scripts/Dpkg/Source/Patch.pm: New module that is able to
generate patches (between files or between directories). It's
also able to apply patches. Built on CompressedFile, it
handles compression/decompression of patches files on the fly.
It still lack some functionalities of dpkg-source (patch
analysis and pre-creation of new directories before patch
application).
* scripts/dpkg-source.pl: Replaced big chunks of the code by
some usage of Dpkg::Source::Patch. More to come later.
* scripts/Makefile.am, scripts/po/POTFILES.in: Register the new
module file.

scripts/Dpkg/Source/Patch.pm

@@ -0,0 +1,273 @@
+# 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 syserr warning subprocerr);
+
+use POSIX;
+use File::Find;
+use File::Basename;
+use File::Spec;
+use Fcntl ':mode';
+
+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->close() unless $opts{"noclose"};
+    }
+}
+
+sub add_diff_file {
+    my ($self, $old, $new, %opts) = @_;
+    # 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"}) {
+        # 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;
+    while (<$diffgen>) {
+        if (m/^binary/i) {
+            $self->_fail_with_msg($new,_g("binary file contents changed"));
+            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
+    my $exit = WEXITSTATUS($?);
+    unless (WIFEXITED($?) && ($exit == 0 || $exit == 1)) {
+        subprocerr(_g("diff on %s"), $new);
+    }
+    return $exit;
+}
+
+sub add_diff_directory {
+    my ($self, $old, $new, %opts) = @_;
+    # TODO: make this function more configurable
+    # - offer diff generation for removed files
+    # - offer to disable some checks
+    my $basedir = $opts{"basedirname"} || basename($new);
+    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);
+        next 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';
+                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 (not -f _) {
+                $self->_fail_not_same_type("$old/$fn", "$new/$fn");
+                return;
+            }
+
+            $self->add_diff_file($old_file, "$new/$fn",
+                label_old => "$basedir.orig/$fn",
+                label_new => "$basedir/$fn",
+                %opts);
+        } 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("$new/$fn") || syserr(_g("cannot stat file %s"), "$old/$fn");
+        if (-f _) {
+            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 close {
+    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 _fail_with_msg {
+    my ($self, $file, $msg) = @_;
+    printf(STDERR _g("%s: cannot represent change to %s: %s")."\n",
+                  $progname, $file, $msg);
+    $self->{'errors'}++;
+}
+sub _fail_not_same_type {
+    my ($self, $old, $new) = @_;
+    my $old_type = get_type($old);
+    my $new_type = get_type($new);
+    printf(STDERR _g("%s: cannot represent change to %s:\n".
+                     "%s:  new version is %s\n".
+                     "%s:  old version is %s\n"),
+                  $progname, $new, $progname, $old_type, $progname, $new_type);
+    $self->{'errors'}++;
+}
+
+sub apply {
+    my ($self, $destdir, %opts) = @_;
+    # TODO: check diff
+    # TODO: create missing directories
+    $opts{"options"} ||= [ '-s', '-t', '-F', '0', '-N', '-p1', '-u',
+            '-V', 'never', '-g0', '-b', '-z', '.dpkg-orig'];
+    my $diff_handle = $self->open_for_read();
+    fork_and_exec(
+	'exec' => [ 'patch', @{$opts{"options"}} ],
+	'chdir' => $destdir,
+	'env' => { LC_ALL => 'C', LANG => 'C' },
+	'wait_child' => 1,
+	'from_handle' => $diff_handle
+    );
+    $self->cleanup_after_open();
+}
+
+# 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 %"), 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

@@ -108,6 +108,7 @@ nobase_dist_perllib_DATA = \
 	Dpkg/Source/Archiver.pm \
 	Dpkg/Source/CompressedFile.pm \
 	Dpkg/Source/Compressor.pm \
+	Dpkg/Source/Patch.pm \
 	Dpkg/Source/VCS/git.pm \
 	Dpkg.pm
 

scripts/dpkg-source.pl

@@ -22,6 +22,7 @@ use Dpkg::Vars;
 use Dpkg::Changelog qw(parse_changelog);
 use Dpkg::Source::Compressor;
 use Dpkg::Source::Archiver;
+use Dpkg::Source::Patch;
 use Dpkg::IPC;
 
 my @filesinarchive;
@@ -650,162 +651,20 @@ if ($opmode eq 'build') {
             || &syserr(_g("write building diff message"));
 	my ($ndfh, $newdiffgz) = tempfile( "$diffname.new.XXXXXX",
 					DIR => &getcwd, UNLINK => 0 );
-	my $compressor = Dpkg::Source::Compressor->new();
-	my $diff_handle;
-	$compressor->compress(from_pipe => \$diff_handle, to_file => $newdiffgz);
-
-        my $find_handle;
-        my $pid = fork_and_exec(
-            'exec' => [ 'find', '.', '-print0' ],
-            'chdir' => $dir,
-            'to_pipe' => \$find_handle,
-        );
-        $/ = "\0";
-
-      file:
-        while (defined($fn= <$find_handle>)) {
-            $fn =~ s/\0$//;
-            next file if $fn =~ m/$diff_ignore_regexp/o;
-            $fn =~ s,^\./,,;
-            lstat("$dir/$fn") || syserr(_g("cannot stat file %s"), "$dir/$fn");
-	    my $mode = S_IMODE((lstat(_))[2]);
-	    my $size = (lstat(_))[7];
-            if (-l _) {
-                $type{$fn}= 'symlink';
-		checktype($origdir, $fn, '-l') || next;
-		defined(my $n = readlink("$dir/$fn")) ||
-                    syserr(_g("cannot read link %s"), "$dir/$fn");
-		defined(my $n2 = readlink("$origdir/$fn")) ||
-                    syserr(_g("cannot read orig link %s"), "$origdir/$fn");
-                $n eq $n2 || &unrepdiff2(sprintf(_g("symlink to %s"), $n2),
-                                         sprintf(_g("symlink to %s"), $n));
-            } elsif (-f _) {
-		my $ofnread;
-
-                $type{$fn}= 'plain file';
-                if (!lstat("$origdir/$fn")) {
-                    $! == ENOENT ||
-                        syserr(_g("cannot stat orig file %s"), "$origdir/$fn");
-                    $ofnread= '/dev/null';
-		    if( !$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 (-f _) {
-                    $ofnread= "$origdir/$fn";
-                } else {
-                    &unrepdiff2(_g("something else"),
-                                _g("plain file"));
-                    next;
-                }
+        my $diff = Dpkg::Source::Patch->new(filename => $newdiffgz,
+                compression => get_compression_from_filename($diffname));
+        $diff->create();
+        $diff->add_diff_directory($origdir, $dir,
+                basedirname => $basedirname,
+                diff_ignore_regexp => $diff_ignore_regexp);
+        $diff->close() || $ur++;
 
-                my $tab = ("$basedirname/$fn" =~ / /) ? "\t" : '';
-                my $diffgen;
-                my $diff_pid = fork_and_exec(
-                    'exec' => [ 'diff', '-u', '-p',
-                                '-L', "$basedirname.orig/$fn$tab",
-                                '-L', "$basedirname/$fn$tab",
-                                '--', "$ofnread", "$dir/$fn" ],
-                    'env' => { LC_ALL => 'C', LANG => 'C', TZ => 'UTC0' },
-                    'to_pipe' => \$diffgen
-                );
-                my $difflinefound = 0;
-                $/ = "\n";
-                while (<$diffgen>) {
-                    if (m/^binary/i) {
-                        close($diffgen);
-                        $/ = "\0";
-                        &unrepdiff(_g("binary file contents changed"));
-                        next file;
-                    } elsif (m/^[-+\@ ]/) {
-                        $difflinefound=1;
-                    } elsif (m/^\\ No newline at end of file$/) {
-                        warning(_g("file %s has no final newline (either " .
-                                   "original or modified version)"), $fn);
-                    } else {
-                        s/\n$//;
-                        internerr(_g("unknown line from diff -u on %s: `%s'"),
-                                  $fn, $_);
-                    }
-                    print($diff_handle $_) || syserr(_g("failed to write to compression pipe"));
-                }
-                close($diffgen);
-                wait_child($diff_pid, nocheck => 1, cmdline => 'diff');
-                $/ = "\0";
-		my $es;
-                if (WIFEXITED($?) && (($es=WEXITSTATUS($?))==0 || $es==1)) {
-                    if ($es==1 && !$difflinefound) {
-                        &unrepdiff(_g("diff gave 1 but no diff lines found"));
-                    }
-                } else {
-		    subprocerr(_g("diff on %s"), "$dir/$fn");
-                }
-            } elsif (-p _) {
-                $type{$fn}= 'pipe';
-		checktype($origdir, $fn, '-p');
-            } elsif (-b _ || -c _ || -S _) {
-                &unrepdiff(_g("device or socket is not allowed"));
-            } elsif (-d _) {
-                $type{$fn}= 'directory';
-		if (!lstat("$origdir/$fn")) {
-		    $! == ENOENT ||
-		        syserr(_g("cannot stat orig file %s"), "$origdir/$fn");
-		} elsif (! -d _) {
-		    &unrepdiff2(_g('not a directory'),
-		                _g('directory'));
-		}
-            } else {
-                &unrepdiff(sprintf(_g("unknown file type (%s)"), $!));
-            }
-        }
-        close($find_handle);
-        wait_child($pid);
-        close($diff_handle) || syserr(_g("finish write to compression pipe"));
-        $compressor->wait_end_process();
 	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);
 
-        $find_handle = undef;
-        $pid = fork_and_exec(
-            'exec' => [ 'find', '.', '-print0' ],
-            'chdir' => $origdir,
-            'to_pipe' => \$find_handle,
-        );
-        $/ = "\0";
-        while (defined($fn= <$find_handle>)) {
-            $fn =~ s/\0$//;
-            next if $fn =~ m/$diff_ignore_regexp/o;
-            $fn =~ s,^\./,,;
-            next if defined($type{$fn});
-            lstat("$origdir/$fn") ||
-                syserr(_g("cannot check orig file %s"), "$origdir/$fn");
-            if (-f _) {
-		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 {
-                &unrepdiff2(_g('not a file, directory or link'),
-                            _g('nonexistent'));
-            }
-        }
-        close($find_handle);
-        wait_child($pid);
-
 	addfile($fields, $diffname);
 
     }
@@ -1128,24 +987,8 @@ if ($opmode eq 'build') {
 
     for my $patch (@patches) {
 	printf(_g("%s: applying %s")."\n", $progname, $patch);
-	my ($diff_handle, $compressor);
-	if ($patch =~ /\.$comp_regex$/) {
-	    $compressor = Dpkg::Source::Compressor->new();
-	    $compressor->uncompress(from_file => $patch, to_pipe => \$diff_handle);
-	} else {
-	    open $diff_handle, $patch or error(_g("can't open diff `%s'"), $patch);
-	}
-
-	fork_and_exec(
-	    'exec' => [ 'patch', '-s', '-t', '-F', '0', '-N', '-p1', '-u',
-	                '-V', 'never', '-g0', '-b', '-z', '.dpkg-orig' ],
-	    'chdir' => $newdirectory,
-	    env => { LC_ALL => 'C', LANG => 'C' },
-	    wait_child => 1,
-	    from_handle => $diff_handle
-	);
-
-	$compressor->wait_end_process() if $patch =~ /\.$comp_regex$/;
+	my $patch_obj = Dpkg::Source::Patch->new(filename => $patch);
+	$patch_obj->apply($newdirectory);
     }
 
     my $now = time;

scripts/po/POTFILES.in

@@ -30,6 +30,7 @@ scripts/Dpkg/Shlibs/SymbolFile.pm
 scripts/Dpkg/Source/Archiver.pm
 scripts/Dpkg/Source/CompressedFile.pm
 scripts/Dpkg/Source/Compressor.pm
+scripts/Dpkg/Source/Patch.pm
 scripts/Dpkg/Source/VCS/git.pm
 scripts/Dpkg/Substvars.pm
 scripts/Dpkg/Vars.pm