File Coverage

blib/lib/IPC/Mmap/POSIX.pm

Criterion	Covered	Total	%
statement	65	92	70.6
branch	19	56	33.9
condition	3	9	33.3
subroutine	16	18	88.8
pod	0	5	0.0
total	103	180	57.2

#/**
# Concrete implementation of the IPC::Mmap class for OS's supporting
# a POSIX mmap().
#
# Permission is granted to use this software under the same terms as Perl itself.
# Refer to the Perl Artistic License
# for details.
#
# @author D. Arnold
# @since 2006-05-01
# @self $self
#
# maintenance and modifications - Athanasios Douitsis [e-mail]
#*/
package IPC::Mmap::POSIX;
#
#	just bootstrap in the XS code
#
use Carp;
use Fcntl qw(:flock :mode);
use FileHandle;
use IPC::SysV qw(IPC_PRIVATE IPC_CREAT);
use IPC::Semaphore;
use IPC::Mmap;
use FindBin qw($Bin $Script);
use IPC::Mmap qw(MAP_ANON MAP_ANONYMOUS MAP_FILE MAP_PRIVATE MAP_SHARED
	PROT_READ PROT_WRITE);
use base qw(IPC::Mmap);

use strict;
use warnings;
use Data::Dumper;

#use constant MAP_ANON => constant('MAP_ANON', 0);
#use constant MAP_ANONYMOUS => constant('MAP_ANONYMOUS', 0);
#use constant MAP_FILE => constant('MAP_FILE', 0);
#use constant MAP_PRIVATE  => constant('MAP_PRIVATE', 0);
#use constant MAP_SHARED => constant('MAP_SHARED', 0);
#use constant PROT_READ  => constant('PROT_READ', 0);
#use constant PROT_WRITE => constant('PROT_WRITE', 0);

our $VERSION = '0.22_02';
#/**
# Constructor. mmap()'s using POSIX mmap().
#
# @param $filename
# @param $length 	optional
# @param $protflags optional
# @param $mmapflags optional
#
# @return the IPC::Mmap::POSIX object on success; undef on failure
#*/
sub new {
	my ($class, $file, $length, $prot, $mmap) = @_;

	my $fh;

	#the MAN_ANON case will be handled independentlY
	if($mmap & MAP_ANON) {
		#make sure we weren't given something that is not a pathname
		croak 'When using anonymous mmap, only a pathname is allowed as the first argument' unless (ref($file) eq '');

		#if the file doesn't exist, just touch it
		if(! -e $file) {
			open(my $fd,'>',$file) or croak $!;
			close $fd;
		}
		if(! -r $file) {
			croak "For anonymous mmap, you must provide an readable filename in order for the ftok(3) to return a valid unique id. Unfortunately $file doesn't seem to be readable. ";
		}

		my $unique_id = IPC::SysV::ftok($file,1);

		#create a brand new semaphore
		my $sem = new IPC::Semaphore($unique_id, 1, 0666|IPC_CREAT) or croak "Cannot create semaphore:$!";
		####print STDERR "semaphore is ".Dumper($sem)." \n";

		#make sure its released
		$sem->op(0,1,0) or croak "Cannot op(0,1,0) on sem";
		#@@#warn "semaphore value is ",$sem->getval(0),"\n";

		my ($mapaddr, $maxlen, $slop) = _mmap_anon($length, $prot, $mmap);
		croak "mmap() failed" unless defined($mapaddr);
		my $self = {
			_fh => $fh,
			_file => $file,
			_mmap => $mmap,
			_access => $prot,
			_addr => $mapaddr,
			_maxlen => $maxlen,
			_slop => $slop,
			semaphore => $sem,
		};

	return bless $self, $class;
	}


	croak 'No filename or filehandle provided.'
		unless defined($file) || ($mmap & MAP_ANON);

	croak 'No filename or filehandle provided.'
		if defined($file) && (ref $file) && (ref $file ne 'GLOB');

	if (ref $file) {
		$fh = $file;
	}
	elsif (! ($mmap & MAP_ANON)) {
#
#	specified a filename, we need to open (and maybe create) it
#	NOTE: POSIX doesn't seem to like mmap'ing write-only files,
#	so we'll cheat
#
		my $flags = ($prot == PROT_READ) ? O_RDONLY : O_RDWR;
		$flags |= O_CREAT
			unless -e $file;
		croak "Can't open $file: $!"
			unless sysopen($fh, $file, $flags);
	}

	my @filestats = stat $fh;
	if ($filestats[7] < $length) {
#
#	if file not big enough, expand if its writable
#	else throw error
#
		croak "IPC::Mmap::new(): specified file too small"
			unless ($prot & PROT_WRITE);
#
#	seek to end, then write NULs
#	NOTE: we need to chunk this out!!!
#
		my $tlen = $length - $filestats[7];
		seek($fh, 0, 2);
		syswrite($fh, "\0" x $tlen);
	}
	my ($mapaddr, $maxlen, $slop) = _mmap($length, $prot, $mmap, $fh);
	croak "mmap() failed"
		unless defined($mapaddr);
	my $self = {
		_fh => $fh,
		_file => $file,
		_mmap => $mmap,
		_access => $prot,
		_addr => $mapaddr,
		_maxlen => $maxlen,
		_slop => $slop,
	};

	return bless $self, $class;
}

