examples/debian/versions/build-mldbm.pl

   1 #! /usr/bin/perl -w
   2 use strict;
   3 use MLDBM qw(DB_File Storable);
   4 use Fcntl;
   5
   6 $MLDBM::DumpMeth=q(portable);
   7
   8 my %db;
   9 my %db2;
  10 tie %db, "MLDBM", "versions.idx.new", O_CREAT|O_RDWR, 0664
  11     or die "tie versions.idx.new: $!";
  12 tie %db2, "MLDBM", "versions_time.idx.new",O_CREAT|O_RDWR, 0664
  13      or die "tie versions_time.idx.new failed: $!";
  14
  15 my $archive = shift;
  16 my $dist = shift;
  17 my $arch = shift;
  18 print "$archive/$dist/$arch\n";
  19
  20 my $time = time;
  21 my ($p, $v);
  22 my $extra_source_only = 0;
  23 while (<>) {
  24     if (/^Package: (.*)/)    { $p = $1; }
  25     elsif (/^Version: (.*)/) { $v = $1; }
  26     elsif (/^Extra-Source-Only: yes/) {
  27         $extra_source_only = 1;
  28     }
  29     elsif (/^$/) {
  30         if ($extra_source_only) {
  31             $extra_source_only = 0;
  32             next;
  33         }
  34         update_package_version($p,$v,$time);
  35     }
  36 }
  37 update_package_version($p,$v,$time) unless $extra_source_only;
  38
  39 sub update_package_version {
  40     my ($p,$v,$t) = @_;
  41         # see MLDBM(3pm)/BUGS
  42         my $tmp = $db{$p};
  43         # we allow multiple versions in an architecture now; this
  44         # should really only happen in the case of source, however.
  45         push @{$tmp->{$dist}{$arch}}, $v;
  46         $db{$p} = $tmp;
  47         $tmp = $db2{$p};
  48         $tmp->{$dist}{$arch}{$v} = $time if not exists
  49              $tmp->{$dist}{$arch}{$v};
  50         $db2{$p} = $tmp;
  51 }
  52