This file is indexed.

/usr/share/perl5/Tie/Cache.pm is in libtie-cache-perl 0.21-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
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
#!/usr/bin/perl -w

package Tie::Cache;
use strict;
use vars qw(
 $VERSION $Debug $STRUCT_SIZE $REF_SIZE
 $BEFORE $AFTER $KEY $VALUE $BYTES $DIRTY
);

$VERSION = .21;
$Debug = 0; # set to 1 for summary, 2 for debug output
$STRUCT_SIZE = 240; # per cached elem bytes overhead, approximate
$REF_SIZE    = 16;

# NODE ARRAY STRUCT
$KEY    = 0;
$VALUE  = 1;
$BYTES  = 2;
$BEFORE = 3;
$AFTER  = 4;
$DIRTY  = 5;

=pod

=head1 NAME

Tie::Cache - LRU Cache in Memory

=head1 SYNOPSIS

 use Tie::Cache;
 tie %cache, 'Tie::Cache', 100, { Debug => 1 };   
 tie %cache2, 'Tie::Cache', { MaxCount => 100, MaxBytes => 50000 };
 tie %cache3, 'Tie::Cache', 100, { Debug => 1 , WriteSync => 0};   

 # Options ##################################################################
 #
 # Debug =>	 0 - DEFAULT, no debugging output
 #		 1 - prints cache statistics upon destroying
 #		 2 - prints detailed debugging info
 #
 # MaxCount =>	 Maximum entries in cache.
 #
 # MaxBytes =>   Maximum bytes taken in memory for cache based on approximate 
 #               size of total cache structure in memory
 #
 #               There is approximately 240 bytes used per key/value pair in the cache for 
 #               the cache data structures, so a cache of 5000 entries would take
 #               at approximately 1.2M plus the size of the data being cached.
 #
 # MaxSize  =>   Maximum size of each cache entry. Larger entries are not cached.
 #                   This helps prevent much of the cache being flushed when 
 #                   you set an exceptionally large entry.  Defaults to MaxBytes/10
 #
 # WriteSync =>  1 - DEFAULT, write() when data is dirtied for 
 #                   TRUE CACHE (see below)
 #               0 - write() dirty data as late as possible, when leaving 
 #                   cache, or when cache is being DESTROY'd
 #
 ############################################################################

 # cache supports normal tied hash functions
 $cache{1} = 2;       # STORE
 print "$cache{1}\n"; # FETCH

 # FIRSTKEY, NEXTKEY
 while(($k, $v) = each %cache) { print "$k: $v\n"; } 
 
 delete $cache{1};    # DELETE
 %cache = ();         # CLEAR

=head1 DESCRIPTION

This module implements a least recently used (LRU) cache in memory
through a tie interface.  Any time data is stored in the tied hash,
that key/value pair has an entry time associated with it, and 
as the cache fills up, those members of the cache that are
the oldest are removed to make room for new entries.

So, the cache only "remembers" the last written entries, up to the 
size of the cache.  This can be especially useful if you access 
great amounts of data, but only access a minority of the data a 
majority of the time. 

The implementation is a hash, for quick lookups, 
overlaying a doubly linked list for quick insertion and deletion.
On a WinNT PII 300, writes to the hash were done at a rate 
3100 per second, and reads from the hash at 6300 per second.   
Work has been done to optimize refreshing cache entries that are 
frequently read from, code like $cache{entry}, which moves the 
entry to the end of the linked list internally.

=cut

# Documentation continues at the end of the module.

