t/test_spool/versions/indices/make_index_from_stubs.pl

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use MLDBM qw(DB_File Storable);
   7 use Fcntl;
   8
   9 $MLDBM::DumpMeth=q(portable);
  10
  11 # given an index and a set of stubs, populate the index with the stubs
  12
  13 my ($index,@stubs) = @ARGV;
  14
  15 my $index_new = $index.'.new';
  16 my $tied_index = open_index($index_new);
  17 populate_index($tied_index,\@stubs);
  18 close_index($tied_index,$index_new,$index);
  19
  20 # open and create a tied index
  21 sub open_index {
  22     my ($index) = @_;
  23     my %db;
  24     tie %db, "MLDBM", $index, O_CREAT|O_RDWR, 0664
  25         or die "tie $index: $!";
  26     return \%db;
  27 }
  28
  29 # populate the index with the given stubs
  30 sub populate_index{
  31     my ($tie,$stubs);
  32     for my $stub (@{$stubs}) {
  33         my $fh = IO::File->new($stub,'r');
  34         local $/;
  35         my $file_contents = <$fh>;
  36         my @stub_results = eval $file_contents;
  37         if ($@) {
  38             die "Stub $stub failed with error $@";
  39         }
  40         my %stub_results_to_add;
  41         if (@stub_results == 1 and
  42             ref($stub_results[0]) and
  43             ref($stub_results[0]) eq 'ARRAY') {
  44             @stub_results = @{$stub_results[0]};
  45         }
  46         if ((@stub_results % 2) == 0 and
  47             not ref($stub_results[0])
  48            ) {
  49             %stub_results_to_add = @stub_results;
  50         } else {
  51             for my $stub_result (@stub_results) {
  52                 next unless ref($stub_result);
  53                 next unless ref($stub_result) eq 'HASH';
  54                 %stub_results_to_add = (%stub_results_to_add,
  55                                         %{$stub_result});
  56             }
  57         }
  58         for my $sr (keys %stub_results_to_add) {
  59             $tie->{$sr} = $stub_results_to_add{$sr};
  60         }
  61     }
  62 }
  63
  64 # close the index
  65 sub close_index{
  66     my ($tie,$index_new,$index) = @_;
  67     untie %{$tie};
  68     rename($index_new,$index);
  69 }