Skip error/warn frames within CAG - saner callsite error messages this way
[dbsrgits/DBIx-Class.git] / maint / benchmark_hashrefinflator.pl
CommitLineData
f54428ab 1#!/usr/bin/env perl
2328814a 2
2328814a 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
a5b29361 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.
2328814a 8
a5b29361 9package DBIx::Class::ResultClass::HashRefInflator::Bench;
2328814a 10
a5b29361 11use warnings;
12use strict;
2328814a 13
a5b29361 14my $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]} : (),
2328814a 23
a5b29361 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 };
2328814a 29
a5b29361 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 }
2328814a 35
a5b29361 36 return undef;
37 }
38};
2328814a 39
40# the (incomplete, fails a test) implementation before svn:4760
a5b29361 41my $old_mk_hash;
42$old_mk_hash = sub {
2328814a 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'
a5b29361 66 ? [ grep defined, map $old_mk_hash->(@$_), @{$rest->{$_}} ]
67 : $old_mk_hash->( @{$rest->{$_}} )
2328814a 68 )
69 } keys %$rest
70 };
a5b29361 71};
2328814a 72
2328814a 73
a5b29361 74our %bench_list = (
75 current_implementation => $current_mk_hash,
76 old_implementation => $old_mk_hash,
77);
2328814a 78
a5b29361 791;
2328814a 80
a5b29361 81package benchmark_hashrefinflator;
82
83use warnings;
84use strict;
85
86use FindBin;
87use lib ("$FindBin::Bin/../lib", "$FindBin::Bin/../t/lib");
88
89use Benchmark qw/timethis cmpthese/;
90use DBICTest;
91
92chdir ("$FindBin::Bin/..");
93my $schema = DBICTest->init_schema();
94
95my $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
104my $results;
105for 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);
2328814a 117}
a5b29361 118cmpthese ($results);