File Coverage

blib/lib/Cache/Memcached/Fast/Safe.pm
Criterion Covered Total %
statement 36 97 37.1
branch 0 10 0.0
condition 0 3 0.0
subroutine 12 19 63.1
pod 2 2 100.0
total 50 131 38.1


line stmt bran cond sub pod time code
1             package Cache::Memcached::Fast::Safe;
2              
3 3     3   309916 use strict;
  3         5  
  3         105  
4 3     3   17 use warnings;
  3         4  
  3         111  
5 3     3   3249 use Cache::Memcached::Fast 0.19;
  3         14528  
  3         97  
6 3     3   2698 use URI::Escape::XS qw/uri_escape/;
  3         11649  
  3         286  
7 3     3   7163 use Digest::SHA qw/sha1_hex/;
  3         14839  
  3         304  
8 3     3   10116 use parent qw/Cache::Memcached::Fast/;
  3         361  
  3         23  
9 3     3   2685 use POSIX::AtFork;
  3         2060  
  3         323  
10 3     3   20 use Scalar::Util qw/weaken/;
  3         6  
  3         901  
11              
12             our $VERSION = '0.04';
13             our $SANITIZE_METHOD = sub {
14             my $key = shift;
15             $key = uri_escape($key,"\x00-\x20\x7f-\xff");
16             if ( length $key > 200 ) {
17             $key = sha1_hex($key);
18             }
19             $key;
20             };
21              
22             sub new {
23 0     0 1   my $class = shift;
24 0 0         my %args = ref $_[0] ? %{$_[0]} : @_;
  0            
25 0           my $mem = $class->SUPER::new(\%args);
26             # fork safe
27 0           weaken(my $mem_weaken = $mem);
28             POSIX::AtFork->add_to_child(sub {
29 0     0     eval { $mem_weaken->disconnect_all };
  0            
30 0           });
31 0           $mem;
32             }
33              
34             for my $method ( qw/set cas add replace append prepend incr decr delete/ ) {
35 3     3   19 no strict 'refs';
  3         7  
  3         540  
36             my $super = 'SUPER::'.$method;
37             *{$method} = sub {
38 0     0     my $self = shift;
39 0           my $key = shift;
40 0           $self->$super($SANITIZE_METHOD->($key), @_);
41             };
42             }
43             for my $method (qw/set_multi cas_multi add_multi replace_multi append_multi prepend_multi incr_multi decr_multi delete_multi/ ) {
44 3     3   38 no strict 'refs';
  3         5  
  3         867  
45             my $super = 'SUPER::'.$method;
46             *{$method} = sub {
47 0     0     my $self = shift;
48 0           my @request = @_;
49 0           my @request_keys;
50             my %sanitized_keys;
51 0           my @sanitized_request;
52 0           for my $keyval (@request) {
53 0           my $key;
54             my $sanitized_key;
55 0           my $sanitized_keyval;
56 0 0         if ( ref $keyval ) {
57 0           my @keyval = @$keyval;
58 0           $key = shift @keyval;
59 0           $sanitized_key = $SANITIZE_METHOD->($key);
60 0           $sanitized_keyval = [$sanitized_key, @keyval];
61             }
62             else {
63 0           $key = $keyval;
64 0           $sanitized_key = $SANITIZE_METHOD->($key);
65 0           $sanitized_keyval = $sanitized_key
66             }
67 0           $sanitized_keys{$sanitized_key} = $key;
68 0           push @request_keys, $key;
69 0           push @sanitized_request, $sanitized_keyval;
70             }
71 0           my $sanitized_result = $self->$super(@sanitized_request);
72 0           my %result;
73 0           for my $key ( keys %$sanitized_result ) {
74 0           $result{$sanitized_keys{$key}} = $sanitized_result->{$key};
75             }
76 0 0         if ( wantarray ) {
77 0           my @result;
78 0           for my $key ( @request_keys ) {
79 0           push @result, $result{$key};
80             }
81 0           return @result;
82             }
83 0           \%result;
84             }
85             }
86              
87             *remove = \&delete;
88              
89             for my $method (qw/get gets/) {
90 3     3   15 no strict 'refs';
  3         3  
  3         271  
91             my $super = 'SUPER::'.$method;
92             *{$method} = sub {
93 0     0     my $self = shift;
94 0           my $key = shift;
95 0           $self->$super($SANITIZE_METHOD->($key));
96             };
97             }
98             for my $method (qw/get_multi gets_multi/) {
99 3     3   13 no strict 'refs';
  3         5  
  3         995  
100             my $super = 'SUPER::'.$method;
101             *{$method} = sub {
102 0     0     my $self = shift;
103 0           my @request;
104             my %sanitized_keys;
105 0           for my $key (@_) {
106 0           my $sanitized_key = $SANITIZE_METHOD->($key);
107 0           $sanitized_keys{$sanitized_key} = $key;
108 0           push @request, $sanitized_key;
109             }
110 0 0         return {} if ! @request;
111 0           my $sanitized_result = $self->$super(@request);
112 0           my %result;
113 0           for my $key ( keys %$sanitized_result ) {
114 0           $result{$sanitized_keys{$key}} = $sanitized_result->{$key};
115             }
116 0           \%result;
117             }
118             }
119              
120             sub get_or_set {
121 0     0 1   my($self, $key, $sub, $expire) = @_;
122 0 0         if (my $value = $self->get($key)) {
123 0           return $value;
124             }
125 0           my ($value, $ret_expire) = $sub->();
126 0   0       $self->set($key, $value, $expire || $ret_expire);
127 0           $value;
128             }
129              
130             1;
131              
132             __END__