Method `clear' is renamed into `clear_pkg'.

Separator for stat lines is now `!' instead of a colon.
Redesign object structure to ease further changes in database format.

CVS version numbers

Perl/Webwml/L10n/Db.pm: 1.4 -> 1.5

1 files changed, 78 insertions, 73 deletions

diff --git a/Perl/Webwml/L10n/Db.pm b/Perl/Webwml/L10n/Db.pm
index 72a001bbcc7..7719284cce2 100644
--- a/Perl/Webwml/L10n/Db.pm
+++ b/Perl/Webwml/L10n/Db.pm
@@ -50,26 +50,27 @@ sub new {
         my $proto = shift;
         my $class = ref($proto) || $proto;
         my $self  = {
-                data => {},
-                date => 0,
-                methods => {
-                        package         => '$',
-                        version         => '$',
-                        section         => '$',
-                        priority        => '$',
-                        pooldir         => '$',
-                        type            => '$',
-                        upstream        => '$',
-                        errors          => '@',
-                        warnings        => '@',
-                        catgets         => '@',
-                        gettext         => '@',
-                        nls             => '@',
-                        po              => '@',
-                        templates       => '@',
-                        menu            => '@',
-                },
+                data    => {},
+                date    => 0,
+                #   Fields below are written into file in the same order
+                #   Package must always be the first field
+                scalar  => [qw(Package Version Section Priority PoolDir Type Upstream)],
+                array1  => [qw(Errors Warnings Catgets Gettext)],
+                array2  => [qw(NLS PO TEMPLATES MENU)],
         };
+        $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;
 }
@@ -100,28 +101,31 @@ sub AUTOLOAD {
         }
 
         die "Can't access \`$has$name' method in class $type"
-                unless $self->{methods}->{$name} ne '';
+                unless defined($self->{methods}->{$name});
+
+        my $field = $self->{methods}->{$name};
 
         if ($has) {
-                return defined($self->{data}->{$pkg}->{$name});
+                return defined($self->{data}->{$pkg}->{$field});
         } else {
                 if ($#_ == -1) {
-                        return $self->{data}->{$pkg}->{$name};
+                        return $self->{data}->{$pkg}->{$field};
                 }
-                if ($self->{methods}->{$name} eq '$') {
-                        $self->{data}->{$pkg}->{$name} = $_[0];
-                } elsif ($self->{methods}->{$name} eq '%') {
-                        $self->{data}->{$pkg}->{$name} = {}
-                                unless defined($self->{data}->{$pkg}->{$name})
+                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;
-                        $self->{data}->{$pkg}->{$name}->{$_[0]} = $_[1];
-                } elsif ($self->{methods}->{$name} eq '@') {
-                        $self->{data}->{$pkg}->{$name} = []
-                                unless defined($self->{data}->{$pkg}->{$name})
+                        push (@{$self->{data}->{$pkg}->{$field}}, @_);
+                } elsif ($self->{fields}->{$field} eq '@@') {
+                        $self->{data}->{$pkg}->{$field} = []
+                                unless defined($self->{data}->{$pkg}->{$field})
                                         || !$add;
-                        push (@{$self->{data}->{$pkg}->{$name}}, @_);
+                        my @list = @_;
+                        push (@{$self->{data}->{$pkg}->{$field}}, \@list);
                 } else {
-                        die __PACKAGE__.":internal error: unknown data type:".$self->{methods}->{$name}."\n";
+                        die __PACKAGE__.":internal error: unknown data type:".$self->{fields}->{$field}."\n";
                 }
         }
 }
@@ -142,16 +146,14 @@ sub read {
         my $self = shift;
         my $file  = shift;
 
-        if (! open (DB,"< $file")) {
-                warn "Unable to read $file\n";
-                return 0;
-        }
+        return 0 unless open (DB,"< $file");
 
         $self->{date} = <DB>;
         return 0 unless defined($self->{date});
 
         chomp($self->{date});
-        <DB>;
+        $_ = <DB>;
+        next unless defined $_;
         MAIN: while (1) {
                 my $entry = {};
                 my $desc = '';
@@ -167,34 +169,38 @@ sub read {
                         $last_item = 1;
                 }
 
-                # leading tabs are illegal, but handle them anyway
+                # Leading tabs are illegal, but handle them anyway
                 $desc =~ s/^\t/ \t/mg;
 
-                foreach (qw(Package Version Section Priority PoolDir Type Upstream)) {
+                foreach (@{$self->{scalar}}) {
                         if ($desc =~ m/^$_: (.*)$/m) {
-                                $entry->{lc $_} = $1;
+                                $entry->{$_} = $1;
                         } else {
                                 warn "Parse error when reading $file: missing $_ field\n";
                                 next MAIN;
                         }
                 }
-                foreach (qw(Errors Warnings Catgets Gettext)) {
+                foreach (@{$self->{array1}}) {
                         if ($desc =~ m/(^|\n)$_:\n(.+?)(\n\S|$)/s) {
                                 $text = $2;
                                 $text =~ s/^ //mg;
                                 my @list = split(/\n\./, $text);
-                                $entry->{lc $_} = \@list;
+                                $entry->{$_} = \@list;
                         }
                 }
-                foreach (qw(NLS PO TEMPLATES MENU)) {
+                foreach (@{$self->{array2}}) {
                         if ($desc =~ m/(^|\n)$_:\n(.+?)(\n\S|$)/s) {
                                 $text = $2;
                                 $text =~ s/^ //mg;
-                                my @list = split(/\n/, $text);
-                                $entry->{lc $_} = \@list;
+                                my @list = ();
+                                foreach my $line (split(/\n/, $text)) {
+                                        my @list2 = split('!', $line);
+                                        push(@list, \@list2);
+                                }
+                                $entry->{$_} = \@list;
                         }
                 }
-                $self->{data}->{$entry->{package}} = $entry;
+                $self->{data}->{$entry->{Package}} = $entry;
                 last if $last_item;
         }
         close DB;
@@ -212,33 +218,32 @@ Write database into file.
 sub write {
         my $self = shift;
         my $file = shift;
-        my $text;
+        my ($text, $line);
 
         open (DB,"> $file")
                 || die "Unable to write to $file\n";
 
-        print DB join('-', (localtime->year() + 1900, localtime->mon() + 1, localtime->mday))."\n\n";
+        print DB join('-', (Time::localtime::localtime->year() + 1900, Time::localtime::localtime->mon() + 1, Time::localtime::localtime->mday))."\n\n";
         foreach my $pkg (keys %{$self->{data}}) {
-                foreach (qw(Package Version Section Priority PoolDir Type Upstream)) {
-                        print DB $_.": ".$self->{data}->{$pkg}->{lc $_}."\n";
+                foreach (@{$self->{scalar}}) {
+                        next unless defined($self->{data}->{$pkg}->{$_});
+                        print DB $_.": ".$self->{data}->{$pkg}->{$_}."\n";
                 }
-                foreach (qw(Errors Warnings Catgets Gettext)) {
-                        if (defined($self->{data}->{$pkg}->{lc $_})) {
-                                $text = join("\n\.\n", @{$self->{data}->{$pkg}->{lc $_}})."\n";
-                                $text =~ s/\n\n/\n/g;
-                                $text =~ s/\n+$//s;
-                                $text =~ s/^/ /mg;
-                                #  Warning: there is already a trailing
-                                #  newline within $text.
-                                print DB $_.":\n".$text."\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 (qw(NLS PO TEMPLATES MENU)) {
-                        if (defined($self->{data}->{$pkg}->{lc $_})) {
-                                $text = join("\n", @{$self->{data}->{$pkg}->{lc $_}});
-                                $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";
         }
@@ -256,15 +261,15 @@ sub list_packages {
         return keys %{$self->{data}};
 }
 
-=item clear
+=item clear_pkg
 
 Reset info for a given package
 
-   $l10n_db->clear("foo");
+   $l10n_db->clear_pkg("foo");
 
 =cut
 
-sub clear {
+sub clear_pkg {
         my $self = shift;
         my $pkg  = shift;
 
@@ -288,8 +293,8 @@ sub get_date {
 
 Data about packages can be classified within scalar values (C<package>,
 C<version>, C<section>, C<priority>, C<pooldir>, C<type>, C<upstream>),
-and arrays (C<errors>, C<warnings>, C<catgets>, C<gettext>, C<nls>,
-C<po>, C<templates>, C<menu>).
+arrays (C<errors>, C<warnings>, C<catgets>, C<gettext>), and arrays of
+arrays (C<nls>, C<po>, C<templates>, C<menu>).
 Each field has a method with the same name to get and set it, e.g.
 
    $section = $l10n_db->section($pkg);
@@ -301,12 +306,12 @@ 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 hash values.
+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');
+   $l10n_db->add_po($pkg, 'po/fr.po', 'fr', '42t0f0u', 'po/adduser_3.42_po_fr.po');
 
 =head1 AUTHOR