sub DESTROY {
	if(defined($_[0]->{semaphore})) {
		print STDERR "destroying semaphore ".Dumper($_[0]->{semaphore})."\n";
		$_[0]->{semaphore}->remove;
	}
}

#/**
# Locks the mmap'ed region. Implemented using flock()
# on the mmap()'ed file.
#
# NOTE: This lock is not sufficient
# for multithreaded  access control, but may be sufficient for
# multiprocess access control.
#
# Also note that, due to flock() restrictions on some
# platforms, the type of lock is determined by the protection flags
# with which the mmap'ed region was created: if only PROT_READ,
# then shared access is used; otherwise, an exclusive lock is used.
#*/
sub lock {
	my ($self, $offset, $len) = @_;

	if(defined($self->{semaphore})) {
		#acquire
		$self->{semaphore}->op(0,-1,0) or croak("Cannot op(0,-1,0) on sem");
		#@@#warn "semaphore acquired";
		return 1;
	}

	my $fh = $self->{_fh};
	my $mmode = ($self->{_access} == PROT_READ) ? LOCK_SH : LOCK_EX;
	return flock($fh, $mmode);
}

#/**
# Unlocks the mmap'ed region. Implemented using flock()
# on the mmap()'ed file.
#*/
sub unlock {
	my ($self, $offset, $len) = @_;

	if(defined($self->{semaphore})) {
		#release
		$self->{semaphore}->op(0,1,0) or croak("Cannot op(0,1,0) on sem");
		#@@#warn "semaphore released";
		return 1;
	}

	my $fh = $self->{_fh};
	return flock($fh, LOCK_UN);
}
#/**
# Unmap the mmap()ed region.
#
# CAUTION!!! Use of this method is discouraged and
# deprecated. Unmapping from the file in one thread
# can cause segmentation in faults in other threads,
# so best practice is to just leave the mmap() in place
# and let process rundown clean things up.
#
# @deprecated
#*/
sub close {
	my $self = shift;
	_munmap($self->{_addr}, $self->{_maxlen})
		if $self->{_addr};
	CORE::close $self->{_fh} if $self->{_fh};
}
#
#	unmap and close the file
#	NOTE: do we need a ref count for multithreaded environments ?
#
sub oldDESTROY {
	my $self = shift;
print STDERR "IPC::Mmap::DESTROY: addr is $self->{_addr} len $self->{_maxlen}\n";
	_munmap($self->{_addr}, $self->{_maxlen})
		if $self->{_addr};
	CORE::close $self->{_fh} if $self->{_fh};
}

1;