├── .gitignore ├── .shipit ├── Changes ├── MANIFEST.SKIP ├── Makefile.PL ├── README ├── lib └── Cache │ └── Memcached │ └── IronPlate.pm ├── t ├── 00_compile.t └── 01_basic.t └── xt ├── 01_podspell.t ├── 01_podspell.t~ ├── 02_perlcritic.t ├── 03_pod.t └── perlcriticrc /.gitignore: -------------------------------------------------------------------------------- 1 | cover_db 2 | META.yml 3 | Makefile 4 | blib 5 | inc 6 | pm_to_blib 7 | MANIFEST 8 | Makefile.old 9 | nytprof.out 10 | MANIFEST.bak 11 | *.sw[po] 12 | -------------------------------------------------------------------------------- /.shipit: -------------------------------------------------------------------------------- 1 | steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN 2 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Cache::Memcached::IronPlate 2 | 3 | 0.01 Tue Feb 22 18:03:52 2011 4 | - original version 5 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \bRCS\b 2 | \bCVS\b 3 | ^MANIFEST\. 4 | ^Makefile$ 5 | ~$ 6 | ^# 7 | \.old$ 8 | ^blib/ 9 | ^pm_to_blib 10 | ^MakeMaker-\d 11 | \.gz$ 12 | \.cvsignore 13 | ^t/9\d_.*\.t 14 | ^t/perlcritic 15 | ^tools/ 16 | \.svn/ 17 | ^[^/]+\.yaml$ 18 | ^[^/]+\.pl$ 19 | ^\.shipit$ 20 | ^\.git/ 21 | \.sw[po]$ 22 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use inc::Module::Install; 2 | name 'Cache-Memcached-IronPlate'; 3 | all_from 'lib/Cache/Memcached/IronPlate.pm'; 4 | 5 | requires 'List::Util'; 6 | requires 'Scalar::Util'; 7 | requires 'Storable'; 8 | requires 'POSIX'; 9 | requires 'Encode'; 10 | requires 'overload'; 11 | 12 | tests 't/*.t'; 13 | author_tests 'xt'; 14 | 15 | test_requires 'Test::More'; 16 | test_requires 'Test::TCP'; 17 | test_requires 'Test::Skip::UnlessExistsExecutable'; 18 | test_requires 'Cache::Memcached::Fast'; 19 | test_requires 'File::Which'; 20 | test_requires 'Proc::Guard'; 21 | 22 | auto_set_repository; 23 | WriteAll; 24 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is Perl module Cache::Memcached::IronPlate. 2 | 3 | INSTALLATION 4 | 5 | Cache::Memcached::IronPlate installation is straightforward. If your CPAN shell is set up, 6 | you should just be able to do 7 | 8 | % cpan Cache::Memcached::IronPlate 9 | 10 | Download it, unpack it, then build it as per the usual: 11 | 12 | % perl Makefile.PL 13 | % make && make test 14 | 15 | Then install it: 16 | 17 | % make install 18 | 19 | DOCUMENTATION 20 | 21 | Cache::Memcached::IronPlate documentation is available as in POD. So you can do: 22 | 23 | % perldoc Cache::Memcached::IronPlate 24 | 25 | to read the documentation online with your favorite pager. 26 | 27 | Masahiro Nagano 28 | -------------------------------------------------------------------------------- /lib/Cache/Memcached/IronPlate.pm: -------------------------------------------------------------------------------- 1 | package Cache::Memcached::IronPlate; 2 | 3 | use strict; 4 | use warnings; 5 | use Carp qw//; 6 | use URI::Escape; 7 | use Digest::MD5; 8 | use Storable; 9 | use Scalar::Util qw/blessed/; 10 | use List::Util qw//; 11 | use POSIX qw//; 12 | use Encode; 13 | use overload; 14 | 15 | our $VERSION = '0.01'; 16 | 17 | sub new { 18 | my $class = shift; 19 | my %args = ( 20 | distribution_num => 20, 21 | duplication_num => 3, 22 | @_ 23 | ); 24 | Carp::croak('cache value should be object.') unless blessed $args{cache}; 25 | # $args{distribution_id} = int(rand($args{distribution_num})) + 1; 26 | bless \%args, $class; 27 | } 28 | 29 | sub _is_distribution { 30 | my $key = shift; 31 | return unless $key; 32 | $key =~ m/:dist$/; 33 | } 34 | 35 | sub _is_duplication { 36 | my $key = shift; 37 | return unless $key; 38 | $key =~ m/:dup$/; 39 | } 40 | 41 | sub _safekey { 42 | my $key = shift; 43 | Carp::croak 'no key' unless $key; 44 | 45 | if ( ref $key ) { 46 | if ( blessed($key) && (my $stringify = overload::Method( $key, '""' )) ) { 47 | $key = $stringify->($key); 48 | } 49 | else { 50 | $key = Digest::MD5::md5_hex( Storable::nfreeze($key) ); 51 | } 52 | } 53 | 54 | $key = Encode::encode_utf8($key) if Encode::is_utf8($key); 55 | 56 | my $suffix=''; 57 | if ( $key =~ m!(.*)(:dist|:dup)$! ) { 58 | $key = $1; 59 | $suffix = $2; 60 | } 61 | $key = uri_escape($key,"\x00-\x20\x7f-\xff"); 62 | if ( length($key) > 200 ) { 63 | $key = Digest::MD5::md5_hex($key); 64 | } 65 | $key .= $suffix; 66 | return $key; 67 | } 68 | 69 | sub get { 70 | my $self = shift; 71 | my $key = _safekey(shift); 72 | if ( _is_distribution($key) ) { 73 | my $rand = int(rand($self->{distribution_num})) + 1; 74 | $key .= ":" . $rand; 75 | } 76 | elsif ( _is_duplication($key) ) { 77 | return $self->_get_duplicate($key); 78 | } 79 | $self->{cache}->get( $key ); 80 | } 81 | 82 | sub _get_duplicate { 83 | my $self = shift; 84 | my $key = shift; 85 | 86 | my $check_num = POSIX::ceil( $self->{duplication_num} / 2 ); 87 | 88 | my @keys = map { $key . ":$_" } 1..$self->{duplication_num}; 89 | my $result = $self->{cache}->get_multi(@keys); 90 | 91 | my %result; 92 | map { $result{$_}++ } values %$result; 93 | List::Util::reduce { $result{$a} > $result{$b} ? $a : $b } grep { $result{$_} >= $check_num } keys %result; 94 | } 95 | 96 | sub get_multi { 97 | my $self = shift; 98 | 99 | my @keys; 100 | my @duplicate_keys; 101 | my %safekey; 102 | foreach my $key ( @_ ) { 103 | Carp::croak 'undefined key' if ! defined $key; 104 | 105 | my $safekey = _safekey($key); 106 | my $rand = int(rand($self->{distribution_num})) + 1; 107 | $safekey .= ":" . $rand if _is_distribution($safekey); 108 | $safekey{$safekey} = $key; 109 | 110 | if ( _is_duplication($safekey) ) { 111 | push @duplicate_keys, $safekey; 112 | next; 113 | } 114 | 115 | push @keys, $safekey; 116 | } 117 | 118 | my $memd = $self->{cache}; 119 | 120 | my %result; 121 | while( my @spliced_keys = splice( @keys, 0, 1000 ) ) { 122 | my $result = $memd->get_multi(@spliced_keys); 123 | %result = ( %result, %$result ); 124 | } 125 | 126 | my %back_safekey; 127 | foreach (keys %result ) { 128 | $back_safekey{ $safekey{$_} } = $result{$_}; 129 | } 130 | 131 | foreach my $duplicate_key ( @duplicate_keys ) { 132 | my $result = $self->_get_duplicate($duplicate_key); 133 | $back_safekey{ $safekey{$duplicate_key} } = $result if defined $result; 134 | } 135 | 136 | \%back_safekey; 137 | } 138 | 139 | sub set { 140 | my $self = shift; 141 | my $key = _safekey(shift); 142 | my $memd = $self->{cache}; 143 | if ( _is_distribution($key) ) { 144 | for ( 1..$self->{distribution_num} ) { 145 | my $spread_key = $key . ":" . $_; 146 | $memd->set($spread_key, @_); 147 | } 148 | return 1; 149 | } 150 | elsif ( _is_duplication($key) ) { 151 | for ( 1..$self->{duplication_num} ) { 152 | my $spread_key = $key . ":" . $_; 153 | $memd->set($spread_key, @_); 154 | } 155 | return 1; 156 | } 157 | $memd->set( $key, @_ ); 158 | } 159 | 160 | sub add { 161 | my $self = shift; 162 | my $key = _safekey(shift); 163 | if ( _is_distribution($key) || _is_duplication($key) ) { 164 | Carp::croak 'distribution/duplication keys are not suppoted in "add"'; 165 | } 166 | $self->{cache}->add( $key, @_ ); 167 | } 168 | 169 | sub replace { 170 | my $self = shift; 171 | my $key = _safekey(shift); 172 | if ( _is_distribution($key) || _is_duplication($key) ) { 173 | Carp::croak 'distribution/duplication keys are not suppoted in "replace"'; 174 | } 175 | $self->{cache}->replace( $key, @_ ); 176 | } 177 | 178 | sub append { 179 | my $self = shift; 180 | my $key = _safekey(shift); 181 | if ( _is_distribution($key) || _is_duplication($key) ) { 182 | Carp::croak 'distribution/duplication keys are not suppoted in "append"'; 183 | } 184 | $self->{cache}->append( $key, @_ ); 185 | } 186 | 187 | sub prepend { 188 | my $self = shift; 189 | my $key = _safekey(shift); 190 | if ( _is_distribution($key) || _is_duplication($key) ) { 191 | Carp::croak 'distribution/duplication keys are not suppoted in "prepend"'; 192 | } 193 | $self->{cache}->prepend( $key, @_ ); 194 | } 195 | 196 | sub incr { 197 | my $self = shift; 198 | my $key = _safekey(shift); 199 | if ( _is_distribution($key) || _is_duplication($key) ) { 200 | Carp::croak 'distribution/duplication keys are not suppoted in "incr"'; 201 | } 202 | $self->{cache}->incr( $key, @_ ); 203 | } 204 | 205 | sub counter { 206 | my $self = shift; 207 | my $key = _safekey(shift); 208 | if ( _is_distribution($key) || _is_duplication($key) ) { 209 | Carp::croak 'distribution/duplication keys are not suppoted in "counter"'; 210 | } 211 | 212 | my $memd = $self->{cache}; 213 | my $result = $memd->incr( $key, @_ ); 214 | if ( defined $result && ! $result ) { 215 | my $init = shift || 1; 216 | # incr/decr operations are not thread safe 217 | # http://code.google.com/p/memcached/issues/detail?id=172 218 | $memd->add($key, sprintf("%-20d", 0), @_ ); 219 | $result = $memd->incr($key, $init, @_ ); 220 | } 221 | $result; 222 | } 223 | 224 | sub decr { 225 | my $self = shift; 226 | my $key = _safekey(shift); 227 | if ( _is_distribution($key) || _is_duplication($key) ) { 228 | Carp::croak 'distribution/duplication keys are not suppoted in "decr"'; 229 | } 230 | $self->{cache}->decr( $key, @_ ); 231 | } 232 | 233 | sub delete { 234 | my $self = shift; 235 | my $key = _safekey(shift); 236 | my $memd = $self->{cache}; 237 | if ( _is_distribution($key) ) { 238 | for ( 1..$self->{distribution_num} ) { 239 | my $spread_key = $key . ":" . $_; 240 | $memd->delete($spread_key); 241 | } 242 | return 1; 243 | } 244 | elsif ( _is_duplication($key) ) { 245 | for ( 1..$self->{duplication_num} ) { 246 | my $spread_key = $key . ":" . $_; 247 | $memd->delete($spread_key); 248 | } 249 | return 1; 250 | } 251 | $memd->delete($key); 252 | } 253 | 254 | *remove = \&delete; 255 | 256 | 257 | 1; 258 | __END__ 259 | 260 | =head1 NAME 261 | 262 | Cache::Memcached::IronPlate - Best practices for Cache::Memcached 263 | 264 | =head1 SYNOPSIS 265 | 266 | use Cache::Memcached::IronPlate; 267 | use Cache::Memcached::Fast; 268 | 269 | my $memd = Cache::Memcached::IronPlate->new( 270 | cache => Cache::Memcached::Fast->new(...). 271 | ); 272 | $memd->get 273 | $memd->get_multi 274 | $memd->set 275 | $memd->add 276 | $memd->replace 277 | $memd->append 278 | $memd->prepend 279 | $memd->incr 280 | $memd->counter 281 | $memd->decr 282 | $memd->delete 283 | 284 | =head1 DESCRIPTION 285 | 286 | Cache::Memcached::IronPlate is best practices for Cache::Memcached(::Fast) 287 | 288 | =head1 FEATURES 289 | 290 | =over 4 291 | 292 | =item Auto key filter 293 | 294 | マルチバイトや制御コードがkeyに含まれている場合、それらをURI Escapeして利用します 295 | 296 | $memd->get("key hoge\n") => get("key%20hoge%0A") 297 | 298 | キーが250文字以上の場合は、Digest::MD5でhash値を作り利用します。またオブジェクトの場合はSerializeしてkeyとします 299 | 300 | =item キャッシュ分散 301 | 302 | 設定情報など、比較的変化が少なく、多くのページで読まれるキャッシュは自動的に分散をします 303 | 分散するkeyには「:dist」を付加します 304 | 305 | $memd->set("mypref:dist") 306 | 307 | 内部的には、:common:${num} などとさらにキーを追加して、分散されるようにします。 308 | ${num}はデフォルト20です。変更するには、インスタンス作成時に distribution_num を設定します 309 | 310 | my $memd = Cache::Memcached::IronPlate->new( 311 | distribution_num => 30 312 | ); 313 | 314 | キャッシュ拡散の機能は、setとget、get_multi、deleteにのみ有効です。他のメソッドに対して:commonが付いたキーを渡すと 315 | 例外となります 316 | 317 | =item キャッシュ複製 318 | 319 | 特定のmemcachedサーバに接続ができない状態になるとセッションが作成できず、 320 | 特定のユーザのみログインができないなどの状態がおこります。 321 | keyの名前に「:dup」を付与すると、distribution と同じように自動的にキャッシュを複製します。 322 | 323 | 内部的には、:dup:${num} などとさらにキーを追加して、複製されるようにします。 324 | ${num}はデフォルト3です。インスタンス作成時に duplication_num を設定します 325 | 326 | my $memd = Cache::Memcached::IronPlate->new( 327 | duplication_num => 30 328 | ); 329 | 330 | キャッシュ拡散と異なるのは、キャッシュ取得時に複製したデータを全て取得し、duplication_num の過半数 331 | に達した場合のみ、データを返す事です。大きなキャッシュデータの場合は通信量に影響がでるので注意してください 332 | 333 | キャッシュ複製の機能は、setとget、get_multi、deleteにのみ有効です。他のメソッドに対して:commonが付いたキーを渡すと 334 | 例外となります 335 | 336 | =item カウンター 337 | 338 | memcached の increment は指定した値がない場合、動作しません。IronPlateのcounterは自動で初期値をaddします。 339 | 340 | =back 341 | 342 | =head1 METHODS 343 | 344 | =over 4 345 | 346 | =item get(key[:common]) 347 | 348 | =item get_multi(key1,key2,key3).. 349 | 350 | get_mulitiに1,000個以上のkeyを渡した場合は、内部的に1000個ごとに分割して処理をします 351 | キャッシュ拡散、複製のkeyも使えます。 352 | 353 | =item set(key, value, expires) 354 | 355 | =item add(key, value, expires) 356 | 357 | =item replace(key, value, expires) 358 | 359 | =item incr(key, increment) 360 | 361 | =item counter(key, increment, expires) 362 | 363 | =item delete(key) 364 | 365 | deleteのexpiresはmemcached-1.3.2以降でサポートされなくなったので 366 | 何かしらの値が後ろに付いていても無視します 367 | 368 | =back 369 | 370 | =head1 AUTHOR 371 | 372 | Masahiro Nagano Ekazeburo {at} gmail.comE 373 | 374 | =head1 SEE ALSO 375 | 376 | =head1 LICENSE 377 | 378 | This library is free software; you can redistribute it and/or modify 379 | it under the same terms as Perl itself. 380 | 381 | =cut 382 | -------------------------------------------------------------------------------- /t/00_compile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 1; 3 | 4 | BEGIN { use_ok 'Cache::Memcached::IronPlate' } 5 | -------------------------------------------------------------------------------- /t/01_basic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | 4 | use Test::TCP qw/empty_port wait_port/; 5 | use Test::Skip::UnlessExistsExecutable; 6 | use File::Which qw(which); 7 | use Proc::Guard; 8 | 9 | use URI; 10 | use Cache::Memcached::IronPlate; 11 | use Cache::Memcached::Fast; 12 | 13 | skip_all_unless_exists 'memcached'; 14 | 15 | my @memcached; 16 | for ( 1..5 ) { 17 | my $port = empty_port(); 18 | my $proc = proc_guard( scalar which('memcached'), '-p', $port, '-U', 0, '-l', '127.0.0.1' ); 19 | wait_port($port); 20 | push @memcached, { proc => $proc, port => $port }; 21 | } 22 | 23 | my $cache = Cache::Memcached::Fast->new({ 24 | servers => [map { "localhost:" . $_->{port} } @memcached] 25 | }); 26 | 27 | my $memd = Cache::Memcached::IronPlate->new( 28 | cache => $cache 29 | ); 30 | 31 | ok( $memd->set('var1','bar1') ); 32 | is( $memd->get('var1'), 'bar1' ); 33 | 34 | ok( $memd->set("v a\nr\t1",'bar1') ); 35 | is( $memd->get("v a\nr\t1"), 'bar1' ); 36 | is( $memd->get("v%20a%0Ar%091"), 'bar1' ); 37 | 38 | ok( $memd->set("spread:dist",'spreadval' ) ); 39 | is( $memd->get("spread:dist"), 'spreadval' ); 40 | is( $memd->get("spread:dist:1"), 'spreadval', 'sg1' ); 41 | is( $memd->get("spread:dist:2"), 'spreadval', 'sg2' ); 42 | is( $memd->get("spread:dist:3"), 'spreadval', 'sg3' ); 43 | 44 | ok( $memd->set("spread:dup",'dupval' ) ); 45 | is( $memd->get("spread:dup"), 'dupval' ); 46 | is( $memd->get("spread:dup:1"), 'dupval', 'dg1' ); 47 | is( $memd->get("spread:dup:2"), 'dupval', 'dg2' ); 48 | is( $memd->get("spread:dup:3"), 'dupval', 'dg3' ); 49 | ok( $memd->delete("spread:dup:1") ); 50 | is( $memd->get("spread:dup"), 'dupval' ); 51 | ok( $memd->delete("spread:dup:2") ); 52 | ok( ! $memd->get("spread:dup") ); 53 | ok( $memd->delete("spread:dup") ); 54 | ok( ! $memd->get("spread:dup:3") ); 55 | ok( $memd->set("spread:dup",'dupval2' ) ); 56 | 57 | ok( $memd->set("x"x512,'longkey' ) ); 58 | is( $memd->get("x"x512), 'longkey' ); 59 | 60 | ok( $memd->set("x"x512 . ":dist",'long distribute key' ) ); 61 | is( $memd->get("x"x512 . ":dist"), 'long distribute key' ); 62 | 63 | { 64 | my $flaged = "\x{3042}"x100; 65 | ok( $memd->set($flaged ,'long utf8 key' ) ); 66 | is( $memd->get($flaged) ,'long utf8 key' ); 67 | } 68 | 69 | for my $method ( qw/add replace append prepend incr counter decr/ ) { 70 | eval { 71 | $memd->$method("test:dist", 1); 72 | }; 73 | ok($@); 74 | 75 | eval { 76 | $memd->$method("test:dup", 1); 77 | }; 78 | ok($@); 79 | } 80 | 81 | is( $memd->counter("counter1", 1, 2), 1 ); 82 | is( $memd->counter("counter1", 1, 2), 2 ); 83 | 84 | is( $memd->counter("counter2"), 1 ); 85 | is( $memd->counter("counter2"), 2 ); 86 | is( $memd->counter("counter2"), 3 ); 87 | 88 | my $hashref = { a => "b" }; 89 | ok( $memd->add($hashref,'reference' ) ); 90 | is( $memd->get($hashref), 'reference' ); 91 | 92 | my $uri = URI->new("http://www.google.com/"); 93 | ok( $memd->add($uri,'stringify object' ) ); 94 | is( $memd->get("$uri"), 'stringify object' ); 95 | 96 | 97 | sleep 3; 98 | 99 | is_deeply( $memd->get_multi( 100 | 'var1', 101 | "v a\nr\t1", 102 | "spread:dist", 103 | "spread:dup", 104 | "counter1", 105 | "x"x512, 106 | $hashref, 107 | ), { 108 | 'var1' => 'bar1', 109 | "v a\nr\t1" => 'bar1', 110 | "spread:dist" => 'spreadval', 111 | "spread:dup" => 'dupval2', 112 | "x"x512 => 'longkey', 113 | $hashref => 'reference', 114 | } ); 115 | 116 | ok( $memd->delete("spread:dist" ) ); 117 | ok( ! $memd->get("spread:dist:1") ); 118 | ok( ! $memd->get("spread:dist:2") ); 119 | ok( ! $memd->get("spread:dist:3") ); 120 | ok( ! $memd->get("spread:dist") ); 121 | 122 | $memd->can('remove'); 123 | 124 | 125 | 126 | subtest 'cache args required' => sub { 127 | eval { Cache::Memcached::IronPlate->new() } ; 128 | like($@ ,qr/^cache value should be object/); 129 | }; 130 | 131 | 132 | done_testing(); 133 | -------------------------------------------------------------------------------- /xt/01_podspell.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval q{ use Test::Spelling }; 3 | plan skip_all => "Test::Spelling is not installed." if $@; 4 | add_stopwords(map { split /[\s\:\-]/ } ); 5 | $ENV{LANG} = 'C'; 6 | set_spell_cmd("aspell -l en list") if `which aspell`; 7 | all_pod_files_spelling_ok('lib'); 8 | __DATA__ 9 | Masahiro Nagano 10 | kazeburo {at} gmail.com 11 | Cache::Memcached::IronPlate 12 | memcached 13 | -------------------------------------------------------------------------------- /xt/01_podspell.t~: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval q{ use Test::Spelling }; 3 | plan skip_all => "Test::Spelling is not installed." if $@; 4 | add_stopwords(map { split /[\s\:\-]/ } ); 5 | $ENV{LANG} = 'C'; 6 | all_pod_files_spelling_ok('lib'); 7 | __DATA__ 8 | Masahiro Nagano 9 | kazeburo {at} gmail.com 10 | Cache::Memcached::IronPlate 11 | -------------------------------------------------------------------------------- /xt/02_perlcritic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | eval { 4 | require Test::Perl::Critic; 5 | Test::Perl::Critic->import( -profile => 'xt/perlcriticrc'); 6 | }; 7 | plan skip_all => "Test::Perl::Critic is not installed." if $@; 8 | all_critic_ok('lib'); 9 | -------------------------------------------------------------------------------- /xt/03_pod.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval "use Test::Pod 1.00"; 3 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 4 | all_pod_files_ok(); 5 | -------------------------------------------------------------------------------- /xt/perlcriticrc: -------------------------------------------------------------------------------- 1 | [TestingAndDebugging::ProhibitNoStrict] 2 | allow=refs 3 | --------------------------------------------------------------------------------