Skip error/warn frames within CAG - saner callsite error messages this way
[dbsrgits/DBIx-Class.git] / 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);