view release on metacpan or  search on metacpan

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

=head1 TITLE: Cache::RamDisk::Functions

Script-like things for installing and monitoring a Cache::RamDisk

=head1 SYNOPSIS

   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' } );


   cache_status ('/tmp/rd');

   cache_remove ('/tmp/rd');


=head1 VERSION

0.1.6

=head1 EXPORTS

   cache_install
   cache_status
   cache_remove
   cache_objects


=head1 REQUIRES

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

   chown, mkdir, mke2fs, mount, umount

The package uses these Perl modules available from CPAN:

   IPC::Shareable
   IPC::SysV
   Filesys::Df
   Filesys::Statvfs
   File::stat
   Fcntl
   Symbol
   Class::Struct
   POSIX


=head1 DESCRIPTION

The package provides programmers with functions for creating, monitoring and removing a cache based on a
bundle of ramdisks.

=head2 cache_install ( $href )

Initialize the rd bundle. What will actually happen when you call this method depends on how the system
kernel had been compiled. Please refer to the manpages about lilo.conf, lsmod etc. for some
further details about manipulating the standard rd size on your box. All rds will be formatted with
standard e2fs and under the default blocksize parameter.
Of course the calling process has to have root privileges.

C<cache_install()> does not terminate the calling process after an error has occurred, but emits a warning and
returns a somehow valuable result! After successful execution the function calls C<cache_status()> on the freshly
installed cache and passes the return value to the caller.

From version 0.1.5 on C<cache_install> tries to find out whether there an C<initrd> has been installed. The most effective - but
nevertheless hack-like - way to me was to grep in C</proc/mounts>. If an entry named 'initrd' can be found, the first rd it tries to install
will be on /dev/ram1, assuming that /dev/ram0 is occupied in some way...


=head3 Arguments

Of course all argument names are case sensitive.

=head4 Base

'Base' is an optional argument defaulting to '/tmp/rd'. Please note that the argument will not be treated
as a pathname, but as the beginning of it. With the default value the rds will be called '/tmp/rd0', '/tmp/rd1', ...
From version 0.1.5 on can be stated that an initrd being found on '/tmp/rd0' will be respected.

=head4 Size

The B<minimum> user space in B<MB> to be installed. "Minimum" results from the root space that ext2 reserves on
each disk. The creating loop stops when there are more blocks available than necessary for the requested
value. This will in effect lead to an available space of ca. 19 MB when you want just 16 - but there aren't
many of such opportunities in life, so don't complain.. 'Size' is an optional argument that defaults to 16.

=head4 SIndex

