Initial import for the new infrastruture for l10n

CVS version numbers

Perl/Debian/L10n/Db.pm: INITIAL -> 1.1 
Perl/Debian/L10n/Debconf.pm: INITIAL -> 1.1 
Perl/Debian/Pkg/DebSrc.pm: INITIAL -> 1.1 
Perl/Debian/Pkg/Diff.pm: INITIAL -> 1.1 
Perl/Debian/Pkg/Tar.pm: INITIAL -> 1.1

5 files changed, 2582 insertions, 0 deletions

diff --git a/Perl/Debian/L10n/Db.pm b/Perl/Debian/L10n/Db.pm
new file mode 100644
index 00000000000..d8ea3cbb14f
--- /dev/null
+++ b/Perl/Debian/L10n/Db.pm
@@ -0,0 +1,457 @@
+#!/usr/bin/perl -w
+
+##  Copyright (C) 2001-2004  Denis Barbier <barbier@debian.org>
+##  Copyright (C) 2004       Martin Quinson <martin.quinson@tuxfamily.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.
+
+=head1 NAME
+
+Debian::L10n::Db - handle database of debian l10n stuff
+
+=head1 SYNOPSIS
+
+ use Debian::L10n::Db;
+ my $l10n_db = Debian::L10n::Db->new();
+ $l10n_db->read("../data/unstable");
+ foreach ($l10n_db->list_packages()) {
+         print "Package $_ ".$l10n_db->version($_)."\n";
+ }
+
+=head1 DESCRIPTION
+
+This module is an interface to the database files used in several places of
+the debian localisation infrastructure, such as the webpages under
+C<webwml/E<lt>languageE<gt>/internaltional/l10n/>.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Debian::L10n::Db;
+use strict;
+use Time::localtime;
+
+#   Do not use ``our'' to be compatible with Perl 5.005
+use vars (qw($AUTOLOAD));
+
+=item new
+
+This is the constructor, it only performs some initialization.
+
+   my $l10n_db = Debian::L10n::Db->new();
+
+=cut
+
+sub new {
+        my $proto = shift;
+        my $class = ref($proto) || $proto;
+        my $self  = {
+                data    => {},
+	        #   Fields below constitute the header of the files. they are written 
+	        #   as fields of a package called '' (that's the same trick than in po files)
+	        
+	        # Language Year Month Message are for the spider
+	        headers => [qw{Date Language Year Month Message}],
+                #   Fields below are written into file in the same order
+                #   Package must always be the first field
+	    
+                #   Switch is used temporarily to detect packages which
+                #   depend on debconf and did not switch to using po-debconf.
+                scalar  => [qw(Package Version Section Priority Maintainer PoolDir Type Upstream 
+		               Switch )],
+                array1  => [qw(Errors Catgets Gettext)],
+                array2  => [qw(NLS PO TEMPLATES PODEBCONF MENU DESKTOP MAN STATUS)],
+        };
+        $self->{methods} = {};
+        foreach (@{$self->{scalar}}) {
+                $self->{fields}->{$_} = '$';
+        }
+        foreach (@{$self->{array1}}) {
+                $self->{fields}->{$_} = '@';
+        }
+        foreach (@{$self->{array2}}) {
+                $self->{fields}->{$_} = '@@';
+        }
+        foreach (keys %{$self->{fields}}) {
+                $self->{methods}->{lc $_} = $_;
+        }
+        bless ($self, $class);
+        return $self;
+}
+
+sub AUTOLOAD {
+        my $self = shift;
+        my $type = ref($self) or die "$self is not an object";
+        my $pkg  = shift;
+
+        my $name = $AUTOLOAD;
+        $name =~ s/.*://;   # strip fully-qualified portion
+
+        return defined($self->{data}->{$pkg}) if $name eq 'has_package';
+
+        #   Add a new package into database
+        $self->{data}->{$pkg} = {} if $name eq 'package';
+
+        if (! defined $self->{data}->{$pkg}) {
+                warn __PACKAGE__.": Package $pkg does not exist, method \`$name' skipped\n";
+                return;
+        }
+        my $has = "";
+        my $add = "";
+        if ($name =~ s/^has_//) {
+                $has = "has_";
+        } elsif ($name =~ s/^add_//) {
+                $add = "add_";
+        }
+
+        die "Can't access \`$has$name' method in class $type"
+                unless defined($self->{methods}->{$name});
+
+        my $field = $self->{methods}->{$name};
+
+        if ($has) {
+                return defined($self->{data}->{$pkg}->{$field});
+        } else {
+                if ($#_ == -1) {
+                        if ($self->{fields}->{$field} =~ m/@/) {
+                                return $self->{data}->{$pkg}->{$field} || [];
+                        }
+                        return $self->{data}->{$pkg}->{$field};
+                }
+                if ($self->{fields}->{$field} eq '$') {
+                        $self->{data}->{$pkg}->{$field} = $_[0];
+                } elsif ($self->{fields}->{$field} eq '@') {
+                        $self->{data}->{$pkg}->{$field} = []
+                                unless defined($self->{data}->{$pkg}->{$field})
+                                        || !$add;
+                        push (@{$self->{data}->{$pkg}->{$field}}, @_);
+                } elsif ($self->{fields}->{$field} eq '@@') {
+                        $self->{data}->{$pkg}->{$field} = []
+                                unless defined($self->{data}->{$pkg}->{$field})
+                                        || !$add;
+                        my @list = @_;
+                        push (@{$self->{data}->{$pkg}->{$field}}, \@list);
+                } else {
+                        die __PACKAGE__.":internal error: unknown data type:".$self->{fields}->{$field}."\n";
+                }
+        }
+}
+
+#    Perl 5.6.1 complains when it does not find this routine
+sub DESTROY {
+}
+
+=item read
+
+Read database from a given file.  Returns 1 on success and otherwise 0.
+
+   $l10n_db->read("foo");
+
+=cut
+
+sub read {
+        my $self = shift;
+        my $file  = shift;
+        my $check  = shift;
+        $check = 1 unless defined $check;
+    
+        if ($file =~ m/\.gz$/) {
+                open (DB,"gzip -dc $file |") || return 0;
+        } else {
+                open (DB,"< $file") || return 0;
+        }
+
+        MAIN: while (1) {
+                my $entry = {};
+                my $desc = '';
+                my $last_item = 0;
+                my $text;
+
+                while (<DB>) {
+                        last if m/^\s*$/;
+                        $desc .= $_;
+                }
+	        if ($desc =~ m/^[0-9]{4}-[0-9]{2}-[0-9]{2}$/) { # Parse old format date
+		    $self->set_date($_);
+		    next MAIN;
+		}
+                if (!defined($_)) {
+                        last unless $desc =~ m/\S/;
+                        $last_item = 1;
+                }
+
+                # Leading tabs are illegal, but handle them anyway
+                $desc =~ s/^\t/ \t/mg;
+
+                foreach (@{$self->{scalar}}) {
+                        if ($desc =~ m/^$_: ?(.*)$/m) {
+ 			        if ($_ eq 'Package' && defined $self->{data}->{$1} && length($1)) {
+                                        $entry = $self->{data}->{$1};
+                                } elsif ($_ eq 'Package' && length($1) == 0) {
+				    foreach (@{$self->{headers}}) {
+					if ($desc =~ m/^$_: (.*)$/m) {
+					    $self->set_header($_,$1);
+					}
+				    }
+				    next MAIN;
+				} else {
+                                        $entry->{$_} = $1;
+                                }
+                        } elsif ($check && $_ ne 'Switch' && $_ ne 'STATUS') {
+			        $desc =~ s/^/  /mg;
+                                warn "Parse error when reading $file: Package ".(defined($entry->{Package}) ? $entry->{Package} : "<unknown>").": missing \`$_' field\nDescription follows:\n$desc\n";
+#                                next MAIN;
+                        }
+                }
+                foreach (@{$self->{array1}}) {
+                        if ($desc =~ m/(^|\n)$_:\n(.+?)(\n\S|$)/s) {
+                                $text = $2;
+                                $text =~ s/^ //mg;
+                                my @list = split(/\n\./, $text);
+                                $entry->{$_} = \@list;
+                        }
+                }
+                foreach (@{$self->{array2}}) {
+                        if ($desc =~ m/(^|\n)$_:\n(.+?)(\n\S|$)/s) {
+                                $text = $2;
+                                $text =~ s/^ //mg;
+                                my @list = ();
+                                foreach my $line (split(/\n/, $text)) {
+                                        my @list2 = split('!', $line);
+                                        push(@list, \@list2);
+                                }
+                                $entry->{$_} = \@list;
+                        }
+                }
+                $self->{data}->{$entry->{Package}} = $entry;
+                last if $last_item;
+        }
+        close DB;
+        return defined($self->{data}->{''}->{Date});
+}
+
+=item write
+
+Write database into file.
+
+   $l10n_db->write("foo");
+
+=cut
+
+sub write {
+        my $self = shift;
+        my $file = shift;
+        my ($text, $line);
+
+        my $dir  = $file;
+        $dir  =~ s#/+[^/]*$##;
+
+        File::Path::mkpath($dir, 0, 0755) unless (-d $dir);
+    
+        if ($file =~ m/\.gz$/) {
+                open (DB,"| gzip -c > $file")
+                        || die "Unable to write to $file: $!\n";
+        } else {
+                open (DB,"> $file")
+                        || die "Unable to write to $file: $!\n";
+        }
+
+        $self->set_date(sprintf "%d-%02d-%02d", 
+	                        Time::localtime::localtime->year() + 1900, 
+	                        Time::localtime::localtime->mon() + 1, 
+	                        Time::localtime::localtime->mday);
+        print DB "Package:\n";
+        foreach (@{$self->{headers}}) {
+	    next unless defined($self->{data}->{''}->{$_});
+	    print DB $_.": ".$self->{data}->{''}->{$_}."\n";
+	}
+        print DB "\n";
+        foreach my $pkg (sort keys %{$self->{data}}) {
+	        next if $pkg eq ''; # skip headers
+                foreach (@{$self->{scalar}}) {
+                        next unless defined($self->{data}->{$pkg}->{$_});
+                        print DB $_.": ".$self->{data}->{$pkg}->{$_}."\n";
+                }
+                foreach (@{$self->{array1}}) {
+                        next unless defined($self->{data}->{$pkg}->{$_});
+                        $text = join("\n\.\n", @{$self->{data}->{$pkg}->{$_}})."\n";
+                        $text =~ s/\n\n/\n/g;
+                        $text =~ s/\n+$//s;
+                        $text =~ s/^/ /mg;
+                        print DB $_.":\n".$text."\n";
+                }
+                foreach (@{$self->{array2}}) {
+                        next unless defined($self->{data}->{$pkg}->{$_});
+                        $text = '';
+                        foreach $line (@{$self->{data}->{$pkg}->{$_}}) {
+                                $text .= ' '.join('!', @{$line})."\n";
+                        }
+                        print DB $_.":\n".$text;
+                }
+                print DB "\n";
+        }
+        close (DB) || die "Unable to close $file: $!\n";
+}
+
+=item list_packages
+
+Returns an array with the list of package names
+
+=cut
+
+sub list_packages {
+        my $self = shift;
+        return keys %{$self->{data}};
+}
+
+=item clear_pkg
+
+Reset info for a given package
+
+   $l10n_db->clear_pkg("foo");
+
+=cut
+
+sub clear_pkg {
+        my $self = shift;
+        my $pkg  = shift;
+
+        delete $self->{data}->{$pkg};
+}
+
+=item set_status
+
+Change the status for the category specified as second argument.
+
+=cut
+
+sub set_status {
+    my ($db,$pkg,$type,$file,$date,$status,$translator,$url,$bug_nb) = @_;
+
+    foreach my $line (@{$db->{data}->{$pkg}->{STATUS}}) {
+	if (${$line}[0] eq $type) {
+	    ${$line}[1] = $file;
+	    ${$line}[2] = $date;
+	    ${$line}[3] = $status;
+	    ${$line}[4] = $translator;
+	    ${$line}[5] = $url;
+	    ${$line}[6] = $bug_nb;
+	    return
+	}
+    }
+    $db->add_status($pkg,$type,$file,$date,$status,$translator,$url,$bug_nb);
+}
+
+=item del_status
+
+Del the package if there was only one status line. 
+It should remove the right line from the DB, and empty the package if nothing else is left.
+
+=cut
+
+sub del_status {
+    my ($db,$pkg,$type) = @_;
+    if (scalar @{$db->{data}->{$pkg}->{STATUS}} == 1) {
+	$db->clear_pkg($pkg);
+    } else {
+	print "Ups, sorry, cannot del_status when there is more than one status field in the pkg\n";
+    }
+#    foreach my $line (@{$db->{data}->{$pkg}->{STATUS}}) {
+#	if (${$line}[0] eq $type) {
+#	    print "Do not remove $type from $pkg since it's not implemented yet\n";
+#        }
+#    }
+}
+
+
+=item get_header
+
+Returns the value of the specified header
+
+=cut
+
+sub get_header {
+#    print "get $_[1] -> ".($_[0]->{data}->{''}->{$_[1]})."\n";
+    return $_[0]->{data}->{''}->{$_[1]};
+}
+
+=item set_header
+
+Sets the specified header to the specified value
+
+=cut
+
+sub set_header {
+#    print "set $_[1] -> $_[2]\n";
+    $_[0]->{data}->{''}->{$_[1]} = $_[2];
+}
+
+
+=item get_date
+
+Returns date of generation
+
+=cut
+
+sub get_date {
+    return get_header($_[0],'Date');
+}
+
+=item set_date
+
+Sets the date of generation
+
+=cut
+
+sub set_date {
+    set_header($_[0],'Date',$_[1]);
+}
+
+
+=back
+
+=head2 DATA MANIPULATION
+
+Data about packages can be classified within scalar values (C<package>,
+C<version>, C<section>, C<priority>, C<maintainer>, C<pooldir>, C<type>,
+C<upstream>), arrays (C<errors>, C<catgets>, C<gettext>), and arrays of
+arrays (C<nls>, C<po>, C<templates>, C<podebconf>, C<man>, C<menu> and
+C<desktop>).
+Each field has a method with the same name to get and set it, e.g.
+
+   $section = $l10n_db->section($pkg);
+   $l10n_db->section($pkg, "libs");
+
+The first line get the section associated with the package in C<$pkg>,
+whereas the second set it to C<libs>.
+
+Two other methods are also defined to access those data, by prefixing
+field name by C<has_> and C<add_>.  The former is used to ask whether
+this field is defined in database, and the latter appends values for
+arrays or arrays of arrays.
+
+   if ($l10n_db->has_templates($pkg)) {
+           print "Package $pkg has Debconf templates\n";
+   }
+   $l10n_db->add_po($pkg, 'po/fr.po', 'fr', '42t0f0u', 'po/adduser_3.42_po_fr.po');
+
+=head1 AUTHOR
+
+Copyright (C) 2001-2004  Denis Barbier <barbier@debian.org>
+Copyright (C) 2004       Martin Quinson <enough@spam>
+
+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.
+
+=cut
+
+1;
+
diff --git a/Perl/Debian/L10n/Debconf.pm b/Perl/Debian/L10n/Debconf.pm
new file mode 100644
index 00000000000..d6dd587123c
--- /dev/null
+++ b/Perl/Debian/L10n/Debconf.pm
@@ -0,0 +1,472 @@
+#!/usr/bin/perl -w
+
+##  Copyright (C) 2001  Denis Barbier <barbier@debian.org>
+##  Copyright (C) 2004  Martin Quinson
+##
+##  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.
+
+=head1 NAME
+
+Debian::L10n::Debconf - translation status of Debconf templates
+
+=head1 SYNOPSIS
+
+ use Debian::L10n::Debconf;
+ my $tmpl = Debian::L10n::Debconf->new();
+ $tmpl->read_compact($file);
+ my @languages = $tmpl->langs();
+ foreach (sort @languages) {
+        my ($t,$f,$u) = $tmpl->stats($_);
+        print "$_:${t}t${f}f${u}u\n";
+ }
+
+=head1 DESCRIPTION
+
+This module extracts informations about translation status of Debconf
+templates files.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Debian::L10n::Debconf;
+
+use strict;
+
+=item new
+
+This is the constructor.
+
+   my $tmpl = Debian::L10n::Debconf->new();
+
+=cut
+
+sub new {
+        my $proto = shift;
+        my $class = ref($proto) || $proto;
+        my $self = {};
+        bless ($self, $class);
+        $self->_init();
+        return $self;
+}
+
+sub _init {
+        my $self = shift;
+
+        $self->{orig}  = {};
+        $self->{count} = 0;
+        $self->{trans} = {};
+        $self->{langs} = {};
+        $self->{files} = {};
+}
+
+=item read_compact
+
+Read a templates file containing all translations.  An optional second
+argument may be used, any non-zero value tells that this file comes with
+translations in other files.  In such a case no warning is raised if this
+file contains translated fields, because maintainer is assumed to be
+responsible for such translations.
+
+   $tmpl->read_compact($file);
+
+=cut
+
+sub read_compact {
+        my $self = shift;
+        my $file = shift;
+        my $safe = shift || 0;
+        my ($lang, $msg);
+
+        $self->_init();
+        open (TMPL, "< $file")
+                || die "Unable to read file $file\n";
+
+        my $tmpl = '';
+        my $line = 0;
+        while (<TMPL>) {
+                chomp;
+                $line ++;
+                if (m/^[A-Z][a-z]*-[A-Za-z_]+-fuzzy:/) {
+                        warn "$file:$line: fuzzy-fields-in-templates\n";
+                        goto SKIP;
+                }
+                if ((!$safe) && m/^[A-Z][a-z]*-[A-Za-z_]+:/) {
+                        warn "$file:$line: translated-fields-in-master-templates\n";
+                        #   Display this message only once
+                        $safe = 1;
+                }
+                if (s/^Template:\s*//) {
+                        $tmpl = $_;
+                        $self->{orig}->{$tmpl} = {};
+                } elsif (s/^(Choices):\s*//) {
+                        if ($tmpl eq '') {
+                                warn "$file:$line: \`$1' field found before \`Template'\n";
+                                goto SKIP;
+                        }
+                        $self->{orig}->{$tmpl}->{choices} = $_;
+                        $self->{count} ++;
+                } elsif (s/^(Description):\s*//) {
+                        if ($tmpl eq '') {
+                                warn "$file:$line: \`$1' field found before \`Template'\n";
+                                goto SKIP;
+                        }
+                        $msg = $_ . "\n";
+                        while (<TMPL>) {
+                                $line ++;
+                                last if (!defined($_) || m/^\S/ || m/^$/m);
+                                $msg .= $_;
+                        }
+                        $msg =~ s/^\s+//gm;
+                        $msg =~ s/\s+$//gm;
+                        $msg =~ tr/ \t\n/ /s;
+                        $self->{orig}->{$tmpl}->{description} = $msg;
+                        $self->{count} ++;
+                        last unless defined($_);
+                        $line --;
+                        redo;
+                } elsif (s/^(Choices-(.*?)):\s*//) {
+                        if ($tmpl eq '') {
+                                warn "$file:$line: \`$1' field found before \`Template'\n";
+                                goto SKIP;
+                        }
+                        $lang = $2;
+                        unless (defined($self->{langs}->{$lang})) {
+                                $self->{langs}->{$lang} = 1;
+                                $self->{trans}->{$lang}->{count} = 0;
+                                $self->{trans}->{$lang}->{fuzzy} = 0;
+                        }
+                        $self->{trans}->{$lang}->{count} ++;
+                } elsif (s/^(Description-(.*?)):\s+//) {
+                        if ($tmpl eq '') {
+                                warn "$file:$line: \`$1' field found before \`Template'\n";
+                                goto SKIP;
+                        }
+                        $lang = $2;
+                        unless (defined($self->{langs}->{$lang})) {
+                                $self->{langs}->{$lang} = 1;
+                                $self->{trans}->{$lang}->{count} = 0;
+                                $self->{trans}->{$lang}->{fuzzy} = 0;
+                        }
+                        do {
+                                $_ = <TMPL>;
+                                $line ++;
+                        } until (!defined($_) || m/^\S/ || m/^$/m);
+                        $self->{trans}->{$lang}->{count} ++;
+                        last unless defined($_);
+                        $line --;
+                        redo;
+                } elsif (m/^\s*$/) {
+                        $tmpl = '';
+                } elsif (m/^(Type|Default)/) {
+                        #   Ignored fields
+                } else {
+                        warn "$file:$line: Wrong input line:\n $_\n";
+                }
+                next;
+
+                SKIP:
+                        while (<TMPL>) {
+                                $line ++;
+                                last if (!defined($_) || m/^\S/ || m/^$/m);
+                        }
+                        last unless defined($_);
+                        $line --;
+                        redo;
+        }
+        close(TMPL);
+}
+
+=item read_dispatched
+
+Read templates contained in several files.  First argument is the English file,
+all other arguments are translated templates files.
+
+   @trans = qw(templates.de templates.fr templates.ja templates.nl);
+   $tmpl->read_dispatched('templates', @trans);
+
+=cut
+
+sub read_dispatched {
+        my $self = shift;
+        my $file = shift;
+
+        $self->_init();
+        $self->read_compact($file, 1);
+        $self->{trans} = {};
+        $self->{langs} = {};
+        foreach my $trans (@_) {
+                $self->_read_dispatched($trans);
+        }
+}
+
+sub _read_dispatched {
+        my $self = shift;
+        my $file = shift;
+        my ($lang, $msg, $status_c, $status_d);
+
+        open (TMPL, "< $file")
+                || die "Unable to read file $file\n";
+
+        my $tmpl = '';
+        my $line = 0;
+        my $ext = $file;
+        $ext =~ s/.*\.//;
+        while (<TMPL>) {
+                chomp;
+                $line ++;
+                if (m/^[A-Z][a-z]*-[A-Za-z_]+-fuzzy:/) {
+                        warn "$file:$line: fuzzy-fields-in-templates\n";
+                        goto SKIP;
+                }
+                if (s/^Template:\s*//) {
+                        $tmpl = $_;
+                        $status_c = $status_d = '';
+                        unless (defined $self->{orig}->{$tmpl}) {
+                                warn "$file:$line: translated-templates-not-in-original $_\n";
+                                while (<TMPL>) {
+                                        $line ++;
+                                        last if (!defined($_) || m/^$/);
+                                }
+                                last unless defined($_);
+                                $line --;
+                                redo;
+                        }
+                } elsif (s/^(Choices):\s*//) {
+                        if ($tmpl eq '') {
+                                warn "$file:$line: \`$1' field found before \`Template'\n";
+                                goto SKIP;
+                        }
+                        next unless defined $self->{orig}->{$tmpl};
+                        if (defined($self->{orig}->{$tmpl}->{choices}) &&
+                            $_ eq $self->{orig}->{$tmpl}->{choices}) {
+                                $status_c = 'count';
+                        } else {
+                                $status_c = 'fuzzy';
+                        }
+                } elsif (s/^(Choices-(.*?)):\s*//) {
+                        if ($tmpl eq '') {
+                                warn "$file:$line: \`$1' field found before \`Template'\n";
+                                goto SKIP;
+                        }
+                        $lang = $2;
+                        if ($lang ne $ext) {
+                                warn "$file:$line: lang-mismatch-in-translated-templates\n"
+                        } else {
+                                unless (defined($self->{langs}->{$lang})) {
+                                        $self->{langs}->{$lang} = 1;
+                                        $self->{trans}->{$lang}->{count} = 0;
+                                        $self->{trans}->{$lang}->{fuzzy} = 0;
+                                }
+                                if ($status_c) {
+                                        $self->{trans}->{$lang}->{$status_c} ++;
+                                } else {
+                                        warn "$file:$line: original-fields-removed-in-translated-templates\n";
+                                }
+                                $status_c = '';
+                        }
+                } elsif (s/^(Description):\s*//) {
+                        if ($tmpl eq '') {
+                                warn "$file:$line: \`$1' field found before \`Template'\n";
+                                goto SKIP;
+                        }
+                        next unless defined $self->{orig}->{$tmpl};
+                        $msg = $_ . "\n";
+                        while (<TMPL>) {
+                                $line ++;
+                                last if (!defined($_) || m/^\S/ || m/^$/m);
+                                $msg .= $_;
+                        }
+                        $msg =~ s/^\s+//gm;
+                        $msg =~ s/\s+$//gm;
+                        $msg =~ tr/ \t\n/ /s;
+                        if (defined($self->{orig}->{$tmpl}->{description}) &&
+                            $msg eq $self->{orig}->{$tmpl}->{description}) {
+                                $status_d = 'count';
+                        } else {
+                                $status_d = 'fuzzy';
+                        }
+                        last unless defined($_);
+                        $line --;
+                        redo;
+                } elsif (s/^(Description-(.*?)):\s+//) {
+                        if ($tmpl eq '') {
+                                warn "$file:$line: \`$1' field found before \`Template'\n";
+                                goto SKIP;
+                        }
+                        $lang = $2;
+                        if ($lang ne $ext) {
+                                warn "$file:$line: lang-mismatch-in-translated-templates\n";
+                                do {
+                                        $_ = <TMPL>;
+                                        $line ++;
+                                } until (!defined($_) || m/^\S/ || m/^$/m);
+                        } else {
+                                if (defined($self->{files}->{$lang})) {
+                                        die "Lang \`$lang' found in \`$file' and \`$self->{files}->{$lang}'\n"
+                                                unless $self->{files}->{$lang} eq $file;
+                                } else {
+                                        $self->{files}->{$lang} = $file;
+                                }
+                                unless (defined($self->{langs}->{$lang})) {
+                                        $self->{langs}->{$lang} = 1;
+                                        $self->{trans}->{$lang}->{count} = 0;
+                                        $self->{trans}->{$lang}->{fuzzy} = 0;
+                                }
+                                do {
+                                        $_ = <TMPL>;
+                                        $line ++;
+                                } until (!defined($_) || m/^\S/ || m/^$/m);
+                                if ($status_d) {
+                                        $self->{trans}->{$lang}->{$status_d} ++;
+                                } else {
+                                        warn "$file:$line: original-fields-removed-in-translated-templates\n";
+                                }
+                                $status_d = '';
+                        }
+                        last unless defined($_);
+                        $line --;
+                        redo;
+                } elsif (m/^\s*$/) {
+                        $tmpl = '';
+                        $status_c = $status_d = '';
+                } elsif (m/^(Type|Default)/) {
+                        #   Ignored fields
+                } else {
+                        warn "$file:$line: Wrong input line:\n $_\n";
+                }
+                next;
+
+                SKIP:
+                        while (<TMPL>) {
+                                $line ++;
+                                last if (!defined($_) || m/^\S/ || m/^$/);
+                        }
+                        last unless defined($_);
+                        $line --;
+                        redo;
+        }
+        close(TMPL);
+}
+
+=item langs
+
+Return the languages in which this templates file is translated.
+
+   my @list = $tmpl->langs();
+
+=cut
+
+sub langs {
+        my $self = shift;
+        return keys %{$self->{langs}};
+}
+
+=item filename
+
+When templates are dispatched into several files, return the filename in
+which the language passed as argument is found.
+
+   my $filename = $tmpl->filename("de");
+
+=cut
+
+sub filename {
+        my $self = shift;
+        my $lang = shift;
+        return (defined($self->{files}->{$lang}) ? 
+                        $self->{files}->{$lang}  : '');
+}
+
+=item count
+
+Return the number of translatable strings in this templates file.
+
+   my $number = $tmpl->count();
+
+=cut
+
+sub count {
+        my $self = shift;
+        return $self->{count};
+}
+
+=item stats
+
+With an argument, return an array consisting of the number of
+translated, fuzzy and untranslated strings for the language given as
+argument.
+Without argument, return a hash array indexed by language and returning
+an array of the number of translated, fuzzy and untranslated strings.
+
+   my ($t, $f, $u) = $tmpl->stats("de");
+   my %stats  = $tmpl->stats();
+   foreach (keys %stats) {
+           print $_.':'. $stats{$_}->[0].'t'.$stats{$_}->[1].'f'.
+                $stats{$_}->[2]."u\n";
+   }
+
+=cut
+
+sub stats {
+        my $self = shift;
+        my $lang;
+        if (@_) {
+                $lang = shift;
+                if (defined($self->{langs}->{$lang})) {
+                        return ($self->{trans}->{$lang}->{count},
+                                $self->{trans}->{$lang}->{fuzzy},
+                                $self->{count} -
+                                        $self->{trans}->{$lang}->{fuzzy} -
+                                        $self->{trans}->{$lang}->{count});
+                } else {
+                        return (0,0,0);
+                }
+        } else {
+                my %stats = ();
+                foreach $lang (keys %{$self->{langs}}) {
+                        $stats{$lang} = [
+                                $self->{trans}->{$lang}->{count},
+                                $self->{trans}->{$lang}->{fuzzy},
+                                $self->{count} -
+                                        $self->{trans}->{$lang}->{fuzzy} -
+                                        $self->{trans}->{$lang}->{count}
+                        ];
+                }
+                return %stats;
+        }
+}
+
+=item entries
+
+Return an array containing all Debconf ids found in this templates file.
+
+   my @ids = $tmpl->entries();
+
+=cut
+
+sub entries {
+        my $self = shift;
+        return keys %{$self->{orig}};
+}
+
+=back
+
+=head1 AUTHOR
+
+Copyright (C) 2001  Denis Barbier <barbier@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.
+
+=cut
+
+1;
+
diff --git a/Perl/Debian/Pkg/DebSrc.pm b/Perl/Debian/Pkg/DebSrc.pm
new file mode 100644
index 00000000000..246dccc4c31
--- /dev/null
+++ b/Perl/Debian/Pkg/DebSrc.pm
@@ -0,0 +1,176 @@
+#!/usr/bin/perl -w
+
+##  Copyright (C) 2001  Denis Barbier <barbier@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.
+
+=head1 NAME
+
+Debian::Pkg::DebSrc - extract contents from Debian source package
+
+=head1 SYNOPSIS
+
+ use Debian::Pkg::DebSrc;
+ my $deb = Debian::Pkg::DebSrc->new("/path/to/foo_0.1-1.dsc");
+ my @list = $deb->list_files();
+ my $body = $deb->file_content("debian/control");
+
+=head1 DESCRIPTION
+
+This module extracts informations and files from a Debian source
+package.  It is built upon the C<Debian::Pkg::Tar> module, see
+its documentation for further details on available methods.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Debian::Pkg::DebSrc;
+
+use Debian::Pkg::Tar;
+@ISA = ("Debian::Pkg::Tar");
+
+use strict;
+use Carp;
+
+=item new
+
+This is the constructor.
+
+   my $deb = Debian::Pkg::DebSrc->new("/path/to/foo_0.1-1.dsc");
+
+Basically, C<dsc> file is parsed to read tarball and patch file
+names, then C<Debian::Pkg::Tar-E<gt>new> is called with tarball
+filename being first argument.  When a patch file is found,
+C<Debian::Pkg::Tar-E<gt>bind_patch> method is invoked.
+Optional arguments with a C<patch_> prefix are passed along to the
+latter (with the prefix removed), whereas other arguments are passed
+along to the former.
+
+   my $deb = Debian::Pkg::DebSrc->new("/path/to/foo_0.1-1.dsc",
+        parse_dft => 0,
+        patch_parse_dft => -1,
+   );
+
+is almost equivalent to
+
+   my $deb = Debian::Pkg::Tar->new("/path/to/foo_0.1.orig.tar.gz",
+        parse_dft => 0,
+   );
+   $deb->bind_patch( parse_dft => -1 );
+   $deb->parse();
+
+When tarball or patch file is required but does not exist, the C<new>
+method returns C<undef> after printing a warning.
+
+=cut
+
+sub new {
+        my $proto = shift;
+        my $class = ref($proto) || $proto;
+        my $file = shift;
+
+        my $dir  = $file;
+        $dir =~ s|/+[^/]*$||;
+
+        my $origtargz = '';
+        my $diffgz = '';
+        open(DSC, "< ".$file) or Carp::croak ("Unable to read $file");
+        while (<DSC>) {
+                last if m/^Files:/;
+        }
+        while (<DSC>) {
+                chomp;
+                last unless s/^ \S* \S* //;
+                if (m/\.tar\.gz$/) {
+                        $origtargz = $dir . '/' . $_;
+                        unless (-f $origtargz) {
+                                warn "$origtargz: No such file\n";
+                                return undef;
+                        }
+                } elsif (m/\.diff\.gz$/) {
+                        $diffgz = $dir . '/' . $_;
+                        unless (-f $diffgz) {
+                                warn "$diffgz No such file\n";
+                                return undef;
+                        }
+                }
+        }
+        close(DSC);
+        if ($origtargz eq '') {
+                warn "No tarball\n";
+                return undef;
+        }
+        my $self = $class->SUPER::new("$origtargz", @_);
+        bless ($self, $class);
+
+        #   Apply patch if found
+        my %patch_opts = ();
+        if ($#_ >= 0) {
+                my %opts = @_;
+                foreach (keys %opts) {
+                        next unless s/^patch_//;
+                        $patch_opts{$_} = $opts{'patch_'.$_};
+                }
+        }
+        $patch_opts{olddirsuffix} = '.orig'
+                if !defined($patch_opts{olddirsuffix});
+        $self->bind_patch($diffgz, %patch_opts) if $diffgz ne '';
+        $self->parse();
+        return $self;
+}
+
+=item get_tar_name
+
+Returns the full qualified name of tarball
+
+   my $tarfile = $deb->get_tar_name();
+
+=cut
+
+sub get_tar_name {
+        my $self = shift;
+        return $self->{name};
+}
+
+=item get_diff_name
+
+Returns the full qualified name of the diff file, or empty string if it
+does not exist.
+
+   my $patchname = $deb->get_diff_name();
+
+=cut
+
+sub get_diff_name {
+        my $self = shift;
+        return (defined($self->{patch}) ? $self->{patch}->{name} : '');
+}
+
+=back
+
+=head1 LIMITATIONS
+
+It is a pain to retrieve content of Debian packages when in dbs format,
+since C<debian/rules> must be called to apply patches on upstream tarball.
+It does not make much sense to use an in-memory representation is such a
+case, so this module will surely not try to ease parsing such packages.
+
+=head1 AUTHOR
+
+Copyright (C) 2001  Denis Barbier <barbier@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.
+
+=cut
+
+1;
+
diff --git a/Perl/Debian/Pkg/Diff.pm b/Perl/Debian/Pkg/Diff.pm
new file mode 100644
index 00000000000..1808bb09ef8
--- /dev/null
+++ b/Perl/Debian/Pkg/Diff.pm
@@ -0,0 +1,652 @@
+#!/usr/bin/perl -w
+
+##  Copyright (C) 2001  Denis Barbier <barbier@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.
+
+=head1 NAME
+
+Debian::Pkg::Diff - examine and apply patch
+
+=head1 DESCRIPTION
+
+This package reads a patch file in memory, and apply hunks on demand.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Debian::Pkg::Diff;
+use strict;
+use Carp;
+use Symbol;
+
+=item new
+
+This is the constructor. It has a mandatory argument, which is either a
+tarfile, or a string containing command for a pipe creation.
+
+ my $diff1 = Debian::Pkg::Diff->new("foo-0.1.diff");
+ my $diff2 = Debian::Pkg::Diff->new("foo-0.1.diff.gz");
+ my $diff3 = Debian::Pkg::Diff->new("gzip -dc foo-0.1.diff.gz |");
+
+The last two are strictly equivalent, since this package does not know
+how to handle compressed files, they are gunzipped on the fly if they
+have a F<.gz> extension.
+
+Options can be passed in the form of a hash array; these options are
+currently supported:
+
+=over 6
+
+=item C<debug>
+
+Set to 1 if you want to see lots of garbage on screen
+
+=item C<parse_dft>
+
+This option sets default argument if C<parse> method is called without
+argument.
+
+=item C<maxmem>
+
+Sets maximum amount of memory used to store file content.  Scanning is
+aborted and an error is reported when this amount is exceeded.
+
+=item Path specifications
+
+A patch file typically contains line like these ones:
+
+  --- foo-0.4.orig/Makefile
+  +++ foo-0.4/Makefile
+
+  --- foo-0.4/Makefile
+  +++ foo-0.4.new/Makefile
+
+  --- foo-0.4/Makefile.orig
+  +++ foo-0.4/Makefile
+
+So a general representation for all such cases is
+
+  --- <odp>foo-0.4<ods>/Makefile<ofs>
+  +++ <ndp>foo-0.4<nds>/Makefile<nfs>
+
+Six other arguments of the C<new> method can be specified, namely
+C<olddirprefix>, C<olddirsuffix>, C<oldfilesuffix>, C<newdirprefix>,
+C<newdirsuffix> and C<newfilesuffix>, to treat all cases above.
+
+=back
+
+Example:
+
+ my $diff2 = Debian::Pkg::Diff->new("foo-0.1.diff.gz",
+        olddirsuffix => '.orig',
+        parse_dft    => -1,
+ );
+
+=cut
+
+sub new {
+        my $proto = shift;
+        my $class = ref($proto) || $proto;
+        my $file  = shift ||
+                Carp::croak "Missing argument in ".__PACKAGE__."::new";
+
+        my $fh = Symbol::gensym();
+        my $self = {
+                name    => $file,
+                handle  => $fh,
+                cached  => 0,
+                offset  => 0,
+                memory  => 0,
+                maxcache        => 0,
+                curr_line       => '',
+                data    => {
+                        list_files      => [],
+                        list_new_files  => [],
+                        files           => {},
+                        new_files       => {},
+                },
+                #   these options can be overriden by caller
+                _parse_dft      => 0,
+                _debug  => 0,
+                _maxmem => 0,
+                _olddirprefix   => '',
+                _olddirsuffix   => '',
+                _oldfilesuffix  => '',
+                _newdirprefix   => '',
+                _newdirsuffix   => '',
+                _newfilesuffix  => '',
+        };
+
+        if ($#_ >= 0) {
+                my %opts = @_;
+                while (my ($key, $val) = each %opts) {
+                        $self->{"_".$key} = $val;
+                }
+        }
+        #   Special characters in these variables must be escaped
+        $self->{_olddirprefix}  = quotemeta($self->{_olddirprefix});
+        $self->{_olddirsuffix}  = quotemeta($self->{_olddirsuffix});
+        $self->{_oldfilesuffix} = quotemeta($self->{_oldfilesuffix});
+        $self->{_newdirprefix}  = quotemeta($self->{_newdirprefix});
+        $self->{_newdirsuffix}  = quotemeta($self->{_newdirsuffix});
+        $self->{_newfilesuffix} = quotemeta($self->{_newfilesuffix});
+
+        bless ($self, $class);
+        return $self;
+}
+
+sub _debug {
+        my $self = shift;
+        print STDERR __PACKAGE__." Debug: ".$_[0] . "\n"
+                if $self->{_debug};
+}
+
+sub _io_open {
+        my $self = shift;
+        if ($self->{name} =~ m/\.gz$/) {
+                open ($self->{handle}, "gzip -dc $self->{name} |")
+                        or Carp::croak "Unable to open $self->{name}";
+        } elsif ($self->{name} =~ m/\.bz2$/) {
+                open ($self->{handle}, "bzip2 -dc $self->{name} |")
+                        or Carp::croak "Unable to open $self->{name}";
+        } elsif ($self->{name} =~ m/\|/) {
+                open ($self->{handle}, $self->{name})
+                        or Carp::croak "Unable to execute \`$self->{name}'";
+        } elsif (-f $self->{name}) {
+                open ($self->{handle}, $self->{name})
+                        or Carp::croak "Unable to open \`$self->{name}'";
+        } else {
+                Carp::croak "Do not know what to do with this argument: $self->{name}";
+        }
+
+        $self->{offset} = 0;
+}
+
+sub _io_close {
+        close($_[0]->{handle});
+}
+
+sub _io_read_lines {
+        my $self = shift;
+        my $nlines = shift;
+        my $getData = shift || 0;
+
+        $self->_debug("Reading $nlines lines");
+        return '' if $nlines <= 0;
+
+        my $fh = $self->{handle};
+        my $text = '';
+        while ($nlines) {
+                $text .= $self->{curr_line} if $getData;
+                $self->{offset} += length($self->{curr_line});
+                $self->{curr_line} = <$fh>;
+                last if !defined($self->{curr_line});
+                $nlines --;
+        }
+        return $text;
+}
+
+sub _io_read {
+        my $self = shift;
+        my $nbytes = shift;
+        my $getData = shift || 0;
+
+        return '' if $nbytes <= 0;
+
+        my $text = '';
+        my $fh = $self->{handle};
+        my ($nread, $buffer);
+
+        $self->_debug("Reading $nbytes bytes at offset $self->{offset}");
+
+        $self->{offset} += $nbytes;
+        while ($nbytes > 4096) {
+                $nbytes -= read($fh, $buffer, $nbytes) ||
+                        Carp::croak "End of file found when reading \`$self->{name}'";
+                $text .= $buffer if $getData;
+        }
+        if ($nbytes > 0) {
+                read($fh, $buffer, $nbytes) ||
+                        Carp::croak "End of file found when reading \`$self->{name}'";
+                $text .= $buffer if $getData;
+        }
+        return $text;
+}
+
+=item parse
+
+Parse patch and store informations in memory.  See the
+C<Debian::Pkg::Tar> documentation for a detailed description of this
+function, but note that in most cases, -1 is the argument to pass to it.
+
+=cut
+
+sub parse {
+        my $self  = shift;
+        my $matchfiles;
+        my $fh = $self->{handle};
+
+        $self->_debug("Begin parsing");
+        if ($#_ >= 0) {
+                $matchfiles = shift;
+        } else {
+                $matchfiles = $self->{_parse_dft} || sub { return 0; };
+        }
+
+        #   Transform argument when necessary
+        if (ref($matchfiles) ne 'CODE') {
+                Carp::confess "Invalid argument of ".__PACKAGE__."::parse"
+                        unless $matchfiles =~ m/^-?\d+$/;
+                eval "\$matchfiles = sub { return $matchfiles; }";
+        }
+
+        $self->{curr_line} = '';
+        if ($self->{cached}) {
+                $self->_parse_cache($matchfiles);
+        } else {
+                #   This patch was never read before
+                $self->_debug("First time parsing");
+                $self->_io_open();
+                #   Initialize $self->{curr_line}
+                $self->{curr_line} = <$fh>;
+                1 while ($self->_read_firsttime($matchfiles));
+                $self->_io_close();
+        }
+        $self->{cached} = 1;
+        $self->_debug("End parsing");
+}
+
+sub _read_firsttime {
+        my $self  = shift;
+        my $matchfiles = shift;
+
+        return 0 if !defined($self->{curr_line});
+        my $name = $self->_read_header() or return 0;
+        my $maxlength = &$matchfiles($name);
+        $self->_read_patches($name, $maxlength);
+
+        #  This entry is not the last one
+        return 1;
+}
+
+sub _read_header {
+        my $self = shift;
+        my ($dir, $file);
+
+        #  Read header
+        Carp::croak "Malformed diff: line does not begin with ---:\n$self->{curr_line}\n"
+                unless $self->{curr_line} =~ m|^--- ([^/]+)$self->{_olddirsuffix}/(\S+)$self->{_oldfilesuffix}|;
+        ($dir, $file) = ($1, $2);
+        my $fh = $self->{handle};
+        $self->{offset} += length($self->{curr_line});
+        $self->{curr_line} = <$fh>;
+        Carp::croak "Malformed diff: found\n$self->{curr_line}when expecting\n+++ $self->{_newdirprefix}$dir$self->{_newdirsuffix}/$file$self->{_newfilesuffix}"
+                unless $self->{curr_line} =~ m#^\+\+\+ $self->{_newdirprefix}\Q$dir\E$self->{_newdirsuffix}/\Q$file\E$self->{_newfilesuffix}(\b|$)#;
+        $self->{offset} += length($self->{curr_line});
+        $self->{curr_line} = <$fh>;
+
+        return $file;
+}
+
+sub _read_patches {
+        my $self = shift;
+        my $name = shift;
+        my $nbytes = shift;
+
+        my $text = '';
+        my @patch_list = ();
+        my ($offset, $nlines, $chars, $dchars, $entry);
+
+        $nlines = 0;
+        $dchars = 0;
+        $offset = $self->{offset};
+        while (1) {
+                ($entry, $chars) = $self->_read_chunk();
+                last unless ref($entry) eq 'HASH';
+                $text   .= $entry->{data} if $nbytes != 0;
+                $nlines += $entry->{nlines};
+                $dchars += $chars;
+                push (@patch_list, $entry);
+                last if !defined($self->{curr_line})
+                        or $self->{curr_line} =~ m/^--- /;
+        }
+
+        if ($nbytes > 0 && $nbytes < length($text)) {
+                substr($text, $nbytes) = '';
+        }
+
+        # Store information
+        push(@{$self->{data}->{list_files}}, $name)
+                unless $self->{cached};
+        $self->{data}->{files}->{$name} = {
+                offset => $offset,
+                size   => $self->{offset} - $offset,
+                data   => $text,
+                read   => length($text),
+                dchars => $dchars,
+                patch_list      => \@patch_list,
+        };
+        if ($self->{data}->{files}->{$name}->{patch_list}->[0]->{oldfirstline} eq 0
+           && !$self->{cached}) {
+                push(@{$self->{data}->{list_new_files}}, $name);
+                $self->{data}->{new_files}->{$name} = 1;
+        }
+        $self->_debug("   Name   : ".$name);
+        $self->_debug("   Type   : file");
+        $self->_debug("   Size   : ".($self->{offset} - $offset));
+        $self->_debug("   Read   : ".length($text));
+        $self->_debug("   Offset : $offset");
+}
+
+sub _read_chunk {
+        my $self = shift;
+
+        my ($nread, $buffer, $size, $line, %entry);
+        my ($nlines, $nlinesold, $nlinesnew, $nchars);
+
+        $line = $self->{curr_line};
+        chomp $line;
+        $self->_debug("Chunk found: ".$line);
+
+        if ($line =~ m/^\@\@ -(\d+)(?:,(\d+))? \+(\d+)(?:,(\d+))? \@\@/) {
+                %entry = (
+                        oldfirstline    => $1,
+                        oldnblines      => (defined($2) ? $2 : 1),
+                        newfirstline    => $3,
+                        newnblines      => (defined($4) ? $4 : 1),
+                );
+        } else {
+                Carp::croak "Malformed patch, first line is:\n$self->{curr_line}"
+        }
+        my $text = '';
+        $nlines    = 0;
+        $nlinesold = 0;
+        $nlinesnew = 0;
+        $nchars    = 0;
+        while ($nlinesold != $entry{oldnblines}
+            || $nlinesnew != $entry{newnblines}) {
+                $self->_io_read_lines(1, 1);
+                if (defined($self->{curr_line})
+                    && $self->{curr_line} eq "\\ No newline at end of file\n") {
+                        $self->{curr_line} = '';
+                        next;
+                }
+                last if !defined($self->{curr_line})
+                        or $self->{curr_line} =~ m/^\@\@ /;
+                $text .= $self->{curr_line};
+                if ($self->{curr_line} =~ m/^-/) {
+                        $nlinesold ++;
+                        $nchars -= length($self->{curr_line}) - 1;
+                } elsif ($self->{curr_line} =~ m/^\+/) {
+                        $nlinesnew ++;
+                        $nchars += length($self->{curr_line}) - 1;
+                } else {
+                        $nlinesold ++;
+                        $nlinesnew ++;
+                }
+                $nlines ++;
+        };
+        $self->_io_read_lines(1, 1)
+                if defined($self->{curr_line})
+                   && $self->{curr_line} !~ m/^\@\@ /;
+        $self->_io_read_lines(1, 1)
+                if defined($self->{curr_line})
+                   && $self->{curr_line} eq "\\ No newline at end of file\n";
+
+        $entry{data}   = $text;
+        $entry{nlines} = $nlines;
+        return (\%entry, $nchars);
+}
+
+sub _parse_cache {
+        my $self  = shift;
+        my $matchfiles = shift;
+
+        my ($name, $offset, $numbytes, $maxlength, $block);
+        my ($filesize, $fileoffset);
+
+        $self->_debug("Checking in memory representation");
+
+        $self->{offset} = 0;
+        foreach $name (@{$self->{data}->{list_files}}) {
+                $maxlength = &$matchfiles($name);
+                next
+                        if $maxlength == 0;
+
+                #  Look if result is cached
+                $fileoffset = $self->{data}->{files}->{$name}->{offset};
+                $filesize   = $self->{data}->{files}->{$name}->{size};
+                $maxlength  = $filesize
+                        if $maxlength == -1 || $maxlength > $filesize;
+                next
+                        if $self->{data}->{files}->{$name}->{read} >= $maxlength;
+
+                $numbytes  = ($filesize > $maxlength ? $maxlength : $filesize);
+
+                #  Abort if memory needed is too large
+                $self->{memory} += $numbytes - $self->{data}->{files}->{$name}->{read};
+                if ($self->{_maxmem} > 0) {
+                        Carp::croak "Not enough memory: maximum set to $self->{_maxmem}, and at least $self->{memory} needed"
+                                if $self->{memory} > $self->{_maxmem};
+                }
+
+                #  Open filehandle if it has not been done before
+                $self->_io_open() unless $self->{offset} > 0;
+
+                $self->_debug("Found $name at offset $fileoffset");
+
+                $self->_io_read($fileoffset - $self->{offset});
+                $self->{offset} = $fileoffset;
+
+                #  Read next line to initialize $self->{curr_line}
+                $self->{curr_line} = '';
+                $self->_io_read_lines(1);
+
+                $self->_read_patches($name, $numbytes);
+                $self->{offset} += length($self->{curr_line})
+                        if defined($self->{curr_line});
+        }
+        $self->_io_close() if $self->{offset} > 0;
+}
+
+=item list_files
+
+Return the list of files patched.
+
+ my @listfiles = $diff1->list_files();
+
+=cut
+
+sub list_files {
+        my $self = shift;
+        $self->parse()
+                unless $self->{cached};
+        return @{$self->{data}->{list_files}};
+}
+
+=item list_new_files
+
+Return the list of files which are added by this patch.
+
+ my @newfiles = $diff1->list_new_files();
+
+=cut
+
+sub list_new_files {
+        my $self = shift;
+        $self->parse()
+                unless $self->{cached};
+        return @{$self->{data}->{list_new_files}};
+}
+
+=item is_file_patched
+
+Return 1 if argument is a file found in patch and 0 otherwise.
+
+ if ($diff1->is_file_patched("configure.in")) {
+      print "File configure.in found in patch\n";
+ }
+
+=cut
+
+sub is_file_patched {
+        my $self = shift;
+        $self->parse()
+                unless $self->{cached};
+        return defined($self->{data}->{files}->{$_[0]}) ? 1 : 0;
+}
+
+=item patch_file_matches
+
+Return the list of files being patched and matching argument, which is a
+Perl regular expression.
+
+ my @c = $self->patch_file_matches("^c");
+
+=cut
+
+sub patch_file_matches {
+        my $self = shift;
+        my $expr = shift;
+        my @found = ();
+        my $match = sub { my $file = shift; $file =~ m/$expr/; };
+        foreach ($self->list_files()) {
+                push (@found, $_) if &$match($_);
+        }
+        return @found;
+}
+
+=item apply_patch
+
+Given a text, returns patched version against given file.
+
+ $patched = $diff1->apply_patch("src/main.c", $text);
+
+=cut
+
+sub apply_patch {
+        my $self = shift;
+        my $name = shift;
+        my $text = shift || '';
+
+        $self->_debug("Applying patch to file $name");
+        my $match = sub { my $file = shift; $file eq $name && return -1; };
+        $self->parse($match)
+                unless $self->{cached}
+                    || $self->{data}->{files}->{read} == $self->{data}->{files}->{size};
+        if (!defined($self->{data}->{files}->{$name})) {
+                Carp::carp "File $name does not appear in patch";
+                return $text;
+        }
+        if ($self->{data}->{files}->{$name}->{patch_list}->[0]->{oldfirstline} == 0) {
+                #   Special case, this is a new file
+                Carp::carp "In ".__PACKAGE__."::apply_patch, patch new file with non-empty text"
+                        if $text ne '';
+                $text = $self->{data}->{files}->{$name}->{patch_list}->[0]->{data};
+                $text =~ s/^\+//mg;
+                return $text;
+        } else {
+                #   3rd argument is to prevent stripping of trailing
+                #   newlines
+                my @out = split(/\n/, $text, -1);
+                pop(@out) if $text =~ m/\n$/s;
+                foreach my $p (@{$self->{data}->{files}->{$name}->{patch_list}}) {
+                        my @patch = split(/\n/, $p->{data}, -1);
+                        pop(@patch) if $p->{data} =~ m/\n$/s;
+                        my @new = ();
+                        my $begin = $p->{newfirstline} - 1;
+                        my $length = $p->{oldnblines};
+                        my $old = $begin - 1;
+                        foreach (@patch) {
+                                if (s/^ //) {
+                                        $old ++;
+                                        Carp::carp __PACKAGE__."::apply_patch invoked on non-matching text on file $name near line $old\n"
+                                                unless defined($out[$old]) && $_ eq $out[$old];
+                                        push @new, $_;
+                                } elsif (s/^-//) {
+                                        $old ++;
+                                        Carp::carp __PACKAGE__."::apply_patch invoked on non-matching text on file $name near line $old\n"
+                                                unless defined($out[$old]) && $_ eq $out[$old];
+                                } elsif (s/^\+//) {
+                                        push @new, $_;
+                                } else {
+                                        Carp::carp __PACKAGE__."::apply_patch invoked on non-matching text on file $name near line $old\n";
+                                }
+                        }
+                        splice @out, $begin, $length, @new;
+                }
+                $text = join("\n", @out)."\n";
+        }
+        return $text;
+}
+
+=item get_memory
+
+Get number of characters currently stored in cache
+
+ print "Memory used: ".$diff1->get_memory()."\n";
+
+=cut
+
+sub get_memory {
+        return $_[0]->{memory};
+}
+
+=item get_max_memory
+
+Get maximum number of characters stored in this object during its timelife
+
+ print "Max memory used: ".$diff1->get_max_memory()."\n";
+
+=cut
+
+sub get_max_memory {
+        my $self = shift;
+        $self->{maxcache} = $self->{memory} if $self->{maxcache} < $self->{memory};
+        return $self->{maxcache};
+}
+
+=item free
+
+Free memory by removing all previous remembered data.
+
+ $diff1->free();
+
+=cut
+
+sub free {
+        my $self = shift;
+        return unless $self->{cached};
+
+        $self->{maxcache} = $self->{memory}
+                if $self->{maxcache} < $self->{memory};
+        $self->_debug("Free memory");
+        foreach (@{$self->{data}->{list_files}}) {
+                $self->{data}->{files}->{$_}->{read} = 0;
+                $self->{data}->{files}->{$_}->{data} = '';
+        }
+        $self->{memory} = 0;
+}
+
+=back
+
+=head1 AUTHOR
+
+Copyright (C) 2001  Denis Barbier <barbier@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.
+
+=cut
+
+1;
+
diff --git a/Perl/Debian/Pkg/Tar.pm b/Perl/Debian/Pkg/Tar.pm
new file mode 100644
index 00000000000..9e8dadf837d
--- /dev/null
+++ b/Perl/Debian/Pkg/Tar.pm
@@ -0,0 +1,825 @@
+#!/usr/bin/perl -w
+
+##  Copyright (C) 2001  Denis Barbier <barbier@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.
+
+=head1 NAME
+
+Debian::Pkg::Tar - examine tarfile contents
+
+=head1 DESCRIPTION
+
+This package is the base class for all C<Debian::Pkg> classes.
+Unlike most tar processors, this one does perform all operations in
+memory, but retrieves only specified files, so it should not consume too
+much memory if you are specific enough.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+package Debian::Pkg::Tar;
+use strict;
+use Carp;
+use Symbol;
+use File::Path;
+use File::Basename;
+use Debian::Pkg::Diff;
+
+=item new
+
+This is the constructor. It has a mandatory argument, which is either a
+tarfile, or a string containing command for a pipe creation.
+
+ my $tar1 = Debian::Pkg::Tar->new("foo-0.1.tar");
+ my $tar2 = Debian::Pkg::Tar->new("foo-0.1.tar.gz");
+ my $tar3 = Debian::Pkg::Tar->new("gzip -dc foo-0.1.tar.gz |");
+
+The last two are strictly equivalent, since this package does not know
+how to handle compressed files, they are gunzipped on the fly if they
+have a F<.gz> extension.
+
+Options can be passed in the form of a hash array; these options are
+currently supported:
+
+=over 6
+
+=item C<debug>
+
+Set to 1 if you want to see lots of garbage on screen
+
+=item C<parse_dft>
+
+This option sets default argument if C<parse> method is called without
+argument.
+
+=item C<maxmem>
+
+Sets maximum amount of memory used to store file content.  Scanning is
+aborted and an error is reported when this amount is exceeded.
+
+=back
+
+Example:
+
+ my $tar2 = Debian::Pkg::Tar->new("foo-0.1.tar.gz",
+        debug => 1,
+        parse_dft => 32,
+ );
+
+=cut
+
+sub new {
+        my $proto = shift;
+        my $class = ref($proto) || $proto;
+        my $file  = shift ||
+                Carp::croak "Missing argument in ".__PACKAGE__."::new";
+
+        my $fh = Symbol::gensym();
+        my $self = {
+                name    => $file,
+                handle  => $fh,
+                dir     => "",
+                wrongdir=> 0,
+                cached  => 0,
+                offset  => 0,
+                memory  => 0,
+                maxcache        => 0,
+                patch   => undef,
+                data    => {
+                        list_files      => [],
+                        list_dirs       => [],
+                        files           => {},
+                        dirs            => {},
+                },
+                parse_last      => 0,
+                #   these options can be overriden by caller
+                _parse_dft      => 0,
+                _debug  => 0,
+                _maxmem => 0,
+        };
+
+        if ($#_ >= 0) {
+                my %opts = @_;
+                while (my ($key, $val) = each %opts) {
+                        $self->{"_".$key} = $val;
+                }
+        }
+        bless ($self, $class);
+        return $self;
+}
+
+sub _debug {
+        my $self = shift;
+        return unless $self->{_debug};
+        print STDERR __PACKAGE__." Debug: ".$_[0] . "\n";
+}
+
+sub _io_open {
+        my $self = shift;
+        if ($self->{name} =~ m/\.gz$/) {
+                open ($self->{handle}, "gzip -dc $self->{name} |")
+                        or Carp::croak "Unable to open $self->{name}";
+        } elsif ($self->{name} =~ m/\.bz2$/) {
+                open ($self->{handle}, "bzip2 -dc $self->{name} |")
+                        or Carp::croak "Unable to open $self->{name}";
+        } elsif ($self->{name} =~ m/\|/) {
+                open ($self->{handle}, $self->{name})
+                        or Carp::croak "Unable to execute \`$self->{name}'";
+        } elsif (-f $self->{name}) {
+                open ($self->{handle}, $self->{name})
+                        or Carp::croak "Unable to open \`$self->{name}'";
+        } else {
+                Carp::croak "Do not know what to do with this argument: $self->{name}";
+        }
+
+        $self->{offset} = 0;
+}
+
+sub _io_close {
+        my $self = shift;
+
+        close($self->{handle});
+        $self->{offset} = -1;
+}
+
+sub _io_read {
+        my $self = shift;
+        my $nbytes = shift;
+        my $getData = shift || 0;
+
+        return '' if $nbytes <= 0;
+
+        my $text = '';
+        my ($nread, $buffer);
+
+        $self->_debug("Reading $nbytes bytes at offset $self->{offset}");
+
+        $self->{offset} += $nbytes;
+        while ($nbytes > 4096) {
+                $nbytes -= read($self->{handle}, $buffer, $nbytes) ||
+                        Carp::croak "End of file found when reading \`$self->{name}'";
+                $text .= $buffer if $getData;
+        }
+        if ($nbytes > 0) {
+                read($self->{handle}, $buffer, $nbytes) ||
+                        Carp::croak "End of file found when reading \`$self->{name}'";
+                $text .= $buffer if $getData;
+        }
+        return $text;
+}
+
+=item parse
+
+This is where all processing is done.  It has an optional argument, which is
+either a subroutine reference or a number.
+
+For each file found in archive, this routine will be called with filename
+given as attribute, and it returns either a number or a string beginning
+with a colon.  All other return values are discarded and treated as 0.
+The former gives the number of bytes of file content stored in internal
+cache (see below the C<file_content> method), and the latter specifies a
+path where content is stored.
+
+Example:
+
+ my $match = sub {
+      my $file = shift;
+      if ($file =~ m|po/.*\.po$|) {
+           $file =~ s|/|_|g;
+           return ':po-files/'.$file;
+      }
+      $file =~ m|\.c$| && return 32;
+      return 0;
+ };
+ $tar1->parse($match);
+
+This example writes on disk all files matching the Perl regular
+expression C<po/.*\.po$>, and reads in memory all C source files, but
+truncate them to 32 chars.  When file content is retrieved via the
+C<file_content> method, it will be immediately available if less than 32
+chars are requested.  Otherwise, archive will be parsed again to
+retrieve the desired amount of chars of the specified file.
+
+When C<parse> method's argument is a number, this is a shortcut to
+truncate and store all files to the desired length.  There are two
+special cases: if this argument is missing or is null, then archive is
+scanned and structure is stored, but file contents are not retrieved.
+If this argument is -1,  then files contents are kept in memory.  Of
+course, this option should not be used on large tarballs.
+
+When C<parse> method is called the first time, an internal representation of
+tarfile is stored to let further parsing faster, and tarfile will be read only
+if result has not been cached by previous calls.
+
+=cut
+
+sub parse {
+        my $self  = shift;
+        my $matchfiles;
+
+        $self->_debug("Begin parsing");
+        if ($#_ >= 0) {
+                $matchfiles = shift;
+        } else {
+                $matchfiles = $self->{_parse_dft} || sub { return 0; };
+        }
+
+        #   Transform argument if necessary
+        if (ref($matchfiles) ne 'CODE') {
+                Carp::confess "Invalid argument of ".__PACKAGE__."::parse"
+                        unless $matchfiles =~ m/^-?\d+$/;
+                eval "\$matchfiles = sub { return $matchfiles; }";
+        }
+        $self->{parse_last} = $matchfiles;
+
+        if ($self->{cached}) {
+                $self->_parse_cache($matchfiles);
+        } else {
+                #   This tarball was never read before
+                $self->_debug("First time parsing");
+                $self->_io_open();
+                1 while ($self->_read_firsttime($matchfiles));
+                $self->_io_close();
+        }
+        $self->{cached} = 1;
+        $self->_debug("End parsing");
+        $self->_debug("Number of chars in cache: ".$self->get_max_memory());
+}
+
+sub _read_firsttime {
+        my $self  = shift;
+        my $matchfiles = shift;
+
+        my ($block, $data, $maxlength, $numbytes, $offset);
+
+        my ($name, $type, $size) = $self->_read_header(0) or return 0;
+        my $path = '';
+
+        $offset = $self->{offset};
+        if ($type eq "file") {
+                $maxlength = &$matchfiles($name) || 0;
+                if ($maxlength =~ s/^://) {
+                        $path = $maxlength;
+                        $maxlength = -1;
+                } elsif ($maxlength !~ m/^-?[0-9]+$/) {
+                        $maxlength = 0;
+                }
+                $maxlength = $size if $maxlength == -1;
+                $numbytes  = ($size > $maxlength ? $maxlength : $size);
+                $self->{memory} += $numbytes if $path eq '';
+                #  Abort if memory needed is too large
+                if ($self->{_maxmem} > 0) {
+                        Carp::croak "Not enough memory: maximum set to $self->{_maxmem}, and at least $self->{memory} needed"
+                                if $self->{memory} > $self->{_maxmem};
+                }
+
+                $data = $self->_io_read($numbytes, 1);
+
+                # Always read in full 512 byte blocks
+                $block = ($size & 0x01ff) ? ($size & ~0x01ff) + 512 : $size;
+                $self->_io_read($block - $numbytes) if $numbytes < $block;
+
+                # Store information
+                push(@{$self->{data}->{list_files}}, $name);
+                if ($path ne '') {
+                        my $dir = File::Basename::dirname($path);
+                        File::Path::mkpath($dir, 0, 0755);
+                        open(DISK, "> ".$path)
+                                || warn "Unable to write to $path\n";
+                        print DISK $data;
+                        close(DISK);
+                        $data = '';
+                }
+                $self->{data}->{files}->{$name} = {
+                        offset => $offset,
+                        size   => $size,
+                        data   => $data,
+                        read   => $numbytes,
+                        path   => $path,
+                        dchars => 0,
+                        patch  => 0,
+                };
+                $self->_debug("   Type   : file");
+                $self->_debug("   Size   : $size");
+                $self->_debug("   Offset : $offset");
+                $self->_debug("   Path   : $path") if $path ne '';
+        } elsif ($type eq "dir") {
+                $name =~ s|/$||;
+                push (@{$self->{data}->{list_dirs}}, $name);
+                $self->{data}->{dirs}->{$name} = 1;
+                $self->_debug("   Type   : directory");
+                $self->_debug("   Offset : $offset");
+        } else {
+                $self->_debug("   Type   : unknown ($type)");
+        }
+
+        #  This entry is not the last one
+        return 1;
+}
+
+sub _read_header {
+        my $self  = shift;
+        my $cont  = shift;   #  1 when reading long filenames, 0 otherwise
+
+        #  Read header
+        my $head = $self->_io_read(512, 1) ||
+                Carp::croak "End of file found when reading \`$self->{name}'";
+        if ($head eq "\0" x 512) {
+                $self->_debug("EOF detected");
+                return;
+        }
+
+        #  Unpack it
+        my ($name, $mode, $uid, $gid, $size, $mtime, $chksum, $type,
+            $linkname, $magic, $version, $uname, $gname, $devmajor,
+            $devminor, $prefix) =
+            unpack ("A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12", $head);
+
+        if ($name eq '') {
+                $self->_debug("Missing filename, assuming it is EOF");
+                return;
+        }
+
+        $size   = oct $size;
+        $chksum = oct $chksum;
+
+        #   Calculate checksum
+        substr ($head, 148, 8) = "        ";
+        Carp::carp "$name: checksum error.\n"
+                if unpack ("%16C*", $head) != $chksum;
+
+        #   Handle long filename (>100 chars)
+        if ($prefix ne "") {
+                #  POSIX way
+                $name = $prefix."/".$name;
+        } elsif ($name eq "././\@LongLink" && $type eq "L") {
+                #  GNU way
+                my $realname = $self->_io_read($size, 1) ||
+                        Carp::croak "End of file found when reading \`$self->{name}'";
+                $self->_io_read(($size & ~0x01ff) + 512 - $size)
+                        if ($size & 0x01ff);
+                ($name, $type, $size) = $self->_read_header(1) or return 0;
+                $name = $realname;
+        }
+
+        $self->_debug("Found $name");
+
+        $type = "file" if $type eq "";
+        if ($type =~ m/^\d/) {
+                if ($type == 0) {
+                        $type = "file";
+                } elsif ($type == 5) {
+                        $type = "dir";
+                } else {
+                        $type = "unknozn";
+                }
+        }
+        $name .= '/' if $type eq 'dir' && $name !~ m#/#;
+
+        if ($name =~ s|^([^/]+)/||) {
+                if ($self->{wrongdir} == 0) {
+                        if ($self->{dir} ne "" && $self->{dir} ne $1) {
+                                $name = $1 . '/' . $name;
+                                $self->{wrongdir} = 1;
+                                warn "Warning: unable to determine top-level directory in $self->{name}, assuming there is no root directory\n";
+                                #   Adapt already scanned files and
+                                #   directories
+                                $self->_prepend_dir($self->{dir});
+                                $self->{dir} = '';
+                        } else {
+                                $self->{dir} = $1;
+                        }
+                } else {
+                        $name = $1 . '/' . $name;
+                }
+        } else {
+                if ($self->{wrongdir} == 0) {
+                        $self->{wrongdir} = 1;
+                        warn "Warning: unable to determine top-level directory in $self->{name}, assuming there is no root directory\n";
+                        $self->_prepend_dir($self->{dir}) if $self->{dir} ne '';
+                }
+        }
+
+        #   Fix broken archives
+        $type = "dir"  if $name =~ m|/$| and $type eq "file" and !$cont;
+
+        return ($name, $type, $size);
+}
+
+sub _prepend_dir {
+        my $self  = shift;
+        my $dir = shift;
+
+        foreach (keys %{$self->{data}->{files}}) {
+                $self->{data}->{files}->{$dir.'/'.$_} =
+                        $self->{data}->{files}->{$_};
+                delete $self->{data}->{files}->{$_};
+        }
+        foreach (keys %{$self->{data}->{dirs}}) {
+                $self->{data}->{dirs}->{$dir.'/'.$_} =
+                        $self->{data}->{dirs}->{$_};
+                delete $self->{data}->{dirs}->{$_};
+        }
+        my @list_files = ();
+        foreach (@{$self->{data}->{list_files}}) {
+                push(@list_files, $dir.'/'.$_);
+        }
+        $self->{data}->{list_files} = [@list_files];
+        my @list_dirs = ();
+        foreach (@{$self->{data}->{list_dirs}}) {
+                push(@list_dirs, $dir.'/'.$_);
+        }
+        $self->{data}->{list_dirs} = [@list_dirs];
+}
+
+sub _parse_cache {
+        my $self  = shift;
+        my $matchfiles = shift;
+
+        my ($name, $offset, $numbytes, $maxlength, $block, $path);
+        my ($filesize, $fileoffset, $text);
+
+        $self->_debug("Checking in memory representation");
+
+        $self->_io_open();
+        foreach $name (@{$self->{data}->{list_files}}) {
+                $maxlength = &$matchfiles($name) || 0;
+                $path = '';
+                if ($maxlength =~ s/^://) {
+                        $path = $maxlength;
+                        $fileoffset = $self->{data}->{files}->{$name}->{offset};
+                        $filesize   = $self->{data}->{files}->{$name}->{size};
+                        $maxlength  = $filesize;
+                        unless (-r $path) {
+                                $maxlength  = $filesize;
+                                if ($self->{data}->{files}->{$name}->{patch}
+                                    || $self->{data}->{files}->{$name}->{read} < $maxlength) {
+                                        $self->_io_read($fileoffset - $self->{offset});
+                                        $text = $self->_io_read($maxlength, 1);
+                                        $self->{offset} = $fileoffset + $maxlength;
+                                } else {
+                                        $text = $self->{data}->{files}->{$name}->{data};
+                                }
+                                $self->{data}->{files}->{$name}->{patch} = 1
+                                        if defined $self->{patch}
+                                        && $self->{patch}->{data}->{files}->{$name};
+                                $text = $self->{patch}->apply_patch($name, $text)
+                                        if $self->{data}->{files}->{$name}->{patch};
+                                my $dir = File::Basename::dirname($path);
+                                File::Path::mkpath($dir, 0, 0755);
+                                open(DISK, "> ".$path)
+                                        || warn "Unable to write to $path\n";
+                                print DISK $text;
+                                close(DISK);
+                                $self->{data}->{files}->{$name}->{data} = '';
+                                $self->{data}->{files}->{$name}->{read} = 0;
+                        }
+                        next;
+                } elsif ($maxlength !~ m/^-?[0-9]+$/) {
+                        $maxlength = 0;
+                }
+                next unless $maxlength == -1 || $maxlength =~ m/^[0-9]+$/;
+
+                #  Look if result is cached
+                $fileoffset = $self->{data}->{files}->{$name}->{offset};
+                $filesize   = $self->{data}->{files}->{$name}->{size};
+                $maxlength  = $filesize
+                        if $maxlength == -1 || $maxlength > $filesize;
+
+                #   File content is in cache
+                next if $self->{data}->{files}->{$name}->{read} >= $maxlength;
+
+                #   New file added by patch
+                next if $self->{data}->{files}->{$name}->{offset} == -1;
+
+                $numbytes  = ($filesize > $maxlength ? $maxlength : $filesize);
+
+                #  Abort if memory needed is too large
+                $self->{memory} += $numbytes - $self->{data}->{files}->{$name}->{read}
+                        if $path eq '';
+                if ($self->{_maxmem} > 0) {
+                        Carp::croak "Not enough memory: maximum set to $self->{_maxmem}, and at least $self->{memory} needed"
+                                if $self->{memory} > $self->{_maxmem};
+                }
+
+                $self->_debug("Found $name at offset $fileoffset");
+
+                $self->_io_read($fileoffset - $self->{offset});
+                $self->{offset} = $fileoffset;
+                $self->{data}->{files}->{$name}->{data} =
+                                $self->_io_read($numbytes, $maxlength);
+                $self->{data}->{files}->{$name}->{read}  = $numbytes;
+                $self->{data}->{files}->{$name}->{patch} = 1
+                        if defined $self->{patch}
+                           && $self->{patch}->{data}->{files}->{$name};
+        }
+        $self->_io_close();
+}
+
+=item list_dirs
+
+Return the list of directories.
+
+ my @listdirs  = $tar1->list_dirs();
+
+=cut
+
+sub list_dirs {
+        my $self = shift;
+        $self->parse()
+                unless $self->{cached};
+        return @{$self->{data}->{list_dirs}};
+}
+
+=item list_files
+
+Return the list of files.
+
+ my @listfiles = $tar1->list_files();
+
+=cut
+
+sub list_files {
+        my $self = shift;
+        $self->parse()
+                unless $self->{cached};
+        return @{$self->{data}->{list_files}};
+}
+
+=item file_exists
+
+Return 1 if argument is a file found in package, 0 otherwise.
+
+ if ($tar1->file_exists("debian/template")) {
+      print "Hey, this package uses Debconf!\n";
+ }
+
+=cut
+
+sub file_exists {
+        my $self = shift;
+        $self->parse()
+                unless $self->{cached};
+        return defined($self->{data}->{files}->{$_[0]}) ? 1 : 0;
+}
+
+=item file_matches
+
+Return the list of files matching argument, which is a Perl regular
+expression.
+
+ my @c = $self->file_matches("^c");
+
+=cut
+
+sub file_matches {
+        my $self = shift;
+        my $expr = shift;
+        my @found = ();
+        my $match = sub { my $file = shift; $file =~ m/$expr/; };
+        foreach ($self->list_files()) {
+                push (@found, $_) if &$match($_);
+        }
+        return @found;
+}
+
+=item file_content
+
+Return the content of a file if it resides in archive.
+
+ my $control = $self->file_content("debian/control");
+
+An optional second argument is the number of bytes to read.
+
+=cut
+
+sub file_content {
+        my $self = shift;
+        my $file = shift;
+        my $length = shift || -1;
+
+        $self->_debug("Retrieve content of file $file");
+        unless ($self->file_exists($file)) {
+                Carp::carp "File \`$file' not found in archive";
+                return;
+        }
+
+        return $self->_file_content_patch($file, $length)
+                if defined $self->{patch}
+                   && $self->{patch}->{data}->{files}->{$file};
+
+        if ($self->{data}->{files}->{$file}->{path} ne '') {
+                local $/ = undef;
+                open(DISK, "< ".$self->{data}->{files}->{$file}->{path})
+                        || warn "Unable to read from ".
+                                $self->{data}->{files}->{$file}->{path}."\n";
+                my $text = <DISK>;
+                close(DISK);
+                return $text;
+        }
+
+        $length = $self->{data}->{files}->{$file}->{size}
+                if $length == -1
+                   || $length > $self->{data}->{files}->{$file}->{size};
+
+        return substr($self->{data}->{files}->{$file}->{data}, 0, $length)
+                if $self->{data}->{files}->{$file}->{read} >= $length;
+
+        $self->_io_open() unless $self->{offset} >= 0 && $self->{data}->{files}->{$file}->{offset} >= $self->{offset};
+        $self->_io_read($self->{data}->{files}->{$file}->{offset} - $self->{offset});
+        $self->_debug("Read $length bytes of $file");
+        $self->{data}->{files}->{$file}->{data} = $self->_io_read($length, 1);
+        return $self->{data}->{files}->{$file}->{data};
+}
+
+sub _file_content_patch {
+        my $self = shift;
+        my $file = shift;
+        my $length = shift || -1;
+        my ($text, $strlen);
+
+        $self->_debug("Retrieve content of file $file with patches applied");
+        unless ($self->file_exists($file)) {
+                Carp::carp "File \`$file' not found in archive";
+                return;
+        }
+
+        if ($self->{data}->{files}->{$file}->{path} ne '') {
+                local $/ = undef;
+                open(DISK, "< ".$self->{data}->{files}->{$file}->{path})
+                        || warn "Unable to read from ".
+                                $self->{data}->{files}->{$file}->{path}."\n";
+                $text = <DISK>;
+                close(DISK);
+                #   We read text, but do not know yet if it has to be
+                #   patched
+        }
+
+        if ($self->{data}->{files}->{$file}->{patch}) {
+                #   File already patched in cache
+
+                #   New file not in tarball
+                return $self->{patch}->apply_patch($file, $text)
+                        if $self->{data}->{files}->{$file}->{offset} == -1;
+
+                $length = $self->{data}->{files}->{$file}->{size} +
+                          $self->{data}->{files}->{$file}->{dchars}
+                        if $length == -1
+                           || $length > $self->{data}->{files}->{$file}->{size} +
+                                        $self->{data}->{files}->{$file}->{dchars};
+                return $text if $self->{data}->{files}->{$file}->{path} ne '';
+                return substr($self->{data}->{files}->{$file}->{data}, 0, $length)
+                        if $self->{data}->{files}->{$file}->{read} >= $length;
+        }
+
+        if ($self->{data}->{files}->{$file}->{path} ne '') {
+                #   Original file has been stored on disk, it must
+                #   be patched and overwritten
+                $text = $self->{patch}->apply_patch($file, $text);
+                open(DISK, "> ".$self->{data}->{files}->{$file}->{path})
+                        || warn "Unable to write to ".
+                                $self->{data}->{files}->{$file}->{path}."\n";
+                print DISK $text;
+                close(DISK);
+                $self->{data}->{files}->{$file}->{patch} = 1;
+                return $text;
+        }
+
+        #   Read the whole source file
+        $strlen = $self->{data}->{files}->{$file}->{size};
+        $self->_io_open() unless $self->{offset} >= 0 && $self->{data}->{files}->{$file}->{offset} >= $self->{offset};
+        $self->_io_read($self->{data}->{files}->{$file}->{offset} - $self->{offset});
+        $self->_debug("Read $strlen bytes of $file");
+        $text = $self->_io_read($strlen, 1);
+
+        $text = $self->{patch}->apply_patch($file, $text);
+        substr($text, $length) = ''
+                if length($text) > $length && $length != -1;
+        $self->{data}->{files}->{$file}->{data}  = $text;
+        $self->{data}->{files}->{$file}->{read}  = length($text);
+        $self->{data}->{files}->{$file}->{patch} = 1;
+        return $text;
+}
+
+=item bind_patch
+
+Bind current tarball to a patch, so that all files are retrieved
+as if patch was applied after extracting files from tarball.
+
+ $self->bind_patch("foo-0.1.diff.gz");
+ my $text = $self->file_content("debian/control");
+
+This routine accepts the same optional arguments as
+C<Debian::Pkg::Diff-E<gt>new>.
+
+=cut
+
+sub bind_patch {
+        my $self = shift;
+        my $file = shift;
+
+        Carp::croak "Another patch is already bound"
+                if defined $self->{patch};
+
+        $self->parse(0)
+                unless $self->{cached};
+
+        $self->_debug("Apply patch file $file");
+
+        my %opts = ();
+        %opts = @_ if $#_ >= 0;
+
+        $opts{parse_dft} ||= $self->{parse_last};
+        $self->{patch} = Debian::Pkg::Diff->new($file, %opts);
+        $self->{patch}->parse();
+
+        foreach ($self->{patch}->list_files()) {
+                $self->{data}->{files}->{$_}->{dchars} = $self->{patch}->{data}->{files}->{$_}->{dchars};
+        }
+        foreach ($self->{patch}->list_new_files()) {
+                $self->_debug("New file added to archive: $_");
+                my $data = $self->{patch}->{data}->{files}->{$_}->{data};
+                $data =~ s/^\+//mg;
+                $self->{data}->{files}->{$_} = {
+                        offset => -1,
+                        size   => 0,
+                        data   => $data,
+                        read   => length($data),
+                        path   => '',
+                        dchars => length($data),
+                        patch  => 1,
+                };
+                push (@{$self->{data}->{list_files}}, $_);
+        }
+}
+
+=item get_memory
+
+Get number of characters currently stored in cache.
+
+ print "Memory used: ".$tar1->get_memory()."\n";
+
+=cut
+
+sub get_memory {
+        return $_[0]->{memory};
+}
+
+=item get_max_memory
+
+Get maximum number of characters stored in this object during its timelife.
+
+ print "Max memory used: ".$tar1->get_max_memory()."\n";
+
+=cut
+
+sub get_max_memory {
+        my $self = shift;
+        $self->{maxcache} = $self->{memory} if $self->{maxcache} < $self->{memory};
+        return $self->{maxcache};
+}
+
+=item free
+
+Free memory by removing all previous remembered data.
+
+ $tar1->free();
+
+=cut
+
+sub free {
+        my $self = shift;
+        return unless $self->{cached};
+
+        $self->{maxcache} = $self->{memory}
+                if $self->{maxcache} < $self->{memory};
+        $self->_debug("Free memory");
+        foreach (@{$self->{data}->{list_files}}) {
+                $self->{data}->{files}->{$_}->{read} = 0;
+                $self->{data}->{files}->{$_}->{data} = '';
+        }
+        $self->{memory} = 0;
+}
+
+=back
+
+=head1 AUTHOR
+
+Copyright (C) 2001  Denis Barbier <barbier@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.
+
+=cut
+
+1;
+