Changeset 20615 for lang

Timestamp:

10/03/08 18:52:44 (5 years ago)

Author:

bonnu

Message:

lang/perl/Method-Cached - content of beta(or alpha) was reviewed

Location:

lang/perl/Method-Cached/trunk

Files:

• MANIFEST (modified) (2 diffs)
• lib/Method/Cached.pm (modified) (2 diffs)
• lib/Method/Cached/ArgsEncoder.pm (deleted)
• lib/Method/Cached/Domain.pm (modified) (4 diffs)
• lib/Method/Cached/Domain/Default.pm (modified) (1 diff)
• lib/Method/Cached/KeyRegularizer.pm (added)
• lib/Method/Cached/Manager.pm (modified) (2 diffs)
• lib/Method/Cached/MethodRegistry.pm (added)
• lib/Method/Cached/StorageInspector.pm (deleted)
• t/00_compile.t (deleted)
• t/01-basic.t (modified) (4 diffs)
• t/03-key_regularizer (added)
• t/97-boilerplate.t (moved) (moved from lang/perl/Method-Cached/trunk/t/97_boilerplate.t)
• t/98-perlcritic.t (moved) (moved from lang/perl/Method-Cached/trunk/t/98_perlcritic.t)
• t/99-pod.t (moved) (moved from lang/perl/Method-Cached/trunk/t/99_pod.t)
• t/benchmark.pl (added)

lang/perl/Method-Cached/trunk/MANIFEST

@@ -11 +11 @@
 inc/Test/More.pm
 lib/Method/Cached.pm
-lib/Method/Cached/ArgsEncoder.pm
 lib/Method/Cached/Domain.pm
 lib/Method/Cached/Domain/Default.pm
+lib/Method/Cached/KeyRegularizer.pm
 lib/Method/Cached/Manager.pm
-lib/Method/Cached/StorageInspector.pm
+lib/Method/Cached/MethodRegistry.pm
 Makefile.PL
 MANIFEST                        This list of files
@@ -21 +21 @@
 README
 t/00-load.t
-t/00_compile.t
 t/01-basic.t
 t/02-manager.t
+t/97-boilerplate.t
+t/98-perlcritic.t
+t/99-pod.t
+t/benchmark.pl

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

@@ -7 +7 @@
 use Method::Cached::Manager;
 
