File::FcntlLock - File locking with L<fcntl(2)>

File-FcntlLock documentation Contained in the File-FcntlLock distribution.

Index

Code Index:

name

Top

File::FcntlLock - File locking with fcntl(2)

SYNOPSIS

Top

  use File::FcntlLock;

  my $fs = new File::FcntlLock;
  $fs->l_type( F_RDLCK );
  $fs->l_whence( SEEK_CUR );
  $fs->l_start( 100 );
  $fs->l_len( 123 );

  open my $fh, '<', 'file_name' or die "Can't open file: $!\n";
  $fs->lock( $fh, F_SETLK )
      or print "Locking failed: " . $fs->error . "\n";
  $fs->l_type( F_UNLCK );
  $fs->lock( $fh, F_SETLK )
      or print "Unlocking failed: " . $fs->error . "\n";

DESCRIPTION

Top

File locking in Perl is usually done using the flock() function. Unfortunately, this only allows locks on whole files and is often implemented in terms of flock(2), which has some shortcomings.

Using this module file locking via fcntl(2) can be done (obviously, this restricts the use of the module to systems that have a fcntl(2) system call). Before a file (or parts of a file) can be locked, an object simulating a flock structure must be created and its properties set. Afterwards, by calling the lock() method a lock can be set or it can be determined if and which process currently holds the lock.

To create a new object representing a flock structure call new():

  $fs = new File::FcntlLock;

You also can pass the new() method a set of key-value pairs to initialize the objects properties, e.g. use

  $fs = new File::FcntlLock l_type   => F_WRLCK,
                            l_whence => SEEK_SET,
                            l_start  => 0,
                            l_len    => 100;

if you plan to obtain a write lock for the first 100 bytes of a file.

Once you have created the object simulating the flock structure the following methods allow to query and in most cases also to modify the properties of the object.

l_type()

If called without an argument returns the current setting of the lock type, otherwise the lock type is set to the argument, which must be either F_RDLCK, F_WRLCK or F_UNLCK (for read lock, write lock or unlock).

l_whence()

Queries or sets the l_whence property of the flock object, determining if the l_start value is relative to the start of the file, to the current position in the file or to the end of the file. The corresponding values are SEEK_SET, SEEK_CUR and SEEK_END. See also the man page for lseek(2).

l_start()

Queries or sets the start position (offset) of the lock in the file according to the mode selected by the l_whence member. See also the man page for lseek(2).

l_len()

Queries or sets the length of the region (in bytes) in the file to be locked. A value of 0 is interpreted as to mean a lock (starting at l_start) up to the very end of the file.

According to SUSv3 negative values for l_start are allowed (resulting in a lock ranging from l_start + l_len to l_start - 1) Unfortunately, not all systems allow negative arguments and will return an error when you try to obtain the lock, so please read the fcntl(2) man page of your system carefully for details.

l_pid()

This method allows retrieving the PID of a process currently holding the lock after a call of lock() with F_SETLK indicated that another process is holding the lock. A call to lock() with F_GETLK will fill in this value so l_pid() can be called.

When not initialized the flock objects l_type property is set to F_RDLCK by default, l_whence to SEEK_SET, and both l_start and l_len to 0, i.e. the settings for a read lock on the whole file.

After having set up the object representing a flock structure you can determine the current holder of a lock or try to obtain a lock by invoking the lock() method with two arguments, a file handle (or a file descriptor, the module figures out automatically what it got) and a flag indicating the action to be taken, e.g.

  $fs->lock( $fh, F_SETLK );

There are three values that can be used as the second argument:

F_GETLK

For F_GETLK the lock() method determines if and who currently is holding the lock. If no other process is holding the lock the l_type field is set to F_UNLCK. Otherwise the flock structure object is set to the values that prevent us from obtaining a lock. There may be multiple such blocking processes, including some that are themselves blocked waiting to obtain a lock. F_GETLK will only make details of one of these visible, and one has no control over which process this is.

F_SETLK

For F_SETLK the lock() method tries to obtain the lock (when l_type is set to either F_WRLCK or F_RDLCK) or releases the lock (if l_type is set to F_UNLCK). If a lock is held by some other proces the method call returns undef and errno is set to EACCESS or EAGAIN (please see the the man page for fcntl(2) for the details).

