view release on metacpan or  search on metacpan

lib/File/Lock/ParentLock.pm  view on Meta::CPAN

    $pid||=$$;
    return not (&_lock_status($lockfile,$pid) & _FORBIDDEN_BIT);
}

sub parentlock_is_locked {
    my ($lockfile,$pid) = @_;
    $pid||=$$;
    carp "parentlock_is_locked and is_locked method are deprecated! Use (parentlock_)is_locked_by_us!";
    return &_lock_status($lockfile,$pid) & _PERMITTED_LOCKED_BIT;
}

sub parentlock_is_locked_by_us {
    my ($lockfile,$pid) = @_;
    $pid||=$$;
    return &_lock_status($lockfile,$pid) & _PERMITTED_LOCKED_BIT;
}

sub parentlock_is_locked_by_others {
    my ($lockfile,$pid) = @_;
    $pid||=$$;
    return &_lock_status($lockfile,$pid) == FORBIDDEN_LOCKED_BY_OTHERS;
}

sub _lock_status {
    my ($lockfile,$pid) = @_;
    $pid||=$$;
    my %parentmap;
    my %pidmap;
    my $t = new Proc::ProcessTable( 'enable_ttys' => 0 );

    foreach my $p (@{$t->table}) {
	my $pid=$p->{'pid'};
	$parentmap{$pid}=$p->{'ppid'};
	$pidmap{$pid}=1;
    }

    return PERMITTED_NOT_LOCKED_NO_LOCK_FILE if (! -e $lockfile);
    return FORBIDDEN_NOT_LOCKED_DIR_AT_LOCK_FILE_PATH if ( -d $lockfile);

    my $fh;
    if (!open($fh, '<', $lockfile)) {
	# lock file can't be opened.
	warn "can't open lock file $lockfile: $!\n";
	return FORBIDDEN_LOCKED_ACCESS_ERROR;
    } else {
	my $oldpid=<$fh>;
	close ($fh) or warn "can't close lock file $lockfile: $!";
	unless ($oldpid) {
	    warn "$lockfile does not have a pid";
	    return PERMITTED_NOT_LOCKED_INVALID_LOCK_FILE;
	}
	chomp $oldpid;
	if ($oldpid<=0) {
	    warn "$lockfile: invalid pid value $oldpid";
	    return PERMITTED_NOT_LOCKED_INVALID_LOCK_FILE;
	}

	return PERMITTED_LOCKED_BY_US if ($oldpid==$pid);

	if ($pidmap{$oldpid}) {
	    # old pid still alive;
	    my $intermedpid=$pid;
	    my $counter=0;
	    my $counter_threshhold=70000;
	    while ($intermedpid and $counter++ <$counter_threshhold) {
		if ($intermedpid==$oldpid) {
		    return PERMITTED_LOCKED_BY_PARENT;
		}
		$intermedpid=$parentmap{$intermedpid};
	    }
	    die "threshhold reached for $oldpid" if $counter >=$counter_threshhold;
	    # lock is valid but we are not born from parent
	    return FORBIDDEN_LOCKED_BY_OTHERS;
	}
	# lock file's pid is dead.
	return PERMITTED_NOT_LOCKED_STALE_LOCK_FILE;
    }
}

sub _write_lock {
    my ($lockfile, $pid)=@_;
    # try to remove it if it exists.
    unlink $lockfile;

    sysopen(FH, $lockfile, O_WRONLY|O_CREAT|O_EXCL, 0644)
	or die "can't open lock file $lockfile: $!";
    syswrite(FH, "$pid");
    close (FH) or die "can't close lock file $lockfile: $!";
}


__END__



=head1	NAME

File::Lock::ParentLock - share lock among child processes of given pid.

=head1	SYNOPSIS

my $locker= File::Lock::ParentLock->new(
	-lockfile=>$lockfile,
	-pid=>$pid,
    );

die $locker->status_string() if !$locker->lock();
...
die $locker->status_string() if !$locker->unlock();


=head1	DESCRIPTION

File::Lock::ParentLock is useful for shell scripting where there are 
lots of nested script calls and we want to share a lock through the
parent - child relationship.

=head1	METHODS

=over