package Plack::Middleware::Debug::CatalystPluginCache;
use 5.008;
use strict;
use warnings;
use Plack::Util::Accessor qw(app_class track_miss_locations show_process_stats show_global_stats);
use Class::Method::Modifiers qw(install_modifier);
use Text::MicroTemplate qw(encoded_string);

use parent qw(Plack::Middleware::Debug::Base);

our $VERSION = '0.10';

my @stat_keys = qw(cache_get_hit cache_get_miss cache_set cache_remove cache_compute);
my $track_miss_locations; # fudge, to be visible to method hooks
my $process_stats_req_count = 0;
my %process_stats;  # process stats keyed by cache name
my %be_stat;        # request stats keyed by backend ref


sub _install_method_hooks {

    install_modifier 'Catalyst::Plugin::Cache', 'before', 'cache_set' => sub {
        my ( $c, $key, $value, @meta ) = @_;
        my $backend = $c->choose_cache_backend_wrapper(key => $key, value => $value, @meta);
        $be_stat{$backend}->{cache_set}++;
    };

    install_modifier 'Catalyst::Plugin::Cache', 'before', 'cache_remove' => sub {
        my ( $c, $key, @meta ) = @_;
        my $backend = $c->choose_cache_backend_wrapper( key => $key, @meta );
        $be_stat{$backend}->{cache_remove}++;
    };

    # XXX if a backend supports compute then we can't tell what happened,
    # if not, then either cache_get_hit or cache_get_miss+cache_set will also
    # be incremented. We could XXX
    install_modifier 'Catalyst::Plugin::Cache', 'before', 'cache_compute' => sub {
        my ($c, $key, $code, @meta) = @_;
        my $backend = $c->choose_cache_backend_wrapper( key => $key, @meta );
        $be_stat{$backend}->{cache_compute}++;
    };

    install_modifier 'Catalyst::Plugin::Cache', 'around', 'cache_get' => sub {
        my $orig = shift;
        my $c = shift;
        my $backend = $c->choose_cache_backend_wrapper( key => @_ );
        if (defined(my $result = $c->$orig(@_))) { # XXX we assume scalar context
            $be_stat{$backend}->{cache_get_hit}++;
            return $result;
        }
        $be_stat{$backend}->{cache_get_miss}++;

        if ($track_miss_locations) {
            my $p = $be_stat{$backend}->{cache_get_miss_call_tree} ||= {};
            my $level = 2;
            while (my ($pkg, $file, $line, $sub) = caller(++$level)) {
                next if $pkg =~ /^(?:Class::MOP|Plack|Class::Method|Try::Tiny)\b/;
                $p = $p->{"$pkg\::$sub\@$line"} ||= {};
            }
            $p->{misses}++;
        }

        return undef;
    };
}


sub prepare_app {
    my $self = shift;

    if (not $self->app_class) {

        my $apps = mro::get_isarev('Catalyst');
        die "There doesn't seem to be a Catalyst application class\n"
            unless @$apps;

        die "The CatalystPluginCache needs an app_class config option specified (one of @$apps)\n"
            if @$apps > 1;

        $self->app_class($apps->[0]);
    }

    if ($INC{'Catalyst/Plugin/Cache.pm'}) {
        _install_method_hooks() if $INC{'Catalyst/Plugin/Cache.pm'};
    }
    else {
        warn __PACKAGE__." wil be inefective because Catalyst::Plugin::Cache is not loaded\n";
    }

    $self->show_process_stats(1) if not defined $self->show_process_stats;

    $track_miss_locations = $self->track_miss_locations;
}