F_SETLKW

is similar to F_SETLK but instead of returning an error if the lock can't be obtained immediately it blocks until the lock is obtained. If a signal is received while waiting for the lock the method returns undef and errno is set to EINTR.

On success the method returns the string "0 but true". If the method fails (as indicated by an undef return value) you can either immediately evaluate the error number (usingf $!, $ERRNO or $OS_ERROR) or check for it at some later time via the methods discussed below.

There are three methods for obtaining information about the reason the the last call of lock() for the object failed:

lock_errno()

Returns the error number from the latest call of lock(). If the last call did not result in an error the method returns undef.

error()

Returns a short description of the error that happened during the latest call of lock() with the object. Please take the messages with a grain of salt, they represent what SUSv3 (IEEE 1003.1-2001) and the Linux, TRUE64, OpenBSD3 and Solaris8 man pages tell what the error numbers mean, there could be differences (and additional error numbers) on other systems. If there was no error the method returns undef.

system_error()

While the previous method, error(), tries to return a string with some relevance to the locking operation (i.e. "File or segment already locked by other process(es)" instead of "Permission denied") this method returns the "normal" system error message associated with errno. The method returns undef if there was no error.

EXPORT

F_GETLK F_SETLK F_SETLKW F_RDLCK F_WRLCK F_UNLCK SEEK_SET SEEK_CUR SEEK_END

CREDITS

Top

Thanks to Mark Jason Dominus (MJD) and Benjamin Goldberg (GOLDBB) for helpful discussions, code examples and encouragement. Glenn Herteg pointed out several problems and also helped improve the documentation.

AUTHOR

Top

Jens Thoms Toerring <jt@toerring.de>

SEE ALSO

Top

perl(1), fcntl(2), lseek(2).

File-FcntlLock documentation Contained in the File-FcntlLock distribution. 
# -*- cperl -*-
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Copyright (C) 2002-2009 Jens Thoms Toerring <jt@toerring.de>


package File::FcntlLock;

use 5.006;
use strict;
use warnings;
use POSIX;
use Errno;
use Carp;

require Exporter;
require DynaLoader;

our @ISA = qw( Exporter DynaLoader );

# Items to export into callers namespace by default.

our @EXPORT = qw( F_GETLK F_SETLK F_SETLKW
                  F_RDLCK F_WRLCK F_UNLCK
                  SEEK_SET SEEK_CUR SEEK_END );

our $VERSION = '0.12';



# Set up a hash with the error messages, but only for errno's that Errno
# knows about. The texts represent what's written in SUSv3 and in the man
# pages for Linux, TRUE64, OpenBSD3 and Solaris8.

my %fcntl_error_texts;

BEGIN {
    my $err;

    if ( $err = eval { &Errno::EACCES } ) {
        $fcntl_error_texts{ $err } = "File or segment already locked " .
                                     "by other process(es) or file is " .
                                     "mmap()ed to virtual memory";
    }
    if ( $err = eval { &Errno::EAGAIN } ) {
        $fcntl_error_texts{ $err } = "File or segment already locked " .
                                     "by other process(es)";
    }
    if ( $err = eval { &Errno::EBADF } ) {
        $fcntl_error_texts{ $err } = "Not an open file handle or descriptor " .
                                     "or not open for writing (with F_WRLCK)" .
                                     " or reading (with F_RDLCK)";
    }
    if ( $err = eval { &Errno::EDEADLK } ) {
        $fcntl_error_texts{ $err } = "Operation would cause a deadlock";
    }
    if ( $err = eval { &Errno::EFAULT } ) {
        $fcntl_error_texts{ $err } = "Lock outside accessible address space " .
                                     "or to many locked regions";
    }
    if ( $err = eval { &Errno::EINTR } ) {
        $fcntl_error_texts{ $err } = "Operation interrupted by a signal";
    }
    if ( $err = eval { &Errno::ENOLCK } ) {
        $fcntl_error_texts{ $err } = "Too many segment locks open, lock " .
                                     "table full or remote locking protocol " .
                                     "failure (e.g. NFS)";
    }
    if ( $err = eval { &Errno::EINVAL } ) {
        $fcntl_error_texts{ $err } = "Illegal parameter or file does not " .
                                     "support locking";
    }
    if ( $err = eval { &Errno::EOVERFLOW } ) {
        $fcntl_error_texts{ $err } = "One of the parameters to be returned " .
                                     "can not be represented correctly";
    }
    if ( $err = eval { &Errno::ENETUNREACH } ) {
        $fcntl_error_texts{ $err } = "File is on remote machine that can " .
                                     "not be reached anymore";
    }
    if ( $err = eval { &Errno::ENOLINK } ) {
        $fcntl_error_texts{ $err } = "File is on remote machine that can " .
                                     "not be reached anymore";
    }
}