Each key's index will be stored on a shared memory segment of the key's 'SIndex' Size in B<kB>.
This is an optional value with a default of 128 for each key. An index element will have the length
of the item's id plus 4 bytes (or 5 if there are more than 10 rds keeping the data). In order to speed
up performance the indexes are stored as strings and parsed by regexes, which I expect to act somewhat
faster than painful C<for> loops over arrays.

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

      warn "You must be root to install a cache";
      return {}; # a somehow useable value...
   }
   my $args = shift || return 0;
   my ($i, $rdpath, $hdl, $ret, @stat);
   $args->{'Base'}  = '/tmp/rd' unless $args->{'Base'};
   $args->{'Size'}  = 16 unless $args->{'Size'};
   $args->{'INodes'}= 1024 unless $args->{'INodes'};
   $args->{'ShMem'} = 'RdLk' unless $args->{'ShMem'};
   $args->{'User'}  = 'root' unless $args->{'User'};
   $args->{'Group'} = 'root' unless $args->{'Group'};
   unless ($args->{'Keys'}) {
      warn "A cache like me needs a key";
      return {};
   }
   $args->{'SIndex'} = {} unless $args->{'SIndex'};

   my @keys;
   foreach (keys %{$args->{'Keys'}}) {
      unless(/\W/ or /^__.*__$/) {
         push @keys, $_;
         $args->{'SIndex'}->{$_} = 128 unless $args->{'SIndex'}->{$_};
      }

   }
   $ret = { 'Disks' => 0, 'DStart' => 0, 'Blocks' => 0, 'BSize' => 1024  };

   # new in 0.1.5: respect an eventual initrd.
   # to me this looks like an ugly hack...
   $hdl = gensym;
   open $hdl, '/proc/mounts' || do { warn "Oops! Is this a linux box? Can't open /proc/mounts: $!";
                                     return $ret;
                                   };
   @stat = (<$hdl>);
   close $hdl;
   $ret->{'DStart'} = 1 if (grep 'initrd', @stat);

   print STDERR "\n"; # some scripts don't make a nice display... ;)
   for ($i=$ret->{'DStart'};;$i++) {

      $rdpath = $args->{'Base'}.$i;
      $hdl = gensym;
      open $hdl, '/etc/mtab' ||  do { warn "Can't open /etc/mtab: $!";
                                     return $ret;
                                    };
      my @mount = (<$hdl>);
      close $hdl;
      if (grep(/$rdpath/, @mount) && system("umount ".$rdpath) < 0) {
         warn "Can't unmount $rdpath: $!";
         return $ret;
      }
      if (-e "/dev/ram$i") {
        if (system("mke2fs -q -N".$args->{'INodes'}." /dev/ram$i") < 0 ||
             system("mkdir -p $rdpath") < 0 ||
             system("mount /dev/ram$i $rdpath")) {
            warn "Error while creating /dev/ram$i on $rdpath: $!";
            return $ret;
         }
         $ret->{'BSize'} = (statvfs $rdpath)[0] unless $i;

         # chowning must not affect a 'lost+found' directory, that's why it's not done recursively
         # for the whole of each disk, but lets the '.' directory belong to root
         foreach (@keys) {
            unless (mkdir "$rdpath/$_") {
               warn "Error while creating directories on $rdpath: $!";
               return $ret;
            }
            if (system("chown -R ".$args->{'User'}.".".$args->{'Group'}." $rdpath/$_") < 0) {
               warn "Unable to change ownership of $rdpath/$_: $!";
               return $ret;
            }
         }
         @stat = statvfs($rdpath);      # df doesn't return the blocksize ?!
         $ret->{'Blocks'} += $stat[4];
         $ret->{$i} = $stat[0];
         $ret->{'Disks'} = $i;
         last if $ret->{'Blocks'} > $args->{'Size'}*$ret->{'BSize'};

      }
      else {
         warn "Not enough devices for ".$args->{'Size'}."MB -  run 'man MAKEDEV'";
         return $ret;
      }
   }

   # write static data to the control segment:
   # 1. get the shmem keys
   my @ftoks;
   for ($i = 0; $i < @keys; $i++) {
      $ftoks[$i] = ftok($args->{'Base'}.$ret->{'DStart'}."/$keys[$i]", 0);
   }

   my (%cache, $stie);
   unless (eval { $stie = tie %cache, 'IPC::Shareable', $args->{'ShMem'}, { create => 1, mode => 0666,
                                                                            size => 65536, exclusive => 0,
                                                                            destroy => 0 } } ) {
      warn $@;
      return $ret;
   }
   $stie->shlock;
   $cache{__Disks__}  = $ret->{'Disks'};
   $cache{__BSize__}  = $ret->{'BSize'};
   $cache{__DStart__} = $ret->{'DStart'};

   for ($i = 0; $i < @keys; $i++) {
      $cache{$keys[$i]} = $args->{'Keys'}->{$keys[$i]}.":0:$ftoks[$i]:".$args->{'SIndex'}->{$keys[$i]};
   }
#                              foreach (keys %cache) { print STDERR "$_=".$cache{$_}."\n";}
   $stie->shunlock;
   undef $stie;
   untie %cache;
   # finally create the shmem segments and prefill them
   for ($i = 0; $i < @keys; $i++) {
      my $baz = "";
      unless (eval { $stie = tie $baz, 'IPC::Shareable', $ftoks[$i], { create => 1, mode => 0666,
                                                                       size => $args->{'SIndex'}->{$keys[$i]}*1024,
                                                                       exclusive => 0, destroy => 0 } } ) {
         warn $@;
         return $ret;
      }
      $stie->shlock;
      $baz = "";
      $stie->shunlock;
      undef $stie;
      untie $baz;
   }

   cache_status ($args->{'Base'}, $args->{'ShMem'});