root/lang/perl/Method-Cached/trunk/lib/Method/Cached/KeyRule.pm @ 24119

Revision 24119, 1.3 kB (checked in by bonnu, 5 years ago)

lang/perl/Method-Cached - wrapper メソッドを外出し

Line 
1package Method::Cached::KeyRule;
2
3use strict;
4use warnings;
5use Digest::SHA qw/sha1_base64/;
6use JSON::XS;
7use Storable;
8use Scalar::Util qw/refaddr/;
9
10sub regularize {
11    my $key_rule = shift;
12    no strict 'refs';
13    my $ref = ref $key_rule;
14    $ref || return &{$key_rule || 'LIST'}(@_);
15    $ref eq 'CODE' && return $key_rule->(@_);
16    my $key;
17    for my $rule (@{$key_rule}) {
18        $key = ref $rule ? $rule->(@_) : &{$rule}(@_);
19    }
20    return $key;
21}
22
23sub SELF_SHIFT {
24    my ($method_name, $args) = @_;
25    shift @{$args};
26    return;
27}
28
29sub SELF_CODED {
30    my ($method_name, $args) = @_;
31    our $ENCODER ||= JSON::XS->new->convert_blessed(1);
32    *UNIVERSAL::TO_JSON = sub { Storable::nfreeze \@_ };
33    my $json = $ENCODER->encode($args->[0]);
34    undef *UNIVERSAL::TO_JSON;
35    $args->[0] = sha1_base64($json);
36    return;
37}
38
39sub PER_OBJECT {
40    my ($method_name, $args) = @_;
41    $args->[0] = refaddr $args->[0];
42    return;
43}
44
45sub LIST {
46    my ($method_name, $args) = @_;
47    local $^W = 0;
48    $method_name . join chr(28), @{$args};
49}
50
51sub SERIALIZE {
52    my ($method_name, $args) = @_;
53    local $^W = 0;
54    our $ENCODER ||= JSON::XS->new->convert_blessed(1);
55    *UNIVERSAL::TO_JSON = sub { Storable::nfreeze \@_ };
56    my $json = $ENCODER->encode($args);
57    undef *UNIVERSAL::TO_JSON;
58    $method_name . sha1_base64($json);
59}
60
611;
62
63__END__
Note: See TracBrowser for help on using the browser.