This file is indexed.

/usr/share/perl5/Cache/Memory.pm is in libcache-perl 2.11-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
=head1 NAME

Cache::Memory - Memory based implementation of the Cache interface

=head1 SYNOPSIS

  use Cache::Memory;

  my $cache = Cache::Memory->new( namespace => 'MyNamespace',
                                  default_expires => '600 sec' );

See Cache for the usage synopsis.

=head1 DESCRIPTION

The Cache::Memory class implements the Cache interface.  This cache stores
data on a per-process basis.  This is the fastest of the cache
implementations, but is memory intensive and data can not be shared between
processes.  It also does not persist after the process dies.  However data will
remain in the cache until cleared or it expires.  The data will be shared
between instances of the cache object, a cache object going out of scope will
not destroy the data.

=cut
package Cache::Memory;

require 5.006;
use strict;
use warnings;
use Heap::Fibonacci;
use Cache::Memory::HeapElem;
use Cache::Memory::Entry;

use base qw(Cache);
use fields qw(namespace);

our $VERSION = '2.11';


# storage for all data
# data is stored in the form:
#   $Store{ns}{key}{data,exp_elem,age_elem,use_elem,rc,validity,handlelock}
#
# Cache::Memory::Entry elements will be passed the final hash as a reference
# when they are constructed.  This reference MUST point to the SAME hash for
# all entries (and also must be the hash in Store{ns}{key}) or data
# inconsistency will occur.  However this means that the key has to persist in
# the store whilst entries exist - regardless of whether there is data stored
# in it or not.  In order to allow the Store{ns}{key} to be safely removed, a
# 'rc' field is used to track the number of entries that have been created for
# the key.
my %Store;

# store sizes
my %Store_Sizes;

# heaps for all the different orderings
# Expiry_Heap is shared between all namespaces
my Heap $Expiry_Heap = Heap::Fibonacci->new();
# In the form $Age_Heaps{namespace} and $Use_Heaps{namespace}
my %Age_Heaps;
my %Use_Heaps;


my $DEFAULT_NAMESPACE = '_';


=head1 CONSTRUCTOR

  my $cache = Cache::Memory->new( %options )

The constructor takes cache properties as named arguments, for example:

  my $cache = Cache::Memory->new( namespace => 'MyNamespace',
                                  default_expires => '600 sec' );

See 'PROPERTIES' below and in the Cache documentation for a list of all
available properties that can be set.

=cut

sub _init_ns_heaps {
    my ($self, $ns) = @_;

    $Age_Heaps{$ns} ||= Heap::Fibonacci->new();
    $Use_Heaps{$ns} ||= Heap::Fibonacci->new();

    return;
}

sub new {
    my Cache::Memory $self = shift;
    my $args = $#_? { @_ } : shift;

    $self = fields::new($self) unless ref $self;
    $self->SUPER::new($args);

    my $ns = $args->{namespace} || $DEFAULT_NAMESPACE;
    $self->{namespace} = $ns;

    $self->_init_ns_heaps($ns);

    return $self;
}

=head1 METHODS

See 'Cache' for the API documentation.

=cut

sub entry {
    my Cache::Memory $self = shift;
    my ($key) = @_;
    my $ns = $self->{namespace};

    $Store{$ns}{$key} ||= {};
    return Cache::Memory::Entry->new($self, $key, $Store{$ns}{$key});
}

sub purge {
    #my Cache::Memory $self = shift;
    my $time = time();
    while (my $minimum = $Expiry_Heap->minimum) {
        $minimum->val() <= $time
            or last;
        $Expiry_Heap->extract_minimum;

        my $min_key = $minimum->key();
        my $min_ns = $minimum->namespace();

        my $store_entry = $Store{$min_ns}{$min_key};

        $minimum == delete $store_entry->{exp_elem}
            or die 'Cache::Memory data structure(s) corrupted';

        # there should always be an age element
        my $age_elem = delete $store_entry->{age_elem}
            or die 'Cache::Memory data structure(s) corrupted';
        $Age_Heaps{$min_ns}->delete($age_elem);

        # there should always be a last use element
        my $use_elem = delete $store_entry->{use_elem}
            or die 'Cache::Memory data structure(s) corrupted';
        $Use_Heaps{$min_ns}->delete($use_elem);

        # remove data & decrease store size
        $Store_Sizes{$min_ns} -= length(${delete $store_entry->{data}});

        # remove entire entry if there are no active Entry objects
        delete $Store{$min_ns}{$min_key} unless $store_entry->{rc};
    }
}

sub clear {
    my Cache::Memory $self = shift;
    my $ns = $self->{namespace};

    # empty store & remove elements from expiry heap
    my $nsstore = $Store{$ns};
    foreach my $key (keys %$nsstore) {
        my $store_entry = $nsstore->{$key};

        # simplified form of remove (doesn't deal with heaps)
        my $exp_elem = delete $store_entry->{exp_elem};
        $Expiry_Heap->delete($exp_elem) if $exp_elem;
        delete $store_entry->{age_elem};
        delete $store_entry->{use_elem};
        delete $store_entry->{data};

        # remove entire entry if there are no active Entry objects
        delete $nsstore->{$key} unless $store_entry->{rc};
    }

    # reset store size
    $Store_Sizes{$ns} = 0;

    # recreate age and used heaps (thus emptying them)
    $self->_init_ns_heaps($ns);

    return;
}