sub TIEHASH {
    my($class, $max_count, $options) = @_;

    if(ref($max_count)) {
	$options = $max_count;
	$max_count = $options->{MaxCount};
    }
	
    unless($max_count || $options->{MaxBytes}) {
	die('you must specify cache size with either MaxBytes or MaxCount');
    }

    my $sync = exists($options->{WriteSync}) ? $options->{WriteSync} : 1;

    my $self = bless 
      { 
       # how many items to cache
       max_count=> $max_count, 
       
       # max bytes to cache
       max_bytes => $options->{MaxBytes},
       
       # max size (in bytes) of an individual cache entry
       max_size => $options->{MaxSize} || ($options->{MaxBytes} ? (int($options->{MaxBytes}/10) + 1) : 0),
       
       # class track, so know if overridden subs should be used
       'class'    => $class,
       'subclass' => $class ne 'Tie::Cache' ? 1 : 0,
       
       # current sizes
       count=>0,
       bytes=>0,
       
       # inner structures
       head=>0, 
       tail=>0, 
       nodes=>{},
       'keys'=>[],
       
       # statistics
       hit => 0,
       miss => 0,
       
       # config
       sync => $sync,
       dbg => $options->{Debug} || $Debug
       
       
      }, $class;
    
    if (($self->{max_bytes} && ! $self->{max_size})) {
	die("MaxSize must be defined when MaxBytes is");
    }

    if($self->{max_bytes} and $self->{max_bytes} < 1000) {
	die("cannot set MaxBytes to under 1000, each raw entry takes $STRUCT_SIZE bytes alone");
    }

    if($self->{max_size} && $self->{max_size} < 3) {
	die("cannot set MaxSize to under 3 bytes, assuming error in config");
    }

    $self;
}

# override to write data leaving cache
sub write { undef; }
# commented this section out for speed
#    my($self, $key, $value) = @_;
#    1;
#}

# override to get data if not in cache, should return $value
# associated with $key
sub read { undef; }
# commented this section out for speed
#    my($self, $key) = @_;
#    undef;
#}

sub FETCH {
    my($self, $key) = @_;

    my $node = $self->{nodes}{$key};
    if($node) {
	# refresh node's entry
	$self->{hit}++; # if $self->{dbg};

	# we used to call delete then insert, but we streamlined code
	if(my $after = $node->[$AFTER]) {
	    $self->{dbg} > 1 and $self->print("update() node $node to tail of list");
	    # reconnect the nodes
	    my $before = $after->[$BEFORE] = $node->[$BEFORE];
	    if($before) {
		$before->[$AFTER] = $after;
	    } else {
		$self->{head} = $after;
	    }

	    # place at the end
	    $self->{tail}[$AFTER] = $node;
	    $node->[$BEFORE] = $self->{tail};
	    $node->[$AFTER] = undef;
	    $self->{tail} = $node; # always true after this
	} else {
	    # if there is nothing after node, then we are at the end already
	    # so don't do anything to move the nodes around
	    die("this node is the tail, so something's wrong") 
		unless($self->{tail} eq $node);
	}

	$self->print("FETCH [$key, $node->[$VALUE]]") if ($self->{dbg} > 1);
	$node->[$VALUE];
    } else {
	# we have a cache miss here
	$self->{miss}++; # if $self->{dbg};

	# its fine to always insert a node, even when we have an undef,
	# because even if we aren't a sub-class, we should assume use
	# that would then set the entry.  This model works well with
	# sub-classing and reads() that might want to return undef as
	# a valid value.
	my $value;
	if ($self->{subclass}) {
	    $self->print("read() for key $key") if $self->{dbg} > 1;
	    $value = $self->read($key);
	}

	if(defined $value) {
	    my $length;
	    if($self->{max_size}) {
		# check max size of entry, that it not exceed max size
		$length = &_get_data_length(\$key, \$value);
		if($length > $self->{max_size}) {
		    $self->print("direct read() [$key, $value]") if ($self->{dbg} > 1);
		    return $value;
		}
	    }
	    # if we get here, we should insert the new node
	    $node = &create_node($self, \$key, \$value, $length);
	    &insert($self, $node);
	    $value;
	} else {
	    undef;
	}
    }
}

sub STORE {
    my($self, $key, $value) = @_;
    my $node;

    $self->print("STORE [$key,$value]") if ($self->{dbg} > 1);

    # do not cache undefined values
    defined($value) || return(undef);

    # check max size of entry, that it not exceed max size
    my $length;
    if($self->{max_size}) {
	$length = &_get_data_length(\$key, \$value);
	if($length > $self->{max_size}) {
	    if ($self->{subclass}) {
		$self->print("direct write() [$key, $value]") if ($self->{dbg} > 1);
		$self->write($key, $value);
	    }
	    return $value;
	}
    }

    # do we have node already ?
    if($self->{nodes}{$key}) {
	$node = &delete($self, $key);
#	$node = &delete($self, $key);
#	$node->[$VALUE] = $value;
#	$node->[$BYTES] = $length || &_get_data_length(\$key, \$value);
    }

    # insert new node  
    $node = &create_node($self, \$key, \$value, $length);
#    $node ||= &create_node($self, \$key, \$value, $length);
    &insert($self, $node);

    # if the data is sync'd call write now, otherwise defer the data
    # writing, but mark it dirty so it can be cleanup up at the end
    if ($self->{subclass}) {
	if($self->{sync}) {
	    $self->print("sync write() [$key, $value]") if $self->{dbg} > 1;
	    $self->write($key, $value);
	} else {
	    $node->[$DIRTY] = 1;
	}
    }

    $value;
}