sub run {
    my($self, $env, $panel) = @_;

    %be_stat = ();

    $self->_store_current_cache_global_stats('global_stats_pre')
        if $self->show_global_stats;

    return sub {
        my $res = shift;
        ++$process_stats_req_count;

        $self->_store_current_cache_global_stats('global_stats_post')
            if $self->show_global_stats;

        my $cbe = $self->app_class->_cache_backends;
        # include configured but unused caches
        $be_stat{$_} ||= {} for values %$cbe;

        my %cache_be2name = reverse %$cbe;
        my %cache_stat_by_name = map {
            ($cache_be2name{$_} || $_) => $be_stat{$_} ||= {}
        } values %$cbe;

        # add per-cache hit_ratio and calc total gets and hits
        my ($t_gets, $t_hits) = (0, 0);
        while ( my ($cache_name, $stats) = each %cache_stat_by_name) {
            $stats->{$_} ||= 0 for @stat_keys; # avoid undefs

            $stats->{cache_gets} = $stats->{cache_get_hit} + $stats->{cache_get_miss};
            $t_gets += $stats->{cache_gets};
            $t_hits += $stats->{cache_get_hit};

            my $process_stats = $process_stats{$cache_name} ||= {};
            $process_stats->{$_} += $stats->{$_} for (@stat_keys, 'cache_gets');
        }

        $panel->nav_subtitle( sprintf "%.1f%% of %d hit", $t_hits/$t_gets*100, $t_gets )
            if $t_gets;

        my $cache_stat_content = sub {
            my ($cache_stats, %opts) = @_;
            my $headings = ['Cache', 'Get', 'Miss', 'Hit%', 'Set', 'Compute', 'Remove', 'Backend'];
            my @rows;
            for my $name (sort keys %$cache_stats) {
                my $stats = $cache_stats->{$name};
                my $gets = $stats->{cache_gets};
                $stats->{hit_pct} = ($gets) ? sprintf "%.2f", $stats->{cache_get_hit}/$gets*100 : 0;
                push @rows, [
                    $name, @{$stats}{qw(cache_gets cache_get_miss hit_pct cache_set cache_compute cache_remove)}, $cbe->{$name}
                ];
            }
            return $self->render_table(
                caption => $opts{caption} || "Cache stats for this request:",
                headings => $headings,
                list => \@rows
            );
        };
        $panel->content( $cache_stat_content->(\%cache_stat_by_name) );

        $self->_add_content($panel, 'track_miss_locations', sub {
            my $html = '';
            for my $name (sort keys %cache_stat_by_name) {
                my $tree = $cache_stat_by_name{$name}{cache_get_miss_call_tree}
                    or next;
                my $dump = Data::Dumper->new([$tree])->Indent(1)->Terse(1)->Sortkeys(1)->Dump;
                $dump = _tidy_dump($dump);
                $dump =~ s/  /. /g;           # add dots to aid visual alignment
                my $miss_call_tree = Text::MicroTemplate::escape_html($dump);
                $miss_call_tree = encoded_string("<pre>$miss_call_tree</pre>");

                my $headings = ["Call paths for misses in the $name cache:"];
                my @rows = ([ $miss_call_tree ]);
                $html .= $self->render_table(headings => $headings, list => \@rows);
            }
            return $html;
        });

        $self->_add_content($panel, 'show_global_stats', sub {
            my @rows;
            for my $name (sort keys %cache_stat_by_name) {
                my $pre  = $cache_stat_by_name{$name}{global_stats_pre} or next;
                my $post = $cache_stat_by_name{$name}{global_stats_post} or next;
                my @diff;
                for my $key (sort keys %$post) {
                    next if $pre->{$key} eq $post->{$key};
                    push @diff, sprintf "%s: %+d", $key, $post->{$key} - $pre->{$key};
                }
                push @rows, [ $name, join ", ", @diff ];
            }
            return "" unless @rows;
            return $self->render_table(
                caption => "Global backend cache server stats (may be affected by other clients using the cache services)",
                headings => ['Cache', 'Global stats changes during time of request'],
                list => \@rows
            );
        });

        $self->_add_content($panel, 'show_process_stats', sub {
            $cache_stat_content->(\%process_stats,
                caption => "Cache stats for the life of this process ($process_stats_req_count requests to pid $$)"
            );
        });

        $panel->content( $panel->content . "<br />" );
    };
}


sub _add_content {
    my ($self, $panel, $attrib, $sub) = @_;

    # if $attrib isn't enabled, replace $sub with a stub
    $sub = sub { $self->render_lines([ "$attrib not enabled in configuration" ]) }
        if not $self->$attrib;

    $panel->content( $panel->content . $sub->() );
}


sub _tidy_dump {
    my $dump = shift;
    $dump =~ s/^[{ ].$//mg;       # remove left-most indentation
    $dump =~ s/\s*{\s*$//mg;      # remove all trailing open braces
    $dump =~ s/^\s*\},?\s*\n//mg; # remove 'empty' closing brace lines
    $dump =~ s/'//g;              #remove quotes
    return $dump;
}


sub _store_current_cache_global_stats {
    my ($self, $key) = @_;

    my $app_class = $self->app_class;
    my $cbe = $app_class->_cache_backends;

    while ( my ($cbe_name, $cache) = each %$cbe ) {
        my $orig_stat;

        if ($cache->isa('Cache::Memcached::libmemcached')) {
            # XXX https://rt.cpan.org/Ticket/Display.html?id=62163
            local $SIG{__WARN__} = sub {
                warn @_ unless $_[0] =~ /Argument "" isn't numeric in addition/;
            };
            # XXX this could be made smarter to only query caches that have
            # different configurations (eg different sets of servers)
            $orig_stat = $cache->stats->{total};
        }
        else {
            warn sprintf "Cache %s is %s which isn't supported by %s",
                    $cbe_name, ref $cache, __PACKAGE__
                unless our $warn_unsupported->{ref $cache}++;
        }
        $be_stat{$cache}{$key} = $orig_stat;
    }
}


# --- this section should be in lib/Plack/Middleware/Debug/Base.pm ---

*vardump = \&Plack::Middleware::Debug::Base::vardump; # import
my $table_template = __PACKAGE__->build_template(<<'EOTMPL');
<table>
% if (my $caption = $_[0]->{caption}) {
    <caption><%= $caption %></caption>
% }
% if (my $headings = $_[0]->{headings}) {
  <thead>
    <tr>
%   for my $heading (@$headings) {
      <th><%= $heading %></th>
%   }
    </tr>
  </thead>
% }
  <tbody>
% my $i;
% while (my $row = shift @{$_[0]->{list}}) {
    <tr class="<%= ++$i % 2 ? 'plDebugOdd' : 'plDebugEven' %>">
%   for my $value (@$row) {
      <td><%= $value %></td>
%   }
    </tr>
% }
    </tbody>
</table>
EOTMPL

sub render_table {
    my ($self, %args) = @_;
    $self->render($table_template, \%args);
}


1;
__END__

=head1 NAME

Plack::Middleware::Debug::CatalystPluginCache - DBI::Profile panel

=head1 SEE ALSO

L<Plack::Middleware::Debug> and
L<Plack::Middleware::Debug::DBITrace>

=cut