-our $VERSION = '0.01';
+our $VERSION = '0.0103';
 
 sub UNIVERSAL::Cached :ATTR(CODE) {
     my ($pkg, $symbol, $code, $options) = @_[0 .. 2, 4];
     $options = [ $options || () ] unless ref $options eq 'ARRAY';
-    my $method_name = $pkg . '::' . *{$symbol}{NAME};
+    my $name = $pkg . '::' . *{$symbol}{NAME};
     {
         no strict 'refs';
         no warnings 'redefine';
-        my ($domain_name, $expire, $keygen) = @{ $options };
-        Method::Cached::Manager->register_method($method_name, $domain_name);
-        *{$method_name} = sub {
-            my $domain = Method::Cached::Manager->get_domain($domain_name);
-            my $key    = $keygen && ref $keygen eq 'CODE'
-                ? $keygen->($method_name, @_)
-                : $domain->method_to_keygen->($method_name, @_);
-            my $ret    = $domain->storage->get($key);
+        my $domain_name = shift @{ $options };
+        Method::Cached::Manager->register_method($name, $domain_name, @{ $options });
+        *{$name} = sub {
+            my $domain = Method::Cached::Manager::_get_domain($domain_name);
+            my $key = $domain->regularize_key($name, @_);
+            my $ret = $domain->get($name, $key);
             return wantarray ? @{ $ret } : ${ $ret }[0] if $ret;
             my @ret = ($code->(@_));
-            $domain->storage->set($key, \@ret, defined $expire ? $expire : ());
+            $domain->set($name, $key, \@ret);
             return wantarray ? @ret : $ret[0];
         };
@@ -46 +44 @@
   use Method::Cached;
    
-  sub message :Cached('domain', 180) {
+  sub message :Cached('domain', 180, KEY_SERIAL) {
       my ($class, $param) = @_;
       sprintf 'Hello world! param(%s) at %s', $param || q{}, time

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

@@ -5 +5 @@
 use 5.008007;
 use base qw/Class::Data::Accessor/;
-use Carp qw/croak/;
+use Carp qw/croak confess/;
 use Scalar::Util qw/blessed/;
-use Method::Cached::ArgsEncoder;
-use Method::Cached::StorageInspector;
+use UNIVERSAL::require;
+use Method::Cached::KeyRegularizer;
+use Method::Cached::MethodRegistry;
 
-our $VERSION = '0.01';
+our $VERSION = '0.0103';
 
 __PACKAGE__->mk_classaccessor('storage');
-__PACKAGE__->mk_classaccessor('method_to_keygen' => \&__method_to_keygen);
-
-sub __method_to_keygen {
-    my $name = shift;
-    my $hash = Method::Cached::ArgsEncoder::encode_args(@_);
-    $name . $hash;
-}
+__PACKAGE__->mk_classaccessor('key_regularizer' => 'LIST');
 
 sub new {
@@ -25 +20 @@
     my %args  = (0 < @_ && ref $_[0] eq 'HASH') ? %{ $_[0] } : @_;
     my $self  = bless {}, $class;
-    my $storage_class    = exists $args{storage_class}    ? delete $args{storage_class}    : undef;
-    my $storage_args     = exists $args{storage_args}     ? delete $args{storage_args}     : undef;
-    my $method_to_keygen = exists $args{method_to_keygen} ? delete $args{method_to_keygen} : undef;
-    if ($storage_class) {
-        if (blessed $storage_class) {
-            $self->storage($storage_class);
+    my $storage_class   = $args{storage_class}   || croak 'storage_class is necessary';
+    my $storage_args    = $args{storage_args}    || undef;
+    my $key_regularizer = $args{key_regularizer} || undef;
+    if (blessed $storage_class) {
+        $self->storage($storage_class);
+    }
+    else {
+        unless (__inspect_storage_class($storage_class)) {
+            croak "storage_class needs the following methods: new, set, get, delete or remove";
         }
-        else {
-            if ($storage_args && ref $storage_args ne 'ARRAY') {
-                croak 'storage_args should be a array reference';
-            }
-            unless (Method::Cached::StorageInspector->inspect($storage_class)) {
-                croak Method::Cached::StorageInspector->message_necessary_methods;
-            }
-            $self->storage($storage_class->new(@{ $storage_args || [] }));
+        if ($storage_args && ref $storage_args ne 'ARRAY') {
+            croak 'storage_args should be a array reference';
         }
+        $self->storage($storage_class->new(@{ $storage_args || [] }));
     }
-    if ($method_to_keygen && ref $method_to_keygen eq 'CODE') {
-        $self->method_to_keygen($method_to_keygen);
-    }
+    $self->key_regularizer($key_regularizer) if $key_regularizer;
     $self;
+}
+
+sub regularize_key {
+    my ($self, $name, @args) = @_;
+    my $registry = Method::Cached::MethodRegistry::refer($name);
+    Method::Cached::KeyRegularizer->regularize(
+        $registry->{key_regularizer} || $self->key_regularizer || undef, 
+        $name,
+        @args,
+    );
+}
+
+sub get {
+    my ($self, $name, $key) = @_;
+    $self->storage->get($key);
+}
+
+sub set {
+    my ($self, $name, $key, $val) = @_;
+    my $registry = Method::Cached::MethodRegistry::refer($name);
+    $self->storage->set($key, $val, $registry ? $registry->{expires} : ());
+}
+
+sub __inspect_storage_class {
+    my $any_class = shift;
+    $any_class->require || confess "Can't load module: $any_class";
+    $any_class->can($_) || return for qw/new set get/;
+    $any_class->can('delete') || $any_class->can('remove') || return;
+    return 1;
 }
 
@@ -62 +82 @@
   my $domain = Method::Cached::Domain->new(
       # The supported interface is Cache::Cache and Cache::Memcached. 
-      storage_class    => 'Cache::Memcached::Fast',
-      storage_args     => [
+      storage_class   => 'Cache::Memcached::Fast',
+      storage_args    => [
           {
               servers         => [qw/ 127.0.0.1:11211 /],
@@ -71 +91 @@
           },
       ],
-      method_to_keygen => undef,
+      key_regularizer => undef,
   );
 

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

@@ -6 +6 @@
 use base qw/Method::Cached::Domain/;
 
-__PACKAGE__->mk_classaccessor('default_setting' => {
-    storage_class    => 'Cache::FastMmap',
-    storage_args     => [
+my $_setting = {
+    storage_class   => 'Cache::FastMmap',
+    storage_args    => [
         share_file     => '/tmp/fastmmap-sharefile.bin',
         unlink_on_exit => 0,
     ],
-    method_to_keygen => undef,
-});
+    key_regularizer => 'LIST',
+};
+
+sub setting { 1 < @_ ? ($_setting = $_[1]) : $_setting }
 
 sub new {
     my $class = shift;
     my %args  = (0 < @_ && ref $_[0] eq 'HASH') ? %{ $_[0] } : @_;
-    $class->SUPER::new(%{ $class->default_setting }, %args);
+    $class->SUPER::new(%{ $class->setting }, %args);
 }
 

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

@@ -4 +4 @@
 use warnings;
 use 5.008007;
-use base qw/Class::Data::Accessor/;
 use Carp qw/croak/;
 use Scalar::Util qw/blessed/;
 use Method::Cached::Domain;
 use Method::Cached::Domain::Default;
+use Method::Cached::MethodRegistry;
 
-our $VERSION = '0.01';
+our $VERSION = '0.0103';
 
-__PACKAGE__->mk_classaccessor('domains' => {});
-__PACKAGE__->mk_classaccessor('map_to_domain' => {});
-__PACKAGE__->mk_classaccessor('default_domain');
+my %_domains;
+my $_default_domain;
 
 sub import {
@@ -25 +24 @@
 }
 
-sub get_domain {
-    my ($class, $name) = @_;
-    my $domain;
-    if (defined $name && length $name) {
-        $domain = $class->domains->{$name};
-        return $domain if $domain;
-    }
-    $domain = $class->default_domain;
-    unless ($domain) {
-        require Method::Cached::Domain::Default;
-        $class->default_domain($domain = Method::Cached::Domain::Default->new);
-    }
-    $domain;
-}
-
 sub set_domain {
     my $class = shift;
     while (my ($name, $args) = splice @_, 0, 2) {
-        $class->domains->{$name} =
-            (blessed $args && $args->isa('Method::Cached::Domain'))
-                ? $args
-                : Method::Cached::Domain->new($args);
+        $_domains{$name} = (blessed $args && $args->isa('Method::Cached::Domain'))
+           ? $args
+           : Method::Cached::Domain->new($args);
     }
+}
+
+sub get_domain {
+    my ($class, $name) = @_;
+    _get_domain($name);
+}
+
+sub _get_domain {
+    defined $_[0] && $_domains{$_[0]} && return $_domains{$_[0]};
+    $_default_domain ||= Method::Cached::Domain::Default->new;
 }
 
 sub default_domain {
     my $class = shift;
-    if (0 < @_) {
-        $class->default_domain(Method::Cached::Domain::Default->new(@_));
-    }
-    else {
-        Method::Cached::Domain->default_setting;
-    }
+    $_default_domain ||= Method::Cached::Domain::Default->new(@_);
 }
 
 sub register_method {
-    my ($class, $method_name, $name) = @_;
-    $class->map_to_domain->{$method_name} = $name;
-}
-
-sub delete {
+    my $class = shift;
+    Method::Cached::MethodRegistry::register(@_);
 }
 

lang/perl/Method-Cached/trunk/t/01-basic.t

@@ -8 +8 @@
     package Dummy::Basic;
     use Method::Cached;
-    sub message : Cached {
+    sub message : Cached(undef, 0, LIST) {
         my ($args) = @_;
         sprintf
             'Nobody understands why to do such a thing. param(%s), rand(%s)',
-            $args || q{}, rand
+            $args || q{}, time
     }
 
@@ -18 +18 @@
     use Method::Cached;
     sub new { bless {}, shift }
-    sub message : Cached {
+    sub message : Cached(undef, 0, STRUCTURE) {
         my ($self, $args) = @_;
         sprintf
@@ -27 +27 @@
 }
 
-my $rand1 = Dummy::Basic::message(1);
-my $rand2 = Dummy::Basic::message(1);
+my $rand1 = Dummy::Basic::message('abc', 1, {});
+my $rand2 = Dummy::Basic::message('abc', 1, {});
 
 ok $rand1 eq $rand2, 'message is same';
 
-my $rand3 = Dummy::Basic::message(0);
+my $rand3 = Dummy::Basic::message('def', { word => 99 });
 
 ok $rand1 ne $rand3, 'message is not same';
@@ -38 +38 @@
 my $obj   = Dummy::Object->new;
 
-my $rand4 = $obj->message('What is the meaning?');
-my $rand5 = $obj->message('What is the meaning?');
+my $rand4 = $obj->message({ a => 1, b => 2 });
+my $rand5 = $obj->message({ b => 2, a => 1 });
 
 ok $rand4 eq $rand5, 'message is same';