maint/benchmark_hashrefinflator.pl

   1 #!/usr/bin/env perl
   2
   3 #
   4 # So you wrote a new mk_hash implementation which passed all tests (particularly
   5 # t/68inflate_resultclass_hashrefinflator) and would like to see how it holds up
   6 # against older versions of the same. Just add your coderef to the HRI::Bench
   7 # namespace and add a name/ref pair to the %bench_list hash. Happy testing.
   8
   9 package DBIx::Class::ResultClass::HashRefInflator::Bench;
  10
  11 use warnings;
  12 use strict;
  13
  14 my $current_mk_hash;
  15 $current_mk_hash = sub {
  16     if (ref $_[0] eq 'ARRAY') {     # multi relationship
  17         return [ map { $current_mk_hash->(@$_) || () } (@_) ];
  18     }
  19     else {
  20         my $hash = {
  21             # the main hash could be an undef if we are processing a skipped-over join
  22             $_[0] ? %{$_[0]} : (),
  23
  24             # the second arg is a hash of arrays for each prefetched relation
  25             map
  26                 { $_ => $current_mk_hash->( @{$_[1]->{$_}} ) }
  27                 ( $_[1] ? (keys %{$_[1]}) : () )
  28         };
  29
  30         # if there is at least one defined column consider the resultset real
  31         # (and not an emtpy has_many rel containing one empty hashref)
  32         for (values %$hash) {
  33             return $hash if defined $_;
  34         }
  35
  36         return undef;
  37     }
  38 };
  39
  40 # the (incomplete, fails a test) implementation before svn:4760
  41 my $old_mk_hash;
  42 $old_mk_hash = sub {
  43     my ($me, $rest) = @_;
  44
  45     # $me is the hashref of cols/data from the immediate resultsource
  46     # $rest is a deep hashref of all the data from the prefetched
  47     # related sources.
  48
  49     # to avoid emtpy has_many rels contain one empty hashref
  50     return undef if (not keys %$me);
  51
  52     my $def;
  53
  54     foreach (values %$me) {
  55         if (defined $_) {
  56             $def = 1;
  57             last;
  58         }
  59     }
  60     return undef unless $def;
  61
  62     return { %$me,
  63         map {
  64           ( $_ =>
  65              ref($rest->{$_}[0]) eq 'ARRAY'
  66                  ? [ grep defined, map $old_mk_hash->(@$_), @{$rest->{$_}} ]
  67                  : $old_mk_hash->( @{$rest->{$_}} )
  68           )
  69         } keys %$rest
  70     };
  71 };
  72
  73
  74 our %bench_list = (
  75     current_implementation => $current_mk_hash,
  76     old_implementation => $old_mk_hash,
  77 );
  78
  79 1;
  80
  81 package benchmark_hashrefinflator;
  82
  83 use warnings;
  84 use strict;
  85
  86 use FindBin;
  87 use lib ("$FindBin::Bin/../lib", "$FindBin::Bin/../t/lib");
  88
  89 use Benchmark qw/timethis cmpthese/;
  90 use DBICTest;
  91
  92 chdir ("$FindBin::Bin/..");
  93 my $schema = DBICTest->init_schema();
  94
  95 my $test_sub = sub {
  96     my $rs_hashrefinf = $schema->resultset ('Artist')->search ({}, {
  97         prefetch => { cds => 'tracks' },
  98     });
  99     $rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator::Bench');
 100     my @stuff = $rs_hashrefinf->all;
 101 };
 102
 103
 104 my $results;
 105 for my $b (keys %DBIx::Class::ResultClass::HashRefInflator::Bench::bench_list) {
 106
 107     print "Timing $b... ";
 108
 109     # switch the inflator
 110     no warnings qw/redefine once/;
 111     no strict qw/refs/;
 112     local *DBIx::Class::ResultClass::HashRefInflator::Bench::inflate_result = sub {
 113         return $DBIx::Class::ResultClass::HashRefInflator::Bench::bench_list{$b}->(@_[2,3]);
 114     };
 115
 116     $results->{$b} = timethis (-2, $test_sub);
 117 }
 118 cmpthese ($results);