sub DELETE {
    my($self, $key) = @_;

    $self->print("DELETE $key") if ($self->{dbg} > 1);
    my $node = $self->delete($key);
    $node ? $node->[$VALUE] : undef;
}

sub CLEAR {
    my($self) = @_;

    $self->print("CLEAR CACHE") if ($self->{dbg} > 1);

    if($self->{subclass}) {
	my $flushed = $self->flush();
	$self->print("FLUSH COUNT $flushed") if ($self->{dbg} > 1);
    }

    my $node;
    while($node = $self->{head}) {
	$self->delete($self->{head}[$KEY]);
    }

    1;
}

sub EXISTS {
    my($self, $key) = @_;
    exists $self->{nodes}{$key};
}
    
# firstkey / nextkey emulate keys() and each() behavior by
# taking a snapshot of all the nodes at firstkey, and 
# iterating through the keys with nextkey
#
# this method therefore will only supports one each() / keys()
# happening during any given time.
#
sub FIRSTKEY {
    my($self) = @_;

    $self->{'keys'} = [];
    my $node = $self->{head};
    while($node) {
	push(@{$self->{'keys'}}, $node->[$KEY]);
	$node = $node->[$AFTER];
    }

    shift @{$self->{'keys'}};
}

sub NEXTKEY {
    my($self, $lastkey) = @_;
    shift @{$self->{'keys'}};
}

sub DESTROY {
    my($self) = @_;

    # if debugging, snapshot cache before clearing
    if($self->{dbg}) {
	if($self->{hit} || $self->{miss}) {
	    $self->{hit_ratio} = 
		sprintf("%4.3f", $self->{hit} / ($self->{hit} + $self->{miss})); 
	}
	$self->print($self->pretty_self());
	if($self->{dbg} > 1) {
	    $self->print($self->pretty_chains());
	}
    }
    
    $self->print("DESTROYING") if $self->{dbg} > 1;
    $self->CLEAR();
    
    1;
}

####PERL##LRU##TIE##CACHE##PERL##LRU##TIE##CACHE##PERL##LRU##TIE##CACHE
## Helper Routines
####PERL##LRU##TIE##CACHE##PERL##LRU##TIE##CACHE##PERL##LRU##TIE##CACHE

# we use scalar_refs for the data for speed
sub create_node {
    my($self, $key, $value, $length) = @_;
    (defined($$key) && defined($$value)) 
      || die("need more localized data than $$key and $$value");
    
    # max_size always defined when max_bytes is
    if (($self->{max_size})) {
	$length = defined $length ? $length : &_get_data_length($key, $value)
    } else {
	$length = 0;
    }
    
    # ORDER SPECIFIC, see top for NODE ARRAY STRUCT
    my $node = [ $$key, $$value, $length ];
}

sub _get_data_length {
    my($key, $value) = @_;
    my $length = 0;
    my %refs;

    my @data = ($$key, $$value);
    while(my $elem = shift @data) {
	next if $refs{$elem};
	$refs{$elem} = 1;
	if(ref $elem && ref($elem) =~ /^(SCALAR|HASH|ARRAY)$/) {
	    my $type = $1;
	    $length += $REF_SIZE; # guess, 16 bytes per ref, probably more
	    if (($type eq 'SCALAR')) {
		$length += length($$elem);
	    } elsif (($type eq 'HASH')) {
		while (my($k,$v) = each %$elem) {
		    for my $kv($k,$v) {
			if ((ref $kv)) {
			    push(@data, $kv);
			} else {
			    $length += length($kv);
			}
		    }
		}
	    } elsif (($type eq 'ARRAY')) {
		for my $val (@$elem){
		    if ((ref $val)) {
			push(@data, $val);
		    } else {
			$length += length($val);
		    }
		}
	    }
	} else {
	    $length += length($elem);
	}
    }

    $length;
}

sub insert {
    my($self, $new_node) = @_;
    
    $new_node->[$AFTER] = 0;
    $new_node->[$BEFORE] = $self->{tail};
    $self->print("insert() [$new_node->[$KEY], $new_node->[$VALUE]]") if ($self->{dbg} > 1);
    
    $self->{nodes}{$new_node->[$KEY]} = $new_node;

    # current sizes
    $self->{count}++;
    $self->{bytes} += $new_node->[$BYTES] + $STRUCT_SIZE;

    if($self->{tail}) {
	$self->{tail}[$AFTER] = $new_node;
    } else {
	$self->{head} = $new_node;
    }
    $self->{tail} = $new_node;

    ## if we are too big now, remove head
    while(($self->{max_count} && ($self->{count} > $self->{max_count})) ||
	  ($self->{max_bytes} && ($self->{bytes} > $self->{max_bytes}))) 
    {
	if($self->{dbg} > 1) {
	    $self->print("current/max: ".
			 "bytes ($self->{bytes}/$self->{max_bytes}) ".
			 "count ($self->{count}/$self->{max_count}) "
			 );
	}
	my $old_node = $self->delete($self->{head}[$KEY]);
	if ($self->{subclass}) {
	    if($old_node->[$DIRTY]) {
		$self->print("dirty write() [$old_node->[$KEY], $old_node->[$VALUE]]") 
		  if ($self->{dbg} > 1);
		$self->write($old_node->[$KEY], $old_node->[$VALUE]);
	    }
	}
#	if($self->{dbg} > 1) {
#	    $self->print("after delete - bytes $self->{bytes}; count $self->{count}");
#	}
    }
    
    1;
}

sub delete {
    my($self, $key) = @_;    
    my $node = $self->{nodes}{$key} || return;
#    return unless $node;

    $self->print("delete() [$key, $node->[$VALUE]]") if ($self->{dbg} > 1);

    my $before = $node->[$BEFORE];
    my $after = $node->[$AFTER];

    #    my($before, $after) = $node->{before,after};
    if($before) {
	($before->[$AFTER] = $after);
    } else {
	$self->{head} = $after;
    }

    if($after) {
	($after->[$BEFORE] = $before);
    } else {
	$self->{tail} = $before;
    }

    delete $self->{nodes}{$key};
    $self->{bytes} -= ($node->[$BYTES] + $STRUCT_SIZE);
    $self->{count}--;
    
    $node;
}

sub flush {
    my $self = shift;

    $self->print("FLUSH CACHE") if ($self->{dbg} > 1);

    my $node = $self->{head};
    my $flush_count = 0;
    while($node) {
	if($node->[$DIRTY]) {
	    $self->print("flush dirty write() [$node->[$KEY], $node->[$VALUE]]") 
	      if ($self->{dbg} > 1);
	    $self->write($node->[$KEY], $node->[$VALUE]);
	    $node->[$DIRTY] = 0;
	    $flush_count++;
	}
	$node = $node->[$AFTER];
    }

    $flush_count;
}

sub print {
    my($self, $msg) = @_;
    print "$self: $msg\n";
}

sub pretty_self {
    my($self) = @_;
    
    my(@prints);
    for(sort keys %{$self}) { 
	next unless defined $self->{$_};
	push(@prints, "$_=>$self->{$_}"); 
    }

    "{ " . join(", ", @prints) . " }";
}

sub pretty_chains {
    my($self) = @_;
    my($str);
    my $k = $self->FIRSTKEY();

    $str .= "[head]->";
    my($curr_node) = $self->{head};
    while($curr_node) {
	$str .= "[$curr_node->[$KEY],$curr_node->[$VALUE]]->";
	$curr_node = $curr_node->[$AFTER];
    }
    $str .= "[tail]->";

    $curr_node = $self->{tail};
    while($curr_node) {
	$str .= "[$curr_node->[$KEY],$curr_node->[$VALUE]]->";
	$curr_node = $curr_node->[$BEFORE];
    }
    $str .= "[head]";

    $str;
}

1;

__END__

=head1 INSTALLATION

Tie::Cache installs easily using the make or nmake commands as
shown below.  Otherwise, just copy Cache.pm to $PERLLIB/site/Tie

	> perl Makefile.PL
	> make
        > make test 
	> make install

        * use nmake for win32
        ** you can also just copy Cache.pm to $perllib/Tie

=head1 BENCMARKS

There is another simpler LRU cache implementation in CPAN,
Tie::Cache::LRU, which has the same basic size limiting 
functionality, and for this functionality, the exact same 
interface.

Through healthy competition, Michael G Schwern got 
Tie::Cache::LRU mostly faster than Tie::Cache on reads & writes:

 Cache Size 5000       Tie::Cache 0.17  Tie::Cache::LRU 20110205.00
 10000 Writes             0.63 CPU sec          0.47 CPU sec
 40000 Reads              0.79 CPU sec          0.71 CPU sec
 10000 Deletes            0.23 CPU sec          0.26 CPU sec

Unless you are using TRUE CACHE or MaxBytes functionality,
using Tie::Cache::LRU could be an easy replacement for Tie::Cache.

OTOH one nice thing about this module is its lack of external module dependencies!

=head1 TRUE CACHE

To use class as a true cache, which acts as the sole interface 
for some data set, subclass the real cache off Tie::Cache, 
with @ISA = qw( 'Tie::Cache' ) notation.  Then override
the read() method for behavior when there is a cache miss,
and the write() method for behavior when the cache's data 
changes.

When WriteSync is 1 or TRUE (DEFAULT), write() is called immediately
when data in the cache is modified.  If set to 0, data that has 
been modified in the cache gets written out when the entries are deleted or
during the DESTROY phase of the cache object, usually at the end of
a script.

To have the dirty data write() periodically while WriteSync is set to 0,
there is a flush() cache API call that will flush the dirty writes
in this way.  Just call the flush() API like:

  my $write_flush_count = tied(%cache)->flush();

The flush() API was added in the .17 release thanks to Rob Bloodgood.

=head1 TRUE CACHE EXAMPLE

 use Tie::Cache;

 # personalize the Tie::Cache object, by inheriting from it
 package My::Cache;
 @ISA = qw(Tie::Cache);

 # override the read() and write() member functions
 # these tell the cache what to do with a cache miss or flush
 sub read { 
    my($self, $key) = @_; 
    print "cache miss for $key, read() data\n";
    rand() * $key; 
 }
 sub write { 
    my($self, $key, $value) = @_;
    print "flushing [$key, $value] from cache, write() data\n";
 }

 my $cache_size   = $ARGV[0] || 2;
 my $num_to_cache = $ARGV[1] || 4;   
 my $Debug = $ARGV[2] || 1;

 tie %cache, 'My::Cache', $cache_size, {Debug => $Debug};   

 # load the cache with new data, each through its contents,
 # and then reload in reverse order.
 for(1..$num_to_cache) { print "read data $_: $cache{$_}\n" }
 while(my($k, $v) = each %cache) { print "each data $k: $v\n"; }
 for(my $i=$num_to_cache; $i>0; $i--) { print "read data $i: $cache{$i}\n"; }

 # flush writes now, trivial use since will happen in DESTROY() anyway
 tied(%cache)->flush(); 

 # clear cache in 2 ways, write will flush out to disk
 %cache = ();
 undef %cache;

=head1 NOTES

Many thanks to all those who helped me make this module a reality, 
including:

	:) Tom Hukins who provided me insight and motivation for
	   finishing this module.
	:) Jamie McCarthy, for trying to make Tie::Cache be all
	   that it can be.
	:) Rob Fugina who knows how to "TRULY CACHE".
	:) Rob Bloodgood, for the TRUE CACHE flush() API

=head1 AUTHOR

Please send any questions or comments to Joshua Chamas at chamas@alumni.stanford.org

=head1 COPYRIGHT

Copyright (c) 1999-2012 Joshua Chamas, Chamas Enterprises Inc.  
Sponsored by development on NodeWorks http://nodeworks.com and Web Test.org http://web-test.org

All rights reserved. This program is free software; you can redistribute it and/or modify it under the same 
terms as Perl itself. 

=cut