Plack::Request::Cached

Cached.pm

package Plack::Request::Cached;
use 5.008_001;
use strict;
use warnings;

use Variable::Magic qw/cast wizard VMG_OP_INFO_NAME/;
use Scalar::Util qw/refaddr weaken/;
use Class::Method::Modifiers::Fast qw(install_modifier);
use Data::Util qw(install_subroutine get_code_ref);
use Plack::Request;

our $VERSION = '0.01';
our %MAP;

my $wiz = wizard(
    store => sub {
        my $refaddr = refaddr($_[0]);
        undef $MAP{$refaddr}->{base};
    },
);

install_subroutine('Plack::Request', DESTROY => sub {
    my $self = shift;
    delete $MAP{refaddr $self->env};
});

install_subroutine('Plack::Request', __base => get_code_ref('Plack::Request', 'base'));

install_modifier('Plack::Request', 'around', new => sub {
    my $orig = shift;
    my $self = $orig->(@_);
    cast %{$self->env}, $wiz;
    my $addr = refaddr $self->env;
    $MAP{$addr} = $self;
    weaken($MAP{$addr});
    return $self;
});

install_modifier('Plack::Request', 'around', base => sub {
    my $orig = shift;
    $_[0]->{base} ||= $orig->($_[0]);
});

1;
__END__

=head1 NAME

Plack::Request::Cached - 

=head1 SYNOPSIS

    use strict;
    use warnings;
    use FindBin;
    use Benchmark qw(:all);

    use Plack::Request;
    use Plack::Request::Cached;
    my $req = Plack::Request->new({HTTP_HOST => 'example.com'});

    cmpthese -1, {
        'orig' => sub {
            $req->__base;
        },
        'cached' => sub {
            $req->base;
        },
    };

=head1 BASE CODE

by tokuhirom

http://subtech.g.hatena.ne.jp/tokuhirom/20100507/1273251167

=cut