bootstrap File::FcntlLock $VERSION;


###########################################################


sub new {
    my $inv = shift;
    my $pkg = ref( $inv ) || $inv;

    my $self = { l_type        => F_RDLCK,
                 l_whence      => SEEK_SET,
                 l_start       => 0,
                 l_len         => 0,
                 l_pid         => 0,
                 errno         => undef,
                 error_message => undef      };

    if ( @_ % 2 ) {
        carp "Missing value in key-value initializer list " .
             "in call of new method";
        return;
    }

    while ( @_ ) {
        my $key = shift;
        no strict 'refs';
        unless ( defined &$key ) {
            carp "Flock structure has no '$key' member " .
                 "in call of new method";
            return;
        }
        &$key( $self, shift );
        use strict 'refs';
    }

    bless $self, $pkg;
}


###########################################################


sub l_type {
    my $flock_struct = shift;

    if ( @_ ) {
        my $l_type = shift;
        unless (    $l_type == F_RDLCK
                 or $l_type == F_WRLCK
                 or $l_type == F_UNLCK ) {
            carp "Invalid argument in call of l_type method";
            return;
        }
        $flock_struct->{ l_type } = $l_type;
    }
    return $flock_struct->{ l_type };
}


###########################################################


sub l_whence {
    my $flock_struct = shift;

    if ( @_ ) {
        my $l_whence = shift;
        unless (    $l_whence == SEEK_SET
                 or $l_whence == SEEK_CUR
                 or $l_whence == SEEK_END ) {
            carp "Invalid argument in call of l_whence method";
            return;
        }
        $flock_struct->{ l_whence } = $l_whence;
    }
    return $flock_struct->{ l_whence };
}


###########################################################


sub l_start {
    my $flock_struct = shift;

    $flock_struct->{ l_start } = shift if @_;
    return $flock_struct->{ l_start };
}


###########################################################


sub l_len {
    my $flock_struct = shift;

    $flock_struct->{ l_len } = shift if @_;
    return $flock_struct->{ l_len };
}


###########################################################


sub l_pid {
    return shift->{ l_pid };
}


###########################################################


sub lock {
    my ( $flock_struct, $fh, $action ) = @_;
    my ( $ret, $err );

    # Figure out the file descriptor - we might get a file handle, a
    # typeglob or already a file descriptor) and set it to a value which
    # will make fcntl(2) fail with EBADF if the argument is undefined or
    # is a file handle that's invalid.

    my $fd = ( ref( $fh ) or $fh =~ /^\*/ ) ? fileno( $fh ) : $fh;
    $fd = -1 unless defined $fd;

    # Set the action argument to something invalid if it's not defined
    # which then fcntl(2) fails and errno gets set accordingly

    $action = -1 unless defined $action;

    if ( $ret = C_fcntl_lock( $fd, $action, $flock_struct, $err ) ) {
        $flock_struct->{ errno } = $flock_struct->{ error } = undef;
    } elsif ( $err ) {
        die "Internal error in File::FcntlLock module detected";
    } else {
        $flock_struct->{ errno } = $! + 0;
        $flock_struct->{ error } = defined $fcntl_error_texts{ $! + 0 } ?
                         $fcntl_error_texts{ $! + 0 } : "Unexpected error: $!";
    }

    return $ret;
}


###########################################################


sub lock_errno {
    return shift->{ errno };
}


###########################################################


sub error {
    return shift->{ error };
}


###########################################################


sub system_error {
    local $!;
    my $flock_struct = shift;
    return $flock_struct->{ errno } ? $! = $flock_struct->{ errno } : undef;
}




1;

# Local variables:
# tab-width: 4
# indent-tabs-mode: nil
# End: