Changeset 24119

Show
Ignore:
Timestamp:
11/18/08 18:19:14 (7 weeks ago)
Author:
bonnu
Message:

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

Location:
lang/perl/Method-Cached/trunk
Files:
5 modified

Legend:

Unmodified
Added
Removed

  • lang/perl/Method-Cached/trunk/MANIFEST

    r22434 r24119  
    2020t/02-management.t 
    2121t/03-composite.t 
    22 t/97-boilerplate.t 
    23 t/98-perlcritic.t 
    24 t/99-pod.t 
    2522t/benchmark.pl 
    2623t/perlcriticrc 

  • lang/perl/Method-Cached/trunk/MANIFEST.SKIP

    r22434 r24119  
    1616^[^/]+\.pl$ 
    1717^\.shipit$ 
     18^t/9\d-.*\.t$ 

  • lang/perl/Method-Cached/trunk/lib/Method/Cached.pm

    r22433 r24119  
    2222    my $name = $pkg . '::' . *{$symbol}{NAME}; 
    2323    my ($domain_name, $expires, $key_rule) = _parse_option(@{ $options }); 
     24    my $cref = { 
     25        name     => $name, 
     26        code     => $code, 
     27        domain   => $domain_name, 
     28        expires  => $expires, 
     29        key_rule => $key_rule, 
     30    }; 
    2431    no strict 'refs'; 
    2532    no warnings 'redefine'; 
    26     *{$name} = sub { 
    27         my @args = @_; 
    28         my $domain = $_DOMAINS{$domain_name} 
    29             ? $_DOMAINS{$domain_name} 
    30             : $_DEFAULT_DOMAIN; 
    31         $key_rule ||= $domain->{key_rule}; 
    32         my $key = Method::Cached::KeyRule::regularize($key_rule, $name, \@args); 
    33         my $storage = _storage($domain); 
    34         my $ret = $storage->get($key); 
    35         return wantarray ? @{ $ret } : ${ $ret }[0] if $ret; 
    36         my @ret = ($code->(@_)); 
    37         $storage->set($key, \@ret, $expires || 0); 
    38         return wantarray ? @ret : $ret[0]; 
    39     }; 
     33    *{$name} = sub { unshift @_, $cref; goto &_wrapper }; 
    4034} 
    4135 
    … …  
    5953    my $class = shift; 
    6054    if (0 < @_) { 
     55        my $option = shift; 
     56        exists $option->{key_rule} && delete $option->{key_rule}; 
    6157        $_DEFAULT_DOMAIN = { 
    6258            %{ $_DEFAULT_DOMAIN }, 
    63             %{ +shift }, 
     59            %{ $option }, 
    6460        }; 
    6561        _inspect_storage_class($_DEFAULT_DOMAIN->{storage_class}); 
    … …  
    120116    $invalid && croak 
    121117        'storage_class needs the following methods: new, set, get, delete or remove'; 
     118} 
     119 
     120sub _wrapper { 
     121    my $c = shift; 
     122    my $dname  = $c->{domain}; 
     123    my $domain = $_DOMAINS{$dname} ? $_DOMAINS{$dname} : $_DEFAULT_DOMAIN; 
     124    my $rule   = $c->{key_rule} || $domain->{key_rule}; 
     125    my $key    = Method::Cached::KeyRule::regularize($rule, $c->{name}, [ @_ ]); 
     126    my $store  = _storage($domain); 
     127    my $ret    = $store->get($key); 
     128    return wantarray ? @{ $ret } : ${ $ret }[0] if $ret; 
     129    my @ret = ($c->{code}->(@_)); 
     130    $store->set($key, \@ret, $c->{expires} || 0); 
     131    return wantarray ? @ret : $ret[0]; 
    122132} 
    123133 

  • lang/perl/Method-Cached/trunk/lib/Method/Cached/KeyRule.pm

    r22060 r24119  
    55use Digest::SHA qw/sha1_base64/; 
    66use JSON::XS; 
    7 use Storable qw/freeze/; 
     7use Storable; 
    88use Scalar::Util qw/refaddr/; 
    99 
    … …  
    1616    my $key; 
    1717    for my $rule (@{$key_rule}) { 
    18         $key = ''; 
    1918        $key = ref $rule ? $rule->(@_) : &{$rule}(@_); 
    2019    } 
    … …  
    3130    my ($method_name, $args) = @_; 
    3231    our $ENCODER ||= JSON::XS->new->convert_blessed(1); 
    33     *UNIVERSAL::TO_JSON = sub { freeze \@_ }; 
     32    *UNIVERSAL::TO_JSON = sub { Storable::nfreeze \@_ }; 
    3433    my $json = $ENCODER->encode($args->[0]); 
    3534    undef *UNIVERSAL::TO_JSON; 
    … …  
    5453    local $^W = 0; 
    5554    our $ENCODER ||= JSON::XS->new->convert_blessed(1); 
    56     *UNIVERSAL::TO_JSON = sub { freeze \@_ }; 
     55    *UNIVERSAL::TO_JSON = sub { Storable::nfreeze \@_ }; 
    5756    my $json = $ENCODER->encode($args); 
    5857    undef *UNIVERSAL::TO_JSON; 

  • lang/perl/Method-Cached/trunk/t/benchmark.pl

    r24086 r24119  
    1111            { servers    => [qw/ 127.0.0.1:11211 /] }, 
    1212        ], 
    13         key_rule      => 'SERIALIZE', # SERIALIZE / LIST 
    1413    }, 
    1514    -domains => { 
    … …  
    1918                { servers    => [qw/ 127.0.0.1:11211 /] }, 
    2019            ], 
    21             key_rule      => 'SERIALIZE', # SERIALIZE / LIST 
     20            key_rule      => 'LIST', # SERIALIZE / LIST 
    2221        }, 
    2322        'fastmmap'       => { 
    … …  
    2726                unlink_on_exit => 1, 
    2827            ], 
    29             key_rule      => 'SERIALIZE', # SERIALIZE / LIST 
     28            key_rule      => 'LIST', # SERIALIZE / LIST 
    3029        }, 
    3130    },