Cache-Profile

 view release on metacpan or  search on metacpan

lib/Cache/Profile.pm  view on Meta::CPAN

package Cache::Profile; # git description: v0.05-2-gd123baf
# ABSTRACT: Measure the performance of a cache

our $VERSION = '0.06';

use Moose;
use Carp;
use Time::HiRes 1.84 qw(tv_interval gettimeofday time clock);
use Try::Tiny;
use Class::MOP;
use namespace::autoclean;

has cache => (
    isa => "Object",
    is  => "ro",
    required => 1,
);

sub AUTOLOAD {
    my $self = shift;

    my ( $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );

    $self->cache->$method(@_);
}

sub isa {
    my ( $self, $class ) = @_;

    $self->SUPER::isa($class) or $self->cache->isa($class);
}

my @timer_names = qw(hit get set miss);

sub timer_names { @timer_names }

foreach my $method ( "all", @timer_names ) {
    my $count = "call_count_$method";

    has $count => (
        traits => [qw(Counter)],
        isa => "Num",
        is  => "ro",
        default => sub { 0 },
        handles => {
            "_inc_call_count_$method" => "inc",
            "reset_call_count_$method" => [ set => 0 ],
        },
    );

    foreach my $measure ( qw(real cpu) )  {
        my $time = "total_${measure}_time_${method}";
        has $time => (
            traits => [qw(Number)],
            isa => "Num",
            is  => "ro",
            default => sub { 0 },
            handles => {
                "_add_${method}_${measure}"  => "add",
                "reset_${method}_${measure}" => [ set => 0 ],
            },
        );

        __PACKAGE__->meta->add_method( "average_${method}_time_${measure}" => sub {
            my $self = shift;

            try { $self->$time / $self->$count } # undef if no count;
        });

        __PACKAGE__->meta->add_method( "${method}_call_rate" => sub {
            my $self = shift;

            try { $self->$count / $self->$time } # undef if no time;
        });
    }
}

foreach my $counter ( qw(hit_count miss_count) ) {
    has $counter => (
        traits => [qw(Number)],
        isa => "Int",
        is  => "ro",
        default => sub { 0 },
        handles => {
            "_add_$counter"  => "add",
            "_inc_$counter"  => [ add => 1 ],
            "reset_$counter" => [ set => 0 ],
        },
    );
}

sub miss_rate {
    my $self = shift;

    try { $self->miss_count / $self->query_count };
}

lib/Cache/Profile.pm  view on Meta::CPAN

    my $name = $args{counter} || $args{method};

    my ( $time_c, $time_r ) = @{ $args{timing} }{qw(time_c time_r)};

    foreach my $counter ( $name, "all" ) {
        $self->${\"_add_${counter}_cpu"}($time_c);
        $self->${\"_add_${counter}_real"}($time_r);
        $self->${\"_inc_call_count_${counter}"};
    }
}

sub _trace {
    my $self = shift;
    my $method = shift;
    $self->_trace_full( method => $method, args => \@_ );
}

sub _trace_full {
    my ( $self, %args ) = @_;

    my $cache = $self->cache;

    my $method = $args{method};
    my $args = $args{args} || [];

    my @ret;

    my $start_c = clock;
    my $start_r = [gettimeofday];

    if ( wantarray ) {
        @ret = $cache->$method(@$args);
    } else {
        $ret[0] = $cache->$method(@$args);
    }

    my $end_c = clock;
    my $end_r = [gettimeofday];

    my $trace_method = $args{trace_method} || "_record_$method";
    $self->$trace_method(
        %args,
        ret  => \@ret,
        wantarray => wantarray,
        timing => {
            start_c => $start_c,
            end_c => $end_c,
            time_c => $end_c - $start_c,
            start_r => $start_r,
            end_r => $end_r,
            time_r => tv_interval($start_r, $end_r),
        },
    );

    return wantarray ? @ret : $ret[0];
}

sub reset {
    my $self = shift;

    foreach my $method ( $self->timer_names ) {
        foreach my $measure ( qw(real cpu) ) {
            $self->${\"reset_${method}_${measure}"};
        }
        $self->${\"reset_call_count_$method"};
    }

    $self->reset_hit_count;
    $self->reset_miss_count;
}

