Changeset 20895

Show
Ignore:
Timestamp:
10/07/08 15:48:46 (3 months ago)
Author:
bonnu
Message:

lang/perl/Method-Cached - derivation & syntax correct

Location:
lang/perl/Method-Cached/trunk
Files:
1 added
8 modified

Legend:

Unmodified
Added
Removed

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

    r20848 r20895  
    1414lib/Method/Cached/Domain/Default.pm 
    1515lib/Method/Cached/KeyRegularizer.pm 
     16lib/Method/Cached/KeyRule.pm 
    1617lib/Method/Cached/Manager.pm 
    1718lib/Method/Cached/MethodRegistry.pm 

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

    r20615 r20895  
    1414 
    1515__PACKAGE__->mk_classaccessor('storage'); 
    16 __PACKAGE__->mk_classaccessor('key_regularizer' => 'LIST'); 
     16__PACKAGE__->mk_classaccessor('key_rule' => 'LIST'); 
    1717 
    1818sub new { 
    … …  
    2020    my %args  = (0 < @_ && ref $_[0] eq 'HASH') ? %{ $_[0] } : @_; 
    2121    my $self  = bless {}, $class; 
    22     my $storage_class   = $args{storage_class}  || croak 'storage_class is necessary'; 
    23     my $storage_args    = $args{storage_args}    || undef; 
    24     my $key_regularizer = $args{key_regularizer} || undef; 
     22    my $storage_class = $args{storage_class} || croak 'storage_class is necessary'; 
     23    my $storage_args  = $args{storage_args}  || undef; 
     24    my $key_rule      = $args{key_rule}      || undef; 
    2525    if (blessed $storage_class) { 
    2626        $self->storage($storage_class); 
    … …  
    3535        $self->storage($storage_class->new(@{ $storage_args || [] })); 
    3636    } 
    37     $self->key_regularizer($key_regularizer) if $key_regularizer; 
     37    $self->key_rule($key_rule) if $key_rule; 
    3838    $self; 
    3939} 
    … …  
    4343    my $registry = Method::Cached::MethodRegistry::refer($name); 
    4444    Method::Cached::KeyRegularizer->regularize( 
    45         $registry->{key_regularizer} || $self->key_regularizer || undef,  
     45        $registry->{key_rule} || $self->key_rule || undef,  
    4646        $name, 
    4747        @args, 
    … …  
    8282  my $domain = Method::Cached::Domain->new( 
    8383      # The supported interface is Cache::Cache and Cache::Memcached.  
    84       storage_class   => 'Cache::Memcached::Fast', 
    85       storage_args    => [ 
     84      storage_class => 'Cache::Memcached::Fast', 
     85      storage_args  => [ 
    8686          { 
    8787              servers         => [qw/ 127.0.0.1:11211 /], 
    … …  
    9191          }, 
    9292      ], 
    93       key_regularizer => undef, 
     93      key_rule      => undef, 
    9494  ); 
    9595 

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

    r20615 r20895  
    77 
    88my $_setting = { 
    9     storage_class   => 'Cache::FastMmap', 
    10     storage_args    => [ 
    11         share_file     => '/tmp/fastmmap-sharefile.bin', 
     9    storage_class => 'Cache::FastMmap', 
     10    storage_args  => [ 
     11        share_file     => '/tmp/fastmmap.bin', 
    1212        unlink_on_exit => 0, 
    1313    ], 
    14     key_regularizer => 'LIST', 
     14    key_rule      => 'LIST', 
    1515}; 
    1616 

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

    r20638 r20895  
    1212my $_encoder; 
    1313 
    14 # 'This regularizer was not supported or it did not operate normally :' . 
    15 # " $regularizer - $@"; 
    16  
    1714sub regularize { 
    18     my ($class, $regularizer, $method_name, @args) = @_; 
    19     ref $regularizer && return $regularizer->(@args); 
     15    my ($class, $key_rule, $method_name, @args) = @_; 
     16    ref $key_rule && return $key_rule->(@args); 
    2017    { 
    2118        no strict 'refs'; 
    22         $regularizer ||= 'LIST'; 
    23         return $method_name . &{$regularizer}(@args); 
     19        $key_rule ||= 'LIST'; 
     20        return $method_name . &{$key_rule}(@args); 
    2421    } 
    2522} 

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

    r20848 r20895  
    44use warnings; 
    55use 5.008007; 
    6 use Method::Cached::KeyRegularizer; 
    76 
    87our %_registry; 
    … …  
    1716    # Arguments of attribute 
    1817    # 
    19     my $domain_name     = ($_[0] && $_[0] =~ /^-?\d+$/) ? q{} : shift; 
    20     my $expires         = shift || 0; 
    21     my $key_regularizer = shift || undef; 
     18    my $domain_name = (defined $_[0] && $_[0] =~ /^-?\d+$/) ? q{} : shift; 
     19    my $expires     = shift || 0; 
     20    my $key_rule    = shift || undef; 
    2221    $_registry{$name} = { 
    23         domain          => $domain_name, 
    24         expires         => $expires, 
    25         key_regularizer => $key_regularizer, 
     22        domain   => $domain_name, 
     23        expires  => $expires, 
     24        key_rule => $key_rule, 
    2625    }; 
    2726} 

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

    r20848 r20895  
    66use Attribute::Handlers; 
    77use Carp qw/croak confess/; 
    8 use Digest::SHA qw/sha1_base64/; 
    9 use JSON::XS; 
    10 use Storable qw/freeze/; 
    118use UNIVERSAL::require; 
     9use Method::Cached::KeyRule; 
    1210 
    1311our $VERSION = '0.0103'; 
    1412 
    15 my %_domains; 
    16 my $_default_domain = { 
    17     storage_class   => 'Cache::FastMmap', 
    18     storage_args    => [ 
    19         share_file     => '/tmp/fastmmap-sharefile.bin', 
     13my %_DOMAINS; 
     14my $_DEFAULT_DOMAIN = { 
     15    storage_class => 'Cache::FastMmap', 
     16    storage_args  => [ 
     17        share_file     => '/tmp/fastmmap.bin', 
    2018        unlink_on_exit => 0, 
    2119    ], 
    22     key_regularizer => 'LIST', 
     20    key_rule      => 'LIST', 
    2321}; 
    2422 
    … …  
    2725    $options = [ $options || () ] unless ref $options eq 'ARRAY'; 
    2826    my $name = $pkg . '::' . *{$symbol}{NAME}; 
    29     my ($domain_name, $expires, $regularizer) = _parse_option(@{ $options }); 
     27    my ($domain_name, $expires, $key_rule) = _parse_option(@{ $options }); 
    3028    no strict 'refs'; 
    3129    no warnings 'redefine'; 
    3230    *{$name} = sub { 
    33         my $domain = $_domains{$domain_name} 
    34             ? $_domains{$domain_name} 
    35             : $_default_domain; 
    36         $regularizer ||= $domain->{key_regularizer}; 
    37         my $key = _regularize($regularizer, $name, @_); 
     31        my $domain = $_DOMAINS{$domain_name} 
     32            ? $_DOMAINS{$domain_name} 
     33            : $_DEFAULT_DOMAIN; 
     34        $key_rule ||= $domain->{key_rule}; 
     35        my $key = Method::Cached::KeyRule::regularize($key_rule, $name, @_); 
    3836        my $storage = _storage($domain); 
    3937        my $ret = $storage->get($key); 
    … …  
    5351    } 
    5452    if (exists $args{-default} && defined $args{-default}) { 
    55         my $domain = $args{-default}; 
    56         ref $domain eq 'HASH' or croak '-default option should be a hash reference'; 
    57         $class->default_domain($domain); 
     53        my $default = $args{-default}; 
     54        ref $default eq 'HASH' or croak '-default option should be a hash reference'; 
     55        $class->default_domain($default); 
    5856    } 
    5957} 
    … …  
    6159sub default_domain { 
    6260    my $class = shift; 
    63     $_default_domain = { 
    64         %{ $_default_domain }, 
     61    $_DEFAULT_DOMAIN = { 
     62        %{ $_DEFAULT_DOMAIN }, 
    6563        %{ +shift }, 
    6664    }; 
    … …  
    7068    my $class = shift; 
    7169    while (my ($name, $args) = splice @_, 0, 2) { 
    72         $_domains{$name} = $args; 
     70        if (exists $_DOMAINS{$name}) { 
     71            warn 'This domain has already been defined: ' . $name; 
     72            next; 
     73        } 
     74        $_DOMAINS{$name} = $args; 
    7375    } 
    7476} 
    … …  
    7779    my $domain_name = ($_[0] =~ /^-?\d+$/) ? q{} : shift; 
    7880    my $expires     = shift || 0; 
    79     my $regularizer = shift || undef; 
    80     return ($domain_name, $expires, $regularizer); 
    81 } 
    82  
    83 sub _regularize { 
    84     my ($regularizer, $method_name) = splice @_, 0, 2; 
    85     ref $regularizer && return $regularizer->($method_name, @_); 
    86     no strict 'refs'; 
    87     $regularizer ||= 'LIST'; 
    88     return $method_name . &{$regularizer}(@_); 
     81    my $key_rule    = shift || undef; 
     82    return ($domain_name, $expires, $key_rule); 
    8983} 
    9084 
    … …  
    9892} 
    9993 
    100 sub LIST { 
    101     my $method_name = shift; 
    102     local $^W = 0; 
    103     join chr(28), @_; 
    104 } 
    105  
    106 sub SERIALIZE { 
    107     my $method_name = shift; 
    108     local $^W = 0; 
    109     our $ENCODER ||= JSON::XS->new->convert_blessed(1); 
    110     *UNIVERSAL::TO_JSON = sub { freeze \@_ }; 
    111     my $json = $ENCODER->encode(\@_); 
    112     undef *UNIVERSAL::TO_JSON; 
    113     sha1_base64($json); 
    114 } 
    115  
    116941; 
    11795 

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

    r20848 r20895  
    77use Method::Cached::Manager 
    88    -default => { 
    9         storage_class    => 'Cache::Memcached::Fast', 
    10         storage_args     => [ 
     9        storage_class => 'Cache::Memcached::Fast', 
     10        storage_args  => [ 
    1111            { servers    => [qw/ 127.0.0.1:11211 /] }, 
    1212        ], 
    13         key_regularizer  => 'SERIALIZE', # SERIALIZE / LIST 
     13        key_rule      => 'SERIALIZE', # SERIALIZE / LIST 
    1414    }, 
    1515    -domains => { 
    1616        'memcached-fast' => { 
    17             storage_class    => 'Cache::Memcached::Fast', 
    18             storage_args     => [ 
     17            storage_class => 'Cache::Memcached::Fast', 
     18            storage_args  => [ 
    1919                { servers    => [qw/ 127.0.0.1:11211 /] }, 
    2020            ], 
    21             key_regularizer  => 'SERIALIZE', # SERIALIZE / LIST 
     21            key_rule      => 'SERIALIZE', # SERIALIZE / LIST 
    2222        }, 
    2323        'fastmmap'       => { 
    24             storage_class    => 'Cache::FastMmap', 
    25             storage_args     => [ 
     24            storage_class => 'Cache::FastMmap', 
     25            storage_args  => [ 
    2626                share_file     => '/tmp/fastmmap.bin', 
    2727                unlink_on_exit => 0, 
    2828            ], 
    29             key_regularizer  => 'SERIALIZE', # SERIALIZE / LIST 
     29            key_rule      => 'SERIALIZE', # SERIALIZE / LIST 
    3030        }, 
    3131    }, 
    … …  
    8383sub m_fib   { $m_fib   = $num; $m_fib   = Dummy::fib_memoize($m_fib)    } 
    8484 
    85 cmpthese(50000, { 
     85cmpthese(10000, { 
    8686    'fib'               => \&fib, 
    8787    'C(default)'        => \&def_fib, 

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

    r20848 r20895  
    66 
    77use Method::Cached::Manager -default => { 
    8     storage_class    => 'Cache::Memcached::Fast', 
    9     storage_args     => [ 
    10         { servers    => [qw/ 127.0.0.1:11211 /] }, 
     8    storage_class => 'Cache::Memcached::Fast', 
     9    storage_args  => [ 
     10        { servers => [qw/ 127.0.0.1:11211 /] }, 
    1111    ], 
    12     key_regularizer  => 'SERIALIZE', # SERIALIZE / LIST 
     12    key_rule      => 'LIST', # SERIALIZE / LIST 
    1313}; 
    1414 
    1515use Method::Cached2 -default => { 
    16     storage_class    => 'Cache::Memcached::Fast', 
    17     storage_args     => [ 
    18         { servers    => [qw/ 127.0.0.1:11211 /] }, 
     16    storage_class => 'Cache::Memcached::Fast', 
     17    storage_args  => [ 
     18        { servers => [qw/ 127.0.0.1:11211 /] }, 
    1919    ], 
    20     key_regularizer  => 'SERIALIZE', # SERIALIZE / LIST 
     20    key_rule      => 'LIST', # SERIALIZE / LIST 
    2121}; 
    2222 
    … …  
    5959my $num = 13; 
    6060 
    61 my ($fib, $c_fib, $c2_fib, $f_fib, $m_fib); 
     61my ($fib, $c_fib, $c2_fib, $m_fib); 
    6262 
    6363sub fib    { $fib    = $num; $fib    = Dummy::fib($fib)           } 
    … …  
    6666sub m_fib  { $m_fib  = $num; $m_fib  = Dummy::fib_memoize($m_fib) } 
    6767 
    68 cmpthese(1000, { 
     68cmpthese(10000, { 
    6969    'fib'     => \&fib, 
    7070    'Cached'  => \&c_fib,