Changeset 20895 for lang/perl/Method-Cached/trunk/lib/Method/Cached2.pm

Timestamp:

10/07/08 15:48:46 (3 months ago)

Author:

bonnu

Message:

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

Files:

• lang/perl/Method-Cached/trunk/lib/Method/Cached2.pm (modified) (7 diffs)

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

@@ -6 +6 @@
 use Attribute::Handlers;
 use Carp qw/croak confess/;
-use Digest::SHA qw/sha1_base64/;
-use JSON::XS;
-use Storable qw/freeze/;
 use UNIVERSAL::require;
+use Method::Cached::KeyRule;
 
 our $VERSION = '0.0103';
 
-my %_domains;
-my $_default_domain = {
-    storage_class   => 'Cache::FastMmap',
-    storage_args    => [
-        share_file     => '/tmp/fastmmap-sharefile.bin',
+my %_DOMAINS;
+my $_DEFAULT_DOMAIN = {
+    storage_class => 'Cache::FastMmap',
+    storage_args  => [
+        share_file     => '/tmp/fastmmap.bin',
         unlink_on_exit => 0,
     ],
-    key_regularizer => 'LIST',
+    key_rule      => 'LIST',
 };
 
@@ -27 +25 @@
     $options = [ $options || () ] unless ref $options eq 'ARRAY';
     my $name = $pkg . '::' . *{$symbol}{NAME};
-    my ($domain_name, $expires, $regularizer) = _parse_option(@{ $options });
+    my ($domain_name, $expires, $key_rule) = _parse_option(@{ $options });
     no strict 'refs';
     no warnings 'redefine';
     *{$name} = sub {
-        my $domain = $_domains{$domain_name}
-            ? $_domains{$domain_name}
-            : $_default_domain;
-        $regularizer ||= $domain->{key_regularizer};
-        my $key = _regularize($regularizer, $name, @_);
+        my $domain = $_DOMAINS{$domain_name}
+            ? $_DOMAINS{$domain_name}
+            : $_DEFAULT_DOMAIN;
+        $key_rule ||= $domain->{key_rule};
+        my $key = Method::Cached::KeyRule::regularize($key_rule, $name, @_);
         my $storage = _storage($domain);
         my $ret = $storage->get($key);
@@ -53 +51 @@
     }
     if (exists $args{-default} && defined $args{-default}) {
-        my $domain = $args{-default};
-        ref $domain eq 'HASH' or croak '-default option should be a hash reference';
-        $class->default_domain($domain);
+        my $default = $args{-default};
+        ref $default eq 'HASH' or croak '-default option should be a hash reference';
+        $class->default_domain($default);
     }
 }
@@ -61 +59 @@
 sub default_domain {
     my $class = shift;
-    $_default_domain = {
-        %{ $_default_domain },
+    $_DEFAULT_DOMAIN = {
+        %{ $_DEFAULT_DOMAIN },
         %{ +shift },
     };
@@ -70 +68 @@
     my $class = shift;
     while (my ($name, $args) = splice @_, 0, 2) {
-        $_domains{$name} = $args;
+        if (exists $_DOMAINS{$name}) {
+            warn 'This domain has already been defined: ' . $name;
+            next;
+        }
+        $_DOMAINS{$name} = $args;
     }
 }
@@ -77 +79 @@
     my $domain_name = ($_[0] =~ /^-?\d+$/) ? q{} : shift;
     my $expires     = shift || 0;
-    my $regularizer = shift || undef;
-    return ($domain_name, $expires, $regularizer);
-}
-
-sub _regularize {
-    my ($regularizer, $method_name) = splice @_, 0, 2;
-    ref $regularizer && return $regularizer->($method_name, @_);
-    no strict 'refs';
-    $regularizer ||= 'LIST';
-    return $method_name . &{$regularizer}(@_);
+    my $key_rule    = shift || undef;
+    return ($domain_name, $expires, $key_rule);
 }
 
@@ -98 +92 @@
 }
 
-sub LIST {
-    my $method_name = shift;
-    local $^W = 0;
-    join chr(28), @_;
-}
-
-sub SERIALIZE {
-    my $method_name = shift;
-    local $^W = 0;
-    our $ENCODER ||= JSON::XS->new->convert_blessed(1);
-    *UNIVERSAL::TO_JSON = sub { freeze \@_ };
-    my $json = $ENCODER->encode(\@_);
-    undef *UNIVERSAL::TO_JSON;
-    sha1_base64($json);
-}
-
 1;