sub speedup {
    my $self = shift;

    my $miss = $self->total_real_time_miss;

    my $sum = $self->total_real_time_all;

    my $cache_overhead = $sum - $miss;

    my $estimated_without_cache = $miss * ( 1 / $self->miss_rate );

    return ( $sum / $estimated_without_cache );
}

sub report {
    my $self = shift;

    my $report = "";

    if ( $self->hit_count ) {
        $report .= sprintf "Hit rate: %0.2f%% (%d/%d)\n", ( $self->hit_rate * 100 ), $self->hit_count, $self->query_count;
    }

    foreach my $method ( $self->timer_names, "all" ) {
        if ( my $calls = $self->${\"call_count_$method"} ) {
            my %times;
            foreach my $measure ( qw(real cpu) ) {
                $times{$measure} = $self->${\"total_${measure}_time_${method}"};
            }

            $report .= sprintf "% 3s: %d time(s), %.2fs cpu, %0.2fs real\n", $method, $calls, @times{qw(cpu real)};
        }
    }

    if ( my $_calls = $self->call_count_miss ) {
        my $gets = $self->call_count_get;

        foreach my $measure (qw(cpu real)) {
            my $miss = $self->${\"total_${measure}_time_miss"};

            my $sum = $self->${\"total_${measure}_time_all"};

            my $cache_overhead = $sum - $miss;

            my $estimated_without_cache = $miss * ( 1 / $self->miss_rate );

            if ( $sum > $estimated_without_cache ) {
                $report .= sprintf
                    "%s time slowdown: %0.2f%% (%.2fs overhead, %.2fs est. compute time w/o cache)\n",
                    $measure, ( ( $sum - $estimated_without_cache ) / $sum ) * 100,
                    $cache_overhead, $estimated_without_cache;
            } else {
                $report .= sprintf
                    "%s time speedup: %0.2f%% (%.2fs est. compute time w/o cache)\n",
                    $measure, ( ( $estimated_without_cache - $sum ) / $estimated_without_cache ) * 100,
                    $estimated_without_cache, $measure;
            }
        }
    }

    return $report;
}

sub moniker {
    my $self = shift;

    if ( my $meta = Class::MOP::class_of($self->cache) ) {
        # CHI drivers
        foreach my $class ( $meta->linearized_isa ) {
            return $class unless Class::MOP::class_of($class)->is_anon_class;
        }
    }

    return ref($self->cache);
}

__PACKAGE__->meta->make_immutable;

__PACKAGE__;

=pod

=encoding UTF-8

lib/Cache/Profile.pm  view on Meta::CPAN

Note that this should increase the overhead of caching by a bit while in use,
especially for quick in memory caches, so don't benchmark with profiling in
case.

=head1 METHODS

=over 4

=item AUTOLOAD

Delegates everything to the cache.

=item get

=item set

=item compute

Standard cache API methods.

=item report

Returns a simple report as a human readable string.

=item {average,total}_{real,cpu}_time_{get,set,miss,all}

Returns the time value (as floating seconds) for the given method.

C<miss> is the time value for the callback provided to C<compute>.

C<compute> is counted as a C<get>, optionally followed by a C<miss> and a
C<set>.

=item call_count_{get,set,miss,all}

Returns the number of times a method is called.

=item query_count

Returns the number of queried keys. For caches supporting multi key get this
may be bigger than C<call_count_get>.

=item hit_rate

=item miss_count

Returns the number of keys whose corresponding return values from C<get> were
defined or C<undef>, respectively.

=item speedup

Returns the actual time elapsed using caching divided the estimated time to
compute all values (based on the average time to compute cache misses).

Smaller is better.

If the overhead of C<get> and C<set> is higher, this will be bigger than 1.

=item reset

Resets the counters/timers.

=back

=head1 SUPPORT

Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Cache-Profile>
(or L<bug-Cache-Profile@rt.cpan.org|mailto:bug-Cache-Profile@rt.cpan.org>).

=head1 AUTHOR

יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>

=head1 CONTRIBUTOR

=for stopwords Karen Etheridge

Karen Etheridge <ether@cpan.org>

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2010 by יובל קוג'מן (Yuval Kogman).

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

__END__


# ex: set sw=4 et: