1package Tie::FileLRUCache; 2 3use strict; 4use warnings; 5 6use Class::ParmList qw (simple_parms parse_parms); 7use Digest::SHA1 qw(sha1_hex); 8use Fcntl qw (:flock); 9use File::Spec; 10use Storable qw (nstore nfreeze retrieve); 11use Symbol qw (gensym); 12 13use vars qw ($VERSION); 14 15BEGIN { 16 $VERSION = "1.06"; 17} 18 19########################################################################### 20 21=head1 NAME 22 23Tie::FileLRUCache - A lightweight but robust filesystem based persistent LRU cache 24 25=head1 CHANGES 26 271.06 2020.10.08 - Changed license to MIT License. Updated maintainer info. 28 Updated build files. Added GitHub repo meta to build. 29 Changed minimum supported version of Perl to 5.6. 30 311.05 2005.09.13 - Changes to pod tests to make them more CPANTS friendly. 32 No functional changes. 33 341.04 2005.09.13 - Removed use of lexical warnings pragma to fix compatibility 35 with Perl 5.005. 36 37 Fixed minor typographical errors in documentation. 38 391.03 2005.09.10 - Changed build test to handle difference in treatment of hashes 40 in scalar context between 5.6.x and 5.8.x versions of Perl that 41 caused a test failure under Perl 5.6.x. 42 431.02 2005.09.08 - Added build tests. Major code cleanup. Improved platform portability. 44 Added and documented 'cache_dir', 'keep_last' and 'number_of_entries' 45 methods. Added Module::Build support. 46 47 48 491.01 1999.12.09 - Added detainting in internal cache maintaining 50 functions to evade Taint's tainting 51 of filenames read via readdir(). 52 53=head1 SYNOPSIS 54 55=head2 OBJECT INTERFACE 56 57 use Tie::FileLRUCache; 58 my $cache = Tie::FileLRUCache->new({ -cache_dir => $directory, -keep_last => 100 }); 59 60 # Inserting value into LRU cache using '-key' 61 $cache->update({ -key => $key, -value => $value }); 62 63 64 # Inserting value into LRU cache using '-cache_key' 65 my $cache_key = $cache->make_cache_key({ -key => $key }); 66 $cache->update({ -cache_key => $cache_key, -value => $value }); 67 68 69 # Checking LRU cache 70 my ($in_cache,$value) = $cache->check({ -key => $key }); 71 if ($in_cache) { 72 return $value; 73 } 74 # Not in cache - do something else 75 76 77 # Checking LRU cache with speed up hack for objects, hashes, arrays etc used as keys 78 my $cache_key = $cache->make_cache_key({ -key => $something }); 79 my ($in_cache,$value) = $cache->check({ -cache_key => $cache_key }); 80 if ($in_cache) { 81 return $value; 82 } 83 # Not in cache - do something else 84 85 86 # Deleting a key and its value from the cache 87 $cache->delete({ -key => $key }); 88 89 90 # Clearing LRU cache 91 $cache->clear; 92 93=head2 TIED INTERFACE 94 95 use Tie::FileLRUCache; 96 97 [$X =] tie %hash, 'Tie::FileLRUCache', $cache_dir, $keep_last_n; 98 99 # Adding a key/value to the cache 100 $hash{$key} = $value; 101 102 # Checking the cache 103 if (not exists $hash{$key}) {; 104 # No match 105 . 106 . 107 . 108 109 } else { 110 my $value = $hash{$key}; 111 . 112 . 113 . 114 115 } 116 117 # Removing a value from the cache; 118 delete $hash{$key}; 119 120 # Clearing the cache 121 %hash = (); 122 123Note: Iteration over the cache (each, keys, values) is _NOT_ supported. 124 125=cut 126 127=head1 DESCRIPTION 128 129Provides a lightweight persistent filesystem based LRU cache. 130 131It uses the 'last accessed' timestamp generated by the file system 132to determine the 'oldest' cache entry and discards the oldest 133cache entries when needed to stay under the -keep_last limit. 134 135If you store thing very fast (such that many entries receive the 136same time stamp), it is essentially a coin toss which entry 137within a single timestamped second gets purged from the cache 138to make room for new ones. 139 140It is not designed to handle huge numbers of cached items. It is probably 141unwise to set the 'keep_last' higher than around 100. 142 143=cut 144 145=head1 OBJECT METHODS 146 147=cut 148 149####################################################################### 150 151=over 4 152 153=item new({[ -cache_dir => $cache_directory] [, -keep_last => $keep_last_n ] }); 154 155Creates and optionally initializes a Tie::FileLRUCache object: 156 157Example: 158 159 my $cache = Tie::FileLRUCache->new({ 160 -cache_dir => '/tmp/testing', 161 -keep_last => 100, 162 }); 163 164The default cache size is 100 entries unless specified. 165 166=back 167 168=cut 169 170sub new { 171 my $proto = shift; 172 my $package = __PACKAGE__; 173 my $class = ref ($proto) || $proto || $package; 174 my $self = bless {}, $class; 175 176 my $parms = parse_parms({ -parms => \@_, 177 -legal => [-cache_dir, -keep_last], 178 -required => [], 179 -defaults => { -keep_last => 100, 180 -cache_dir => undef, 181 }, 182 }); 183 if (not defined $parms) { 184 my $error_message = Class::ParmList->error; 185 require Carp; 186 Carp::croak ($package . "::new() - Parameter error '$error_message'\n"); 187 } 188 189 # Save settings 190 my ($cache_dir,$keep_last) = $parms->get(-cache_dir,-keep_last); 191 $self->cache_dir($cache_dir); 192 $self->keep_last($keep_last); 193 194 $self; 195} 196 197####################################################################### 198 199=over 4 200 201=item check({ -key => $key }); 202 203Reads the cache for the key. 204 205Returns two values: $cache_hit (true if a hit was found, false if not) 206 $value (the cached value, undef if no hit) 207 208Examples: 209 210 my ($cache_hit,$value) = $cache->check({ -key => $key }); 211 212 my ($cache_hit,$value) = $cache->check({ -cache_key => $cache_key }); 213 214The '-key' form is used when you just want to use a raw key. It can use 215blessed objects, hash refs, scalars, or array refs as keys. The more complex 216structures take a speed penalty for computing a canonical form. 217You can minimize this penalty by using the '-cache_key' form instead. 218 219The '-cache_key' form is used for performance reasons when using keys 220such as complex blessed objects or hashes as a key. The -cache_key 221is obtained with a call to 'make_cache_key'. It is legal to mix 222-cache_key and -key based calls - they are cross-compatible. 223 224=back 225 226=cut 227 228sub check { 229 my $self = shift; 230 my $package = __PACKAGE__; 231 232 if (not wantarray) { 233 require Carp; 234 Carp::croak ($package . "::check() - Called in a scalar context\n"); 235 } 236 237 my $parms = parse_parms({ -parms => \@_, 238 -legal => [-cache_key, -key], 239 -required => [], 240 -defaults => {}, 241 }); 242 if (not defined $parms) { 243 my $error_message = Class::ParmList->error; 244 require Carp; 245 Carp::croak ($package . "::check() - $error_message\n"); 246 } 247 my ($key,$cache_key) = $parms->get(-key,-cache_key); 248 if (not (defined ($key) or defined ($cache_key))) { 249 require Carp; 250 Carp::croak ($package . "::check() - Called without either a -key or -cache_key\n"); 251 } 252 253 my $cache_dir = $self->cache_dir; 254 unless (defined $cache_dir) { 255 require Carp; 256 Carp::croak ($package . "::check - No cache directory set.\n"); 257 } 258 259 # Ok. Set our lock on the cache 260 $self->_lock_cache; 261 262 # Generate the cache_key (done by making a cannonical 263 # network order Storable string out of the key) if we 264 # don't already have it 265 unless (defined $cache_key) { 266 $cache_key = $self->make_cache_key({ -key => $key }); 267 } 268 269 # Generate a unique cache file name by taking a SHA1 hash of $cache_key 270 my $cache_hash = lc(sha1_hex($cache_key)); 271 $cache_hash =~ s/\s//gs; 272 my ($untainted_cache_hash) = $cache_hash =~ m/^([a-f0-9]+)$/s; 273 my $cache_file = File::Spec->catfile($cache_dir, "cl_$untainted_cache_hash"); 274 275 # Check if there is a cache entry for this key 276 unless (-e $cache_file) { 277 $self->_unlock_cache; 278 return (0,undef); 279 } 280 281 # Yes. Get it. And update the last modified and last accessed dates. 282 my $entry; 283 eval { 284 $entry = retrieve($cache_file); 285 my $now = time; 286 utime ($now, $now, $cache_file); 287 }; 288 if ($@) { 289 my $error = $@; 290 $self->_unlock_cache; 291 require Carp; 292 Carp::croak($package . "::check - Error while retrieving cache entry file '$cache_file': $error\n"); 293 } 294 unless (defined $entry) { 295 my $error = $!; 296 $self->_unlock_cache; 297 require Carp; 298 Carp::croak($package . "::update - Failed to retrieve cache entry file '$cache_file': $error\n"); 299 } 300 301 # Release the lock. 302 $self->_unlock_cache; 303 304 my $cache_value = $entry->{'-value'}; 305 306 # Give them their cupie doll 307 return (1, $cache_value); 308} 309 310####################################################################### 311 312=over 4 313 314=item make_cache_key({ -key => $key }); 315 316Generates a cache key by canonicalizing a passed 317key as a network ordered canonical Storable string. 318 319Example: 320 321 my $cache_key = $cache->make_cache_key({ -key => $key }); 322 323=back 324 325=cut 326 327sub make_cache_key { 328 my $self = shift; 329 my $package = __PACKAGE__; 330 my $parms = parse_parms({ -parms => \@_, 331 -legal => [], 332 -required => ['-key'], 333 -defaults => {}, 334 }); 335 unless (defined $parms) { 336 my $error_message = Class::ParmList->error; 337 require Carp; 338 Carp::croak ($package . "::make_cache_key() - $error_message\n"); 339 } 340 my ($key) = $parms->get(-key); 341 342 my $temp = $Storable::canonical; 343 my $result = nfreeze(\$key); 344 $Storable::canonical = $temp; 345 346 if (not $result) { 347 my $error = $!; 348 require Carp; 349 Carp::croak ($package . "::check() - Unable to serialize passed -key value: $error"); 350 } 351 return $result; 352} 353 354####################################################################### 355 356=over 4 357 358=item clear; 359 360Completely clears the cache of all cache entries. 361 362=back 363 364=cut 365 366sub clear { 367 my $self = shift; 368 my $package = __PACKAGE__; 369 my $cache_dir = $self->cache_dir; 370 371 unless (defined $cache_dir) { 372 require Carp; 373 Carp::croak ($package . "::clear - No cache directory set.\n"); 374 } 375 if ($cache_dir eq '') { 376 require Carp; 377 Carp::croak ($package . "::clear - Cannot use root directory as cache directory.\n"); 378 } 379 if ((-e $cache_dir) and (not -d _)) { 380 require Carp; 381 Carp::croak ($package . "::clear - '$cache_dir' already exists and is not a directory.\n"); 382 } 383 384 $self->_lock_cache; 385 386 my $cache_dir_fh = gensym; 387 if (not opendir ($cache_dir_fh, $cache_dir)) { 388 my $error = $!; 389 $self->_unlock_cache; 390 require Carp; 391 Carp::croak ($package . "::clear - Failed to open directory '$cache_dir' for reading: $error\n"); 392 } 393 394 my @raw_directory_list = readdir($cache_dir_fh); 395 unless (closedir ($cache_dir_fh)) { 396 my $error = $!; 397 $self->_unlock_cache; 398 require Carp; 399 Carp::croak ($package . "::clear - Failed to close directory '$cache_dir': $error\n"); 400 } 401 402 # Untaint the filenames, convert them to absolute file paths and unlink them. 403 my @raw_files_list = grep(/^(cacheline_[a-zA-Z0-9]{1,50}|cl_[a-zA-Z0-9]{1,50})$/s, @raw_directory_list); 404 my @file_list = (); 405 foreach my $item (@raw_files_list) { 406 my ($filename) = $item =~ m/^(.*)$/s; 407 my $file_path = File::Spec->catfile($cache_dir, $filename); 408 unless (unlink $file_path) { 409 my $error = $!; 410 $self->_unlock_cache; 411 require Carp; 412 Carp::croak($package . "::clear - Failed to unlink file '$file_path': $error"); 413 } 414 } 415 416 $self->_unlock_cache; 417 418 return; 419} 420 421####################################################################### 422 423=over 4 424 425=item update({ [-key => $key,] [-cache_key => $cache_key, ], -value => $value [, -keep_last => $keep_last_n ] }); 426 427Updates the Least Recently Used (LRU) cache for the specified 428key with the passed value. '-keep_last' is optional after the first access 429to a dataset. It will use the I<most recent> 'keep_last' used 430if not specified. 431 432It is legal to use ordinary scalars, hash references, or array references 433as keys as well as objects as -keys or -values. Basically, anything that 434Storable can reproducibly serialize can be used. 435 436Examples: 437 438 $cache->update({ -key => $key, -value => $value }); 439 440 $cache->update({ -key => $key, -value => $value, -keep_last => 100}); 441 442 my $cache_key = $cache->make_cache_key({ -key => $key }); 443 $cache->update({ -cache_key => $cache_key, -value => $value }); 444 445 my $cache_key = $cache->make_cache_key({ -key => $key }); 446 $cache->update({ -cache_key => $cache_key, -value => $value, -keep_last => 50 }); 447 448 -cache_key is assumed to be a simple scalar value for use as a key. 449 450 -key can be pretty much anything Storable can successfully and reproducibly serialize. 451 452One or the other I<must> be passed. 453 454=back 455 456=cut 457 458sub update { 459 my $self = shift; 460 my $package = __PACKAGE__; 461 462 my $parms = parse_parms({ -parms => \@_, 463 -legal => ['-keep_last', '-key', '-cache_key'], 464 -required => ['-value'], 465 -defaults => {'-keep_last' => $self->keep_last}, 466 }); 467 unless (defined $parms) { 468 my $error_message = Class::ParmList->error; 469 require Carp; 470 Carp::croak ($package . "::update() - $error_message\n"); 471 } 472 my ($key,$cache_key,$value,$keep_last) = $parms->get('-key', '-cache_key', '-value', '-keep_last'); 473 unless (defined ($key) or defined ($cache_key)) { 474 require Carp; 475 Carp::croak ($package . "::update() - Called without either a -key or -cache_key. At least one of them must be passed.\n"); 476 } 477 478 my ($cache_dir) = $self->cache_dir; 479 unless (defined $cache_dir) { 480 require Carp; 481 Carp::croak ($package . "::update - No cache directory set.\n"); 482 } 483 484 # Generate the cache_key (done by making a cannonical 485 # network order Storable string out of the key) if we 486 # don't already have one. 487 unless (defined $cache_key) { 488 $cache_key = $self->make_cache_key({ -key => $key }); 489 } 490 491 # Generate a unique cache file 492 # name by taking a SHA1 hash of 493 # $cache_key and dumping it as hex 494 my $cache_hash = lc(sha1_hex($cache_key)); 495 $cache_hash =~ s/\s//gs; 496 my ($untainted_cache_hash) = $cache_hash =~ m/^([a-f0-9]+)$/s; 497 my $cache_file = File::Spec->catfile($cache_dir, "cl_$untainted_cache_hash"); 498 499 # Serialize the $value for storage 500 my $entry = { -value => $value }; 501 502 # Set our lock on the cache directory 503 $self->_lock_cache; 504 505 ########## 506 # Store the cache entry. 507 my $result; 508 eval { $result = nstore($entry,$cache_file); }; 509 if ($@) { 510 my $error = $@; 511 $self->_unlock_cache; 512 require Carp; 513 Carp::croak($package . "::update - Error while saving cache entry file '$cache_file': $error"); 514 } 515 unless (defined $result) { 516 my $error = $!; 517 $self->_unlock_cache; 518 require Carp; 519 Carp::croak($package . "::update - Error while saving cache entry file '$cache_file': $error\n"); 520 } 521 522 ######################################## 523 # Check if we need to purge old entries 524 my $cache_dir_fh = gensym; 525 unless (opendir ($cache_dir_fh, $cache_dir)) { 526 my $error = $!; 527 $self->_unlock_cache; 528 require Carp; 529 Carp::croak ($package . "::update - Failed to open directory '$cache_dir' for reading: $error\n"); 530 } 531 my @raw_file_list = grep(/^(cacheline_[a-fA-F0-9]{1,50}|cl_[a-fA-F0-9]{1,50})$/s,readdir($cache_dir_fh)); 532 unless (closedir ($cache_dir_fh)) { 533 my $error = $!; 534 $self->_unlock_cache; 535 require Carp; 536 Carp::croak ($package . "::update - Failed to close directory '$cache_dir': $error\n"); 537 } 538 539 # Untainting the filenames and converting them to absolute file paths. 540 my @file_list = (); 541 foreach my $item (@raw_file_list) { 542 my ($filename) = $item =~ m/^(.*)$/s; 543 my $file_path = File::Spec->catfile($cache_dir, $filename); 544 push (@file_list,$file_path); 545 } 546 my $n_files = $#file_list + 1; 547 548 # No problems. All done. 549 if ($n_files <= $keep_last) { 550 $self->_unlock_cache; 551 return; 552 } 553 554 # Too many entries. Delete the excess entries (usually only one) 555 my %file_last_access = (); 556 foreach my $file (@file_list) { 557 my $last_accessed = (stat($file))[9]; 558 $file_last_access{$file} = $last_accessed; 559 } 560 my @sorted_file_list = sort { $file_last_access{$b} <=> $file_last_access{$a} } @file_list; 561 while (($n_files > $keep_last) and ($n_files > 0)) { 562 $n_files--; 563 my $pruned_file = $sorted_file_list[$n_files]; 564 unless (unlink $pruned_file) { 565 my $error = $!; 566 $self->_unlock_cache; 567 require Carp; 568 Carp::croak($package . "::update - Failed to unlink file '$pruned_file': $error"); 569 } 570 } 571 572 # Release our lock and return 573 $self->_unlock_cache; 574 return; 575} 576 577####################################################################### 578 579=over 4 580 581=item delete({ -key => $key }); 582 583Forces the deletion of a specific key from the cache. 584 585Example: 586 587 $cache->delete({ -key => $key }); 588 589=back 590 591=cut 592 593sub delete { 594 my $self = shift; 595 my $package = __PACKAGE__; 596 597 my $parms = parse_parms({ -parms => \@_, 598 -legal => [-key, -cache_key], 599 -required => [], 600 -defaults => {}, 601 }); 602 if (not defined $parms) { 603 my $error_message = Class::ParmList->error; 604 require Carp; 605 Carp::croak ($package . "::delete() - $error_message\n"); 606 } 607 my ($key,$cache_key) = $parms->get(-key, -cache_key); 608 if (not (defined ($key) or defined ($cache_key))) { 609 require Carp; 610 Carp::croak ($package . "::delete() - Called without either a -key or -cache_key\n"); 611 } 612 613 my $cache_dir = $self->cache_dir; 614 unless (defined $cache_dir) { 615 require Carp; 616 Carp::croak ($package . "::delete - No cache directory set.\n"); 617 } 618 if ($cache_dir eq '') { 619 require Carp; 620 Carp::croak ($package . "::delete - Cannot use root directory as cache directory.\n"); 621 } 622 623 # Generate the cache_key (done by making a cannonical 624 # network order Storable string out of the key) if we 625 # don't already have it 626 if (not defined $cache_key) { 627 $cache_key = $self->make_cache_key({ -key => $key }); 628 } 629 630 # Generate a unique cache file 631 # name by taking a SHA1 hash of 632 # $cache_key 633 my $cache_hash = lc(sha1_hex($cache_key)); 634 $cache_hash =~ s/\s//gs; 635 my ($untainted_cache_hash) = $cache_hash =~ m/^([a-f0-9]+)$/s; 636 my $cache_file = File::Spec->catfile($cache_dir, "cl_$untainted_cache_hash"); 637 638 # Ok. Set our lock on the cache directory 639 $self->_lock_cache; 640 641 # If it is in the cache, remove it 642 if ((-e $cache_file) and (not unlink $cache_file)) { 643 my $error = $!; 644 $self->_unlock_cache; 645 require Carp; 646 Carp::croak($package . "::delete - Failed to unlink file '$cache_file': $error"); 647 } 648 649 # Release our lock and return 650 $self->_unlock_cache; 651} 652 653####################################################################### 654 655=over 4 656 657=item cache_dir([$cache_directory_path]); 658 659Get/Set accessor for the cache directory path. 660 661Ex. 662 663 my $cache_directory = $cache->cache_dir; 664 665 $cache->cache_dir($cache_directory); 666 667=back 668 669=cut 670 671sub cache_dir { return shift->_property('cache_dir', @_); } 672 673####################################################################### 674 675=over 4 676 677=item keep_last([$keep_last_n]); 678 679Get/Set accessor for the keep last N setting. 680 681Ex. 682 683 my $n_last = $cache->keep_last; 684 685 $cache->keep_last(20); 686 687=back 688 689=cut 690 691sub keep_last { return shift->_property('keep_last', @_); } 692 693 694####################################################################### 695 696=over 4 697 698=item number_of_entries; 699 700Returns the current number of entries in the cache. 701 702=back 703 704=cut 705 706sub number_of_entries { 707 my $self = shift; 708 my $package = __PACKAGE__; 709 710 my $cache_dir_fh = gensym; 711 my $cache_dir = $self->cache_dir; 712 unless (defined $cache_dir) { 713 require Carp; 714 Carp::croak ($package . "::delete - No cache directory set.\n"); 715 } 716 if ($cache_dir eq '') { 717 require Carp; 718 Carp::croak ($package . "::delete - Cannot use root directory as cache directory.\n"); 719 } 720 721 unless (opendir ($cache_dir_fh, $cache_dir)) { 722 my $error = $!; 723 require Carp; 724 Carp::croak ($package . "::update - Failed to open directory '$cache_dir' for reading: $error\n"); 725 } 726 my @raw_file_list = grep(/^(cacheline_[a-fA-F0-9]{1,50}|cl_[a-fA-F0-9]{1,50})$/s,readdir($cache_dir_fh)); 727 unless (closedir ($cache_dir_fh)) { 728 my $error = $!; 729 require Carp; 730 Carp::croak ($package . "::update - Failed to close directory '$cache_dir': $error\n"); 731 } 732 my $n_entries = $#raw_file_list + 1; 733 return $n_entries; 734} 735 736####################################################################### 737# # 738# PRIVATE METHODS # 739# # 740# Internals. Documented for maintainance reasons only. # 741# Do not use these methods from outside this module. # 742# # 743####################################################################### 744 745####################################################################### 746# _cache_lock_fh([$fh]); 747# 748# Get/Set accessor used to store a reference to the filehandle 749# used for locking. 750 751sub _cache_lock_fh { return shift->_property('_cache_lock_fh', @_); } 752 753####################################################################### 754# _lock_cache; 755# 756# Obtains a lock on the 'cache.lock' file for this LRU cache. 757# 758# Example: 759# $self->_lock_cache; 760# 761# This will create the 'cache.lock' file if it does not already exist, 762# creating any intermediate directories as needed. 763# 764# It also writes the current PID to the lock file. 765 766sub _lock_cache { 767 my $self = shift; 768 my $package = __PACKAGE__; 769 770 my $cache_dir = $self->cache_dir; 771 if (not defined $cache_dir) { 772 require Carp; 773 Carp::croak ($package . "::_lock_cache - No cache directory set.\n"); 774 } 775 if ($cache_dir eq '') { 776 require Carp; 777 Carp::croak ($package . "::_lock_cache - Cannot use root directory as cache directory.\n"); 778 } 779 if ((-e $cache_dir) and (not -d _)) { 780 require Carp; 781 Carp::croak ($package . "::_lock_cache - '$cache_dir' already exists and is not a directory.\n"); 782 } 783 if (not -e $cache_dir) { 784 eval { 785 require File::Path; 786 File::Path::mkpath ($cache_dir); 787 }; 788 if ($@) { 789 my $error = $@; 790 require Carp; 791 Carp::croak ($package . "::_lock_cache - unable to create directory '$cache_dir': $error"); 792 } 793 } 794 if (not ((-e $cache_dir) and (-d _))) { 795 require Carp; 796 Carp::croak ($package . "::_lock_cache - Unable to create directory '$cache_dir'\n"); 797 } 798 my $document_name = File::Spec->catfile($cache_dir,'.cache.lock'); 799 my $cache_lock_fh = gensym; 800 unless (open ($cache_lock_fh,">>$document_name")) { 801 my $error = $!; 802 require Carp; 803 Carp::croak ($package . "::_lock_cache - Unable to open '$document_name': $error\n"); 804 } 805 my $lock_timeout = 100; 806 while (not flock($cache_lock_fh, LOCK_EX()|LOCK_NB())) { 807 $lock_timeout--; 808 select (undef,undef,undef,0.1); 809 if ($lock_timeout == 0) { 810 my $error = $!; 811 require Carp; 812 Carp::croak ($package . "::_lock_cache - Unable to get an exclusive lock on '$document_name': $error\n"); 813 } 814 } 815 my $fh = select ($cache_lock_fh); 816 $|++; 817 select ($fh); 818 unless (truncate ($cache_lock_fh, 0)) { 819 my $error = $!; 820 require Carp; 821 Carp::croak ($package . "::_lock_cache - Unable to truncate '$document_name': $error\n"); 822 } 823 print $cache_lock_fh "$$\n"; 824 $self->_cache_lock_fh($cache_lock_fh); 825 826 return; 827} 828 829####################################################################### 830 831# _unlock_cache; 832# 833# Release a lock on the 'cache.lock' file for this LRU cache. 834# 835# Example: 836# $self->_unlock_cache; 837 838sub _unlock_cache { 839 my $self = shift; 840 my $package = __PACKAGE__; 841 842 my $cache_lock_fh = $self->_cache_lock_fh; 843 unless (truncate ($cache_lock_fh,0)) { 844 my $error = $!; 845 require Carp; 846 Carp::croak ($package . "::_lock_cache - Unable to truncate cache.lock file: $error\n"); 847 } 848 unless (close ($cache_lock_fh)) { 849 my $error = $!; 850 require Carp; 851 Carp::croak ($package . "::_unlock_cache - Error while closing cache.lock file: $error\n"); 852 } 853 return; 854} 855 856#################################################################### 857# _property('property_name' => $property_value) 858# 859# get/set base accessor for property values 860 861sub _property { 862 my $self = shift; 863 864 my $property = shift; 865 866 my $package = __PACKAGE__; 867 if (0 == @_) { 868 my $output = $self->{$package}->{$property}; 869 return $output; 870 871 } elsif (1 == @_) { 872 my $input = shift; 873 $self->{$package}->{$property} = $input; 874 return; 875 876 } else { 877 require Carp; 878 Carp::croak("Bad calling parameters to ${package}::${property}()\n"); 879 } 880} 881 882#################################################################### 883 884sub TIEHASH { 885 my $proto = shift; 886 my $package = __PACKAGE__; 887 my $class = ref ($proto) || $proto || $package; 888 my $self = bless {}, $class; 889 890 my ($cache_dir,$keep_last) = @_; 891 892 $keep_last = 100 unless (defined $keep_last); 893 unless (defined ($cache_dir) and ($cache_dir ne '')) { 894 require Carp; 895 Carp::croak($package . ": Missing required parameter (cache_dir)\n"); 896 } 897 $self->cache_dir($cache_dir); 898 $self->keep_last($keep_last); 899 return $self; 900} 901 902####################################################################### 903 904sub STORE { 905 my $self = shift; 906 907 my ($key,$value) = @_; 908 909 if (ref(\$key) eq 'SCALAR') { 910 $self->update({ -cache_key => $key, -value => $value }); 911 } else { 912 $self->update({ -key => $key, -value => $value }); 913 } 914} 915 916####################################################################### 917 918sub FETCH { 919 my $self = shift; 920 921 my ($key) = @_; 922 923 if (ref(\$key) eq 'SCALAR') { 924 my ($cache_hit, $value) = $self->check({ -cache_key => $key }); 925 return $value; 926 927 } else { 928 my ($cache_hit,$value) = $self->check({ -key => $key }); 929 return $value; 930 } 931 932} 933 934####################################################################### 935 936sub DELETE { 937 my $self = shift; 938 939 my ($key) = @_; 940 941 if (ref(\$key) eq 'SCALAR') { 942 $self->delete({ -cache_key => $key }); 943 } else { 944 $self->delete({ -key => $key }); 945 } 946} 947 948####################################################################### 949 950sub CLEAR { 951 my $self = shift; 952 953 $self->clear; 954} 955 956####################################################################### 957 958sub EXISTS { 959 my $self = shift; 960 961 my ($key) = @_; 962 963 if (ref(\$key) eq 'SCALAR') { 964 my ($cache_hit,$value) = $self->check({ -cache_key => $key }); 965 return $cache_hit; 966 } else { 967 my ($cache_hit,$value) = $self->check({ -key => $key }); 968 return $cache_hit; 969 } 970} 971 972####################################################################### 973 974# 975# Iteration over the cache is not supported 976# 977 978sub FIRSTKEY { undef; } 979 980####################################################################### 981 982# 983# Iteration over the cache is not supported 984# 985 986sub NEXTKEY { undef; } 987 988####################################################################### 989# 990# We return the number of cache entries in a scalar context 991# 992 993sub SCALAR { 994 my $self = shift; 995 996 return $self->number_of_entries; 997} 998 999####################################################################### 1000####################################################################### 1001 1002=head1 COPYRIGHT 1003 1004Copyright 1999, 2020 Jerilyn Franz and FreeRun Technologies, Inc. All Rights Reserved. 1005 1006=head1 VERSION 1007 1008 1.06 released 2020.10.08 1009 1010=head1 LICENSE 1011 1012MIT License 1013 1014Copyright (c) 2020 Jerilyn Franz 1015 1016Permission is hereby granted, free of charge, to any person obtaining a copy 1017of this software and associated documentation files (the "Software"), to deal 1018in the Software without restriction, including without limitation the rights 1019to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 1020copies of the Software, and to permit persons to whom the Software is 1021furnished to do so, subject to the following conditions: 1022 1023The above copyright notice and this permission notice shall be included in all 1024copies or substantial portions of the Software. 1025 1026THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 1027IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 1028FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 1029AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 1030LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 1031OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 1032SOFTWARE. 1033 1034=head1 DISCLAIMER 1035 1036THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS 1037OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE 1038IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 1039PARTICULAR PURPOSE. 1040 1041Use of this software in any way or in any form, source or binary, 1042is not allowed in any country which prohibits disclaimers of any 1043implied warranties of merchantability or fitness for a particular 1044purpose or any disclaimers of a similar nature. 1045 1046IN NO EVENT SHALL I BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, 1047SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 1048USE OF THIS SOFTWARE AND ITS DOCUMENTATION (INCLUDING, BUT NOT 1049LIMITED TO, LOST PROFITS) EVEN IF I HAVE BEEN ADVISED OF THE 1050POSSIBILITY OF SUCH DAMAGE 1051 1052=head1 AUTHOR 1053 1054Jerilyn Franz 1055 1056=head1 TODO 1057 1058Nothing. 1059 1060=cut 1061 10621; 1063