view release on metacpan or  search on metacpan

Mmap.pm  view on Meta::CPAN

  $self->_lock(0)
    or croak "Can't lock cache file: $!";

  my $err;
  eval{
    local $SIG{__DIE__};

    # If the file is big enough to contain a header, attempt to read one
    my $size_cur= -s $self->{_fh};
    my $magic_ok;
    if($size_cur>=$headsize){
      my $head;
      if((my $bytes=sysread($self->{_fh},$head,$headsize))!=$headsize){
	croak "Expecting $headsize bytes, read $bytes from cache header\n";
      }
      my($mg,$buckets,$bucketsize,$pagesize,$flags,$format)=unpack('l6',$head);
      $mg==magic
        or croak "$self->{_filename} is not a Cache::Mmap file";
      ($format+=0)==filevers
        or croak "$self->{_filename} uses v$format data structures. Cache::Mmap $VERSION only supports v".filevers." data structures";

      $self->{buckets}=$buckets;
      $self->{bucketsize}=$bucketsize;
      $self->{pagesize}=$pagesize;
      while(my($opt,$bit)=each %bool_opts){
	$self->{$opt}=!!($flags&$bit);
      }
      $magic_ok=1;
    }

    # Make sure the file is big enough for the whole cache
    my $size=$self->{pagesize}+$self->{buckets}*$self->{bucketsize};
    if($size_cur < $size){
      my $pad="\0" x 1024;
      sysseek $self->{_fh},SEEK_END,0
	or croak "Can't seek to end of file: $!\n";
      while($size_cur < $size){
	my $len=syswrite($self->{_fh},$pad,1024)
	  or croak "Can't pad file: $!";
	$size_cur+=$len;
      }
      -s $self->{_fh} >= $size
	or croak "Failed to set correct file size\n";
    }

    # Write file header if it's not already done
    if(!$magic_ok){
      my $flags=0;
      while(my($opt,$bit)=each %bool_opts){
	$flags|=$bit if $self->{$opt};
      }
      my $head=pack("l6x$headsize",
	magic,@$self{'buckets','bucketsize','pagesize'},$flags,filevers
      );
      sysseek $self->{_fh},SEEK_SET,0
	or croak "Can't seek to beginning: $!";
      syswrite($self->{_fh},$head,$headsize)==$headsize
	or croak "Can't write file header: $!";
    }

    # mmap() isn't supposed to work on locked files, so unlock
    $self->_unlock;

    mmap($self->{_mmap}='',$size,$self->{_fh})
      or do{
	delete $self->{_mmap};
	croak "Can't mmap $self->{_filename}: $!";
      };
    length($self->{_mmap}) eq $size
      or do{
        delete $self->{_mmap};
	croak "mmap() failed silently: $!";
      };

    1;
  } or $err=1;

  # Unlock file before returning
  $self->_unlock;

  # Propagate caught error if there was one
  die $@ if $err;
}

=item DESTROY()

Unmap and close the file.

=cut

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

  munmap($self->{_mmap}) if exists $self->{_mmap};
  close $self->{_fh};
}

=item _lock($offset)

Lock the cache file. If $offset is zero, the file header is locked.
Otherwise, the bucket starting at $offset is locked.

XXX This also needs to create an internal lock if threading is enabled.

=cut

sub _lock{
  my($self,$offset)=@_;
  my $length=$offset ? $self->{bucketsize} : $headsize;

  _lock_xs($self->{_fh},$offset,$length,1);
}

=item _unlock()

Unlocks the entire cache file.

XXX This needs to unlock internal lock and take an offset arg if threading

=cut

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

  _lock_xs($self->{_fh},0,0,0);
}

=item _insert($bucket,$ekey,$eval,$write)

Inserts the key/value pair into the bucket. The item will be marked as dirty
if $write is true, and writethrough() is false.

=cut

sub _insert{
  my($self,$bucket,$ekey,$eval,$write)=@_;
  my $klen=length $ekey;
  my $vlen=length $eval;
  my $size=$eheadsize+$klen+$vlen;
  my $bsize=$self->{bucketsize}-$bheadsize;
  return if $size>$bsize;

  my $ehead=substr(pack("l5x$eheadsize",
    $size,time(),$klen,$vlen,($write && !$self->{writethrough} && elem_dirty),
  ),0,$eheadsize);
  my($filled)=unpack 'l',substr($self->{_mmap},$bucket,4);
  my $content=$ehead.$ekey.$eval
    .substr($self->{_mmap},$bucket+$bheadsize,$filled);
  $filled=length $content;

  # Trim down to fit into bucket
  if($filled > $bsize){
    # Find all items which fit in the bucket
    my $poff=my $off=$size;
    while($off<=$bsize){
      $poff=$off;
      last if $poff>=$filled;
      my($size)=unpack 'l',substr($content,$off,4);
      $off+=$size;
    }