view release on metacpan or  search on metacpan

lib/Cache/RamDisk.pm  view on Meta::CPAN

Cache::RamDisk

Sharing of Perl Objects Between Processes on Several RAM Drives

=head1 VERSION

0.1.6

=head1 SYNOPSYS

Application start phase:

   use Cache::RamDisk::Functions;

   cache_install( { 'Base'   => '/tmp/rd',
                    'Size'   => 16,
                    'INodes' => 1024,
                    'SIndex' => { 'fie' => 8,
                                  'foe' => 64,
                                  'fum' => 512 },
                    'ShMem'  => 'RdLk',
                    'Keys'   => { 'fie' => 50,
                                  'foe' => 200,
                                  'fum' => 4000 },
                    'User'   => 'apache',
                    'Group'  => 'apache' } );

Content handler code:

   use MyApp::Fie;

   my $fie = MyApp::Fie->new (12345);
   print $fie->{'some_field'};


Object code:

   package MyApp::Fie;
   use Cache::RamDisk;

   sub new {
      my ($class, $id) = @_;
      my $c = Cache::RamDisk->new ('/tmp/rd', CACHE_LRU);
      my $self = $c->get({'fie' => $id})->{'fie'}->{$id} || do {
         # perform some db logics
         $self = $sth->fetchrow_hashref;
         bless $self, $class;
         $c->put({'fie' => { $id => $self } });
      }
      $self;
   }


Later on in a cgi script:

   use CGI qw(:html);
   use Cache::RamDisk::Functions;
   [...]
   my $s = cache_status ('/tmp/rd');
   [...]
   print "Number of items for 'fie': ".$s->key_stat('fie'), br;


On application shutdown:

   cache_remove ('/tmp/rd');


=head1 DESCRIPTION

I<Note: 'rd' is from now on in this document an abbreviation for 'ramdisk' or 'RAM Disk' or however you prefer
to write or exclaim that herewith specified thing.>

Cache::RamDisk provides multi-process applications with a means of sharing Perl objects between the
processes while trying to avoid the inconveniences inherent to other IPC tools:

1. Message queues are extremely fast, but extremely limited too.

2. Shared memory is perhaps even faster, but it came out for me to be an at least hairy problem
trying to store several references all in one segment.

3. Sockets are reliable, but require a second communication endpoint and yet another server process.

But a file is a file is a file.

The package collects as much ramdisks to a bundle as possible and necessary to hold the required user space,
depending on the respective parameters under which the system's individual kernel had been compiled.
The system user and group who owns the cache can be specified for the whole rd bunch, say cache.


=head2 Cache Types

The package provides three ways of cacheing policy. The desired type can be submitted to the individual
object constructor with one of the following values:

=head3 CACHE_LRU

Forces the accessing object methods to treat the cache under B<L>ast B<R>ecently B<U>sed aspects: an existent
object will be delivered, and the respective index entry moves to the top. Values from the 'Keys' reference
in the latest call to C<install()> define the B<maximum number of objects> for the respective key. If the index
list is full, its last line will be C<pop()>ped and the new entry C<unshift()>ed.

=head3 CACHE_TIMED

All accesses from this object to the cache treat the value for each cache key as B<maximum age in seconds>
that cache objects belonging to the key are allowed to reach. "Stale" objects will not be delivered,
but removed instead. (The decision whether to deliver or remove happens on every C<get()> request. There
may a thread be born some day.)

=head3 CACHE_DEFAULT

A fallback policy by which you may use parts of your cache as a convenient substitute for SysV shared
memory. Values set for the cache keys are ignored - which means that you will have
to invalidate objects on this type of cache "by hand". Indexes are being kept up to date by simple
C<unshift()>s and C<splice()>s. B<Note: the invalidate() method is not part of v0.1.2!>


=head1 REQUIRES

Perl B<5.6.1> on a Linux/ Unix System containing the following binaries:

lib/Cache/RamDisk.pm  view on Meta::CPAN

sub put {
   my $self = shift || return undef;
   return undef if $self->{Err};
   unless (ref $self) {
      $self->errstr("You can't call Cache::RamDisk::put as a class method");
      return undef;
   }
   $self->{Err} = 0;
   my $what = shift;
   unless ($what || ref($what) eq 'HASH') {
      $self->errstr("Argument has to be a hashref in call to put");
      return undef;
   }

   my (%cache, $ctie);
   unless (eval { $ctie = tie %cache, 'IPC::Shareable', $self->{ShMem}, { create => 0, destroy => 0,
                                                                          exclusive => 0, mode => 0666,
                                                                          size => 65536 } } ) {
      $self->errstr($@);
      return undef;
   }

   $ctie->shlock(LOCK_EX);
   my ($k, @key, $xtie, $idx, $id, $rd, $rdpath, $df, $item, $l, $hdl, $iline);
   foreach $k (keys %{$what}) {
      next unless exists($cache{$k});
      @key = split /:/, $cache{$k};  # [0] = cache value, [1] = items on cache, [2] = ftok, [3] = shmemsize

      undef $xtie if defined($xtie);
      untie $idx if tied $idx;
      unless (eval { $xtie = tie $idx, 'IPC::Shareable', $key[2], { create => 0, destroy => 0,
                                                                   exclusive => 0, mode => 0666,
                                                                   size => $key[3]*1024 } } ) {
         $self->errstr($@);
         $ctie->shunlock;
         undef $ctie;
         untie %cache;
         return undef;
      }
      $xtie->shlock(LOCK_EX);
      foreach $id (keys %{$what->{$k}}) {
         next unless ref $what->{$k}->{$id}; # lex Storable
         # the cache truncating loop (when pop'ping has to be done for one overstanding
         if ($self->{Type} == CACHE_LRU) {        # element anyway, why not just pop them all?):
            while ($key[1] >= $key[0]) {
               $idx =~ s/(\d+){1}\/\/\w+?\n$//s;
               $rd = "__".$1."__";
               chop ($rdpath = $&);
               $rdpath =~ s/\/\//\/$k\//;
               $key[1]--;
               $rdpath = $self->{Base}.$rdpath;
               unlink $rdpath;
            }
         }

         $idx ||= "";
         $idx =~ s/(\d+\/\/$id)\n//s if $idx;    # "splice" ...
         $rdpath = $1 || "";

         # remove an existing item (items are stored as a whole on one disk and not broken up, and as we
         # secondly have to stat() an existing item anyway in order to compare the sizes, and after this
         # comparison maybe ++have++ to delete the old item, we just remove it right here):
         if ($rdpath) {
            $rdpath =~ s/\/\//\/$k\//;
            $rdpath = $self->{Base}.$rdpath;
            $key[1]--;
            unlink $rdpath;
         }
         $item = Storable::freeze($what->{$k}->{$id});
         $l = length $item;
         # find a free rd (__DStart__: new in 0.1.5, see Functions.pm)
         for ($rd = $cache{__DStart__}; $rd <= $cache{__Disks__}+$cache{__DStart__}; $rd++) {
            $df = df($self->{Base}.$rd);
            last if ($df->{favail} && ($df->{bavail} >= ceil($l/$cache{__BSize__}))); #/
         }
         if ($rd > $cache{__Disks__}+$cache{__DStart__}) {
            $self->errstr("Cache overflow");
            undef $xtie;
            untie $idx;
            $cache{$k} = join ":", @key;
            $ctie->shunlock;
            undef $ctie;
            untie %cache;
            return undef;
         }

         $iline  = "$rd//$id\n";
         $rdpath = $self->{Base}."$rd/$k/$id";
         $hdl = $self->_gensym;
         sysopen($hdl, $rdpath, O_CREAT | O_RDWR, 0644) || do { $self->errstr("$rdpath: $!");
                                                                undef $xtie;
                                                                untie $idx;
                                                                $cache{$k} = join ":", @key;
                                                                $ctie->shunlock;
                                                                undef $ctie;
                                                                untie %cache;
                                                                return undef;
                                                              };
         syswrite $hdl, $item, $l;
         close $hdl;
         $key[1]++;
         $idx = $iline.$idx;                       # ... and "unshift"
      }
      $cache{$k}  = join ":", @key;
      $xtie->shunlock;
      undef $xtie;
      untie $idx;
   }
   $ctie->shunlock;
   undef $ctie;
   untie %cache;
   1;
}


# also accepts wildcards
sub invalidate {
   my $self = shift || return undef;
   return undef unless (ref $self || $self->{Err});
   $self->{Err} = 0;
   my $what = shift;