Commit | Line | Data |
dc253b77 |
1 | #!/usr/bin/perl |
2 | use strict; |
3 | use warnings; |
4 | use Test::More; |
5 | use lib qw(t/lib); |
6 | use DBICTest; |
7 | |
8 | # This is a rather unusual test. |
9 | # It does not test any aspect of DBIx::Class, but instead tests the |
10 | # perl installation this is being run under to see if it is:- |
11 | # 1. Potentially affected by a RH perl build bug |
12 | # 2. If so we do a performance test for the effect of |
13 | # that bug. |
14 | # |
15 | # You can skip these tests by setting the DBIC_NO_WARN_BAD_PERL env |
16 | # variable |
17 | # |
18 | # If these tests fail then please read the section titled |
19 | # Perl Performance Issues on Red Hat Systems in |
20 | # L<DBIx::Class::Manual::Troubleshooting> |
21 | |
22 | plan skip_all => |
23 | 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set' |
24 | if ( $ENV{DBIC_NO_WARN_BAD_PERL} ); |
25 | |
26 | eval "use Benchmark"; |
27 | plan skip_all => 'needs Benchmark for testing' if $@; |
28 | |
29 | plan tests => 2; |
30 | |
31 | { |
32 | package # don't want this in PAUSE |
33 | TestRHBug; |
34 | use overload bool => sub { 0 } |
35 | } |
36 | |
37 | sub _has_bug_34925 { |
38 | my %thing; |
39 | my $r1 = \%thing; |
40 | my $r2 = \%thing; |
41 | bless $r1 => 'TestRHBug'; |
42 | return !!$r2; |
43 | } |
44 | |
45 | sub _possibly_has_bad_overload_performance { |
46 | return $] < 5.008009 && !_has_bug_34925(); |
47 | } |
48 | |
49 | ok( !_possibly_has_bad_overload_performance(), |
50 | 'Checking not susceptable to bless/overload performance problem' ); |
51 | |
52 | my $results = timethese( |
53 | 0, |
54 | { |
55 | overload => sub { |
56 | use overload q(<) => sub { }; |
57 | my %h; |
58 | for ( my $i = 0 ; $i < 5000 ; $i++ ) { |
59 | $h{$i} = bless [] => 'main'; |
60 | } |
61 | }, |
62 | nooverload => sub { |
63 | my %h; |
64 | for ( my $i = 0 ; $i < 5000 ; $i++ ) { |
65 | $h{$i} = bless [] => 'main'; |
66 | } |
67 | } |
68 | } |
69 | ); |
70 | |
71 | ok( ( ( $results->{nooverload}->iters / $results->{overload}->iters ) < 2 ), |
72 | 'Overload/bless performance acceptable' ) |