diff options
author | Pierre Machard <pmachard> | 2004-07-18 23:04:45 +0000 |
---|---|---|
committer | Pierre Machard <pmachard> | 2004-07-18 23:04:45 +0000 |
commit | 6a6b57e0ca791f50bf7cc52ec4841c93b08619d3 (patch) | |
tree | 9c71981b4eee6f4d8d450c3a129536ec13e20656 /Perl | |
parent | e7446a0a6506dbab79efe8c279a4f2ed0784d36f (diff) |
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
Diffstat (limited to 'Perl')
-rw-r--r-- | Perl/Debian/L10n/Db.pm | 457 | ||||
-rw-r--r-- | Perl/Debian/L10n/Debconf.pm | 472 | ||||
-rw-r--r-- | Perl/Debian/Pkg/DebSrc.pm | 176 | ||||
-rw-r--r-- | Perl/Debian/Pkg/Diff.pm | 652 | ||||
-rw-r--r-- | Perl/Debian/Pkg/Tar.pm | 825 |
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; + |