sub count {
    my Cache::Memory $self = shift;
    my $count = 0;
    my $nsstore = $Store{$self->{namespace}};
    foreach my $key (keys %$nsstore) {
        $count++ if defined $nsstore->{$key}->{data};
    }
    return $count;
}

sub size {
    my Cache::Memory $self = shift;
    return $Store_Sizes{$self->{namespace}} || 0;
}


=head1 PROPERTIES

Cache::Memory adds the property 'namespace', which allows you to specify a
different caching store area to use from the default.  All methods will work
ONLY on the namespace specified.

 my $ns = $c->namespace();
 $c->set_namespace( $namespace );

For additional properties, see the 'Cache' documentation.

=cut

sub namespace {
    my Cache::Memory $self = shift;
    return $self->{namespace};
}

sub set_namespace {
    my Cache::Memory $self = shift;
    my ($namespace) = @_;

    $self->_init_ns_heaps($namespace);

    $self->{namespace} = $namespace;
}


# REMOVAL STRATEGY METHODS

sub remove_oldest {
    my Cache::Memory $self = shift;
    my $minimum = $Age_Heaps{$self->{namespace}}->minimum
        or return undef;
    $minimum == $Store{$minimum->namespace()}{$minimum->key()}{age_elem}
        or die 'Cache::Memory data structure(s) corrupted';
    return $self->remove($minimum->key());
}

sub remove_stalest {
    my Cache::Memory $self = shift;
    my $minimum = $Use_Heaps{$self->{namespace}}->minimum
        or return undef;
    $minimum == $Store{$minimum->namespace()}{$minimum->key()}{use_elem}
        or die 'Cache::Memory data structure(s) corrupted';
    return $self->remove($minimum->key());
}


# SHORTCUT METHODS

sub remove {
    my Cache::Memory $self = shift;
    my ($key) = @_;

    my $ns = $self->{namespace};

    my $store_entry = $Store{$ns}{$key}
        or return undef;

    defined $store_entry->{data}
        or return undef;

    # remove from heap
    my $exp_elem = delete $store_entry->{exp_elem};
    $Expiry_Heap->delete($exp_elem) if $exp_elem;

    my $age_elem = delete $store_entry->{age_elem}
        or die 'Cache::Memory data structure(s) corrupted';
    $Age_Heaps{$ns}->delete($age_elem);

    my $use_elem = delete $store_entry->{use_elem}
        or die 'Cache::Memory data structure(s) corrupted';
    $Use_Heaps{$ns}->delete($use_elem);

    # reduce size of cache iff there is no active handle
    my $size = 0;
    my $dataref = delete $store_entry->{data};
    unless (exists $store_entry->{handlelock}) {
        $size = length($$dataref);
        $Store_Sizes{$ns} -= $size;
    }

    delete $store_entry->{handlelock};

    # remove entire entry if there are no active Entry objects
    delete $Store{$ns}{$key} unless $store_entry->{rc};

    return $size;
}


# UTILITY METHODS

sub add_expiry_to_heap {
    my Cache::Memory $self = shift;
    my ($key, $time) = @_;

    my $exp_elem = Cache::Memory::HeapElem->new($self->{namespace},$key,$time);
    $Expiry_Heap->add($exp_elem);
    return $exp_elem;
}

sub del_expiry_from_heap {
    my Cache::Memory $self = shift;
    my ($key, $exp_elem) = @_;

    $Expiry_Heap->delete($exp_elem);
}

sub add_age_to_heap {
    my Cache::Memory $self = shift;
    my ($key, $time) = @_;
    my $ns = $self->{namespace};

    my $age_elem = Cache::Memory::HeapElem->new($ns,$key,$time);
    $Age_Heaps{$ns}->add($age_elem);
    return $age_elem;
}

sub add_use_to_heap {
    my Cache::Memory $self = shift;
    my ($key, $time) = @_;
    my $ns = $self->{namespace};

    my $use_elem = Cache::Memory::HeapElem->new($ns,$key,$time);
    $Use_Heaps{$ns}->add($use_elem);
    return $use_elem;
}

sub update_last_used {
    my Cache::Memory $self = shift;
    my ($key) = @_;
    my $ns = $self->{namespace};

    my $use_elem = $Store{$ns}{$key}{use_elem}
        or die 'Cache::Memory data structure(s) corrupted';

    $Use_Heaps{$ns}->delete($use_elem);
    $use_elem->val(time());
    $Use_Heaps{$ns}->add($use_elem);
}

sub change_size {
    my Cache::Memory $self = shift;
    my ($size) = @_;
    my $ns = $self->{namespace};

    $Store_Sizes{$ns} += $size;
    $self->check_size($Store_Sizes{$ns}) if $size > 0;
}

sub entry_dropped_final_rc {
    my Cache::Memory $self = shift;
    my ($key) = @_;
    my $ns = $self->{namespace};

    delete $Store{$ns}{$key} unless defined $Store{$ns}{$key}{data};
}


1;
__END__

=head1 SEE ALSO

Cache

=head1 AUTHOR

 Chris Leishman <chris@leishman.org>
 Based on work by DeWitt Clinton <dewitt@unto.net>

=head1 COPYRIGHT

 Copyright (C) 2003-2006 Chris Leishman.  All Rights Reserved.

This module is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND,
either expressed or implied. This program is free software; you can
redistribute or modify it under the same terms as Perl itself.

$Id: Memory.pm,v 1.9 2006/01/31 15:23:58 caleishm Exp $

=cut