File-FcntlLock-0.22/0000755000175000017500000000000012366521615012660 5ustar jensjensFile-FcntlLock-0.22/README0000644000175000017500000000632012340653102013526 0ustar jensjensFile::FcntlLock =============== File::FcntlLock is a module to do file locking in an object oriented fashion using the fcntl(2) system call. This allows locks on parts of a file as well as on the whole file and overcomes some known problems with flock(2), on which Perls flock() function is based per default. Since version 0.15 there three slightly different ways this can be done with using this package. Per default a method is used where a shared library build creation of the package is called from the Perl code to invoke the fcntl(2) system function. This method can also be used by employing the File::FcntlLock::XS module (which basically an alias for File::FcntlLock). Two further methods instead use calls of the Perl fcntl() function. In both cases at some time a C program must be run to determine the binary layout of the C flock struct used by fcntl() for locking. For the one package, File::FcntlLock::Pure, this is done while making the package. For the other, File::FcntlLock::Inline, this happens each time the package is loaded (e.g. wih the 'use' function). Of course, for this to work a C compiler must be installed on the system! Unfortunately, there seem to be a few 32-bit systems where the off_t type, used in the flock struct, is a 64-bit integer but which use a Perl version that hasn't 64-bit support enabled. On these systems the 'q' format for Perl's pack() and unpack() function isn't available and thus a "pure Perl" approach is thus not possible. On such systems the File::FcntlLock::Pure and File::FcntlLock::Inline modules won't get installed. PORTABILITY To use the module the system must support the fcntl() system call which probably will restrict its use to POSIX compliant systems. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES The module requires the following other modules: POSIX, Errno, Carp, Exporter, DynaLoader To install the module(s) a C compiler must be available and the system must support the use of shared libraries (or DLLs). For File::FcntlFlock::Inline the C compiler must also be available when the module is used. The installation of the File::FcntlLock::Pure and File::FcntlLock::Inline modules require that the Perl pack() and unpack() function support the 'q' format if the off_t type on the system is 64-bit wide. ACKNOWLEDGMENTS Thanks to Mark Jason Dominus and Benjamin Goldberg for helpful discus- sions, code examples and encouragement. Glenn Herteg pointed out several problems and also helped improve the documentation. Julian Moreno Patino helped correcting the documentation and pointed out problems arising on GNU Hurd (which seems to have only very rudimentary support for locking with fcntl(2), at least at that time). Niko Tyni and Guillem Jover encouraged and helped with implementing alternatives to a XS-only approach which hopefully will make the module more useful under certain circumstances. AUTHOR Jens Thoms Toerring COPYRIGHT AND LICENCE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (C) 2002-2014 Jens Thoms Toerring http://toerring.de File-FcntlLock-0.22/t/0000755000175000017500000000000012366521615013123 5ustar jensjensFile-FcntlLock-0.22/t/FcntlLock.t0000644000175000017500000002047612341111134015160 0ustar jensjens# -*- cperl -*- # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # Copyright (C) 2002-2014 Jens Thoms Toerring # # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl FcntlLock.t' ######################### use strict; use warnings; use Test; use POSIX; use File::FcntlLock::Core; my @modules; BEGIN { my $num_tests = 8; # Check which packages are usable and only test those for ( qw/ File::FcntlLock::XS File::FcntlLock::Pure File::FcntlLock::Inline / ) { eval "use $_"; unless ( $@ ) { push @modules, $_; $num_tests += 3; } } die "Can't use any of the packages\n" unless $num_tests > 8; plan tests => $num_tests; } ############################################## # 1. Most basic test: create an object my $fs = new File::FcntlLock::Core; ok( defined $fs and $fs->isa( 'File::FcntlLock::Core' ) ); ############################################## # 2. Also basic: create an object with initalization and check thet the # properties of the created object are what they are supposed to be $fs = new File::FcntlLock::Core l_type => F_RDLCK, l_whence => SEEK_CUR, l_start => 123, l_len => 234; ok( defined $fs and $fs->isa( 'File::FcntlLock::Core' ) and $fs->l_type == F_RDLCK and $fs->l_whence == SEEK_CUR and $fs->l_start == 123 and $fs->l_len == 234 ); ############################################## # 3. Change l_type property to F_UNLCK and check $fs->l_type( F_UNLCK ); ok( $fs->l_type, F_UNLCK ); ############################################## # 4. Change l_type property to F_WRLCK and check $fs->l_type( F_WRLCK ); ok( $fs->l_type, F_WRLCK ); ############################################## # 5. Change l_whence property to SEEK_END and check $fs->l_whence( SEEK_END ); ok( $fs->l_whence, SEEK_END ); ############################################## # 6. Change l_whence property to SEEK_SET and check $fs->l_whence( SEEK_SET ); ok( $fs->l_whence, SEEK_SET ); ############################################## # 7. Change l_start property and check $fs->l_start( 20 ); ok( $fs->l_start, 20 ); ############################################## # 8. Change l_len property and check $fs->l_len( 3 ); ok( $fs->l_len, 3 ); ############################################## # 9.-17. Test for obtaining a read and write lock and then concurrent # locking of all three packages (or as far as the packages could # be loaded) for my $module ( @modules ) { ############################################## # Test if we can get a read lock on a file and release it again ok( test_read_lock( $module ) ); ############################################## # Test if we can get an write lock on a test file and release it again ok( test_write_lock( $module ) ); ############################################## # Now a "real" test: the child process grabs a write lock on a test # file for 2 secs while the parent repeatedly tests if it can get the # lock. After the child finally releases the lock the parent should be # able to obtain and again release it. Note that there are systems # that don't support F_GETLK and in that case we can only try to # obtain the lock directly and check for the reason it failed. ok( test_concurrent_locking( $module ) ); } ############################################## # Function run for tests 9, 12 and 15: tests if we can get a read lock # on a file and release it again sub test_read_lock { my $module = shift; my $fh; unless ( defined open $fh, '>', './fcntllock_test' ) { print "# Can't create a test file: $!\n"; return 0; } close $fh; unless ( defined open $fh, '<', './fcntllock_test' ) { print "# Can't open a file for reading: $!\n"; unlink './fcntllock_test'; return 0; } unlink './fcntllock_test'; my $fs = $module->new( ); $fs->l_type( F_RDLCK ); $fs->l_start( 0 ); # that's all GNU Hurd can handle $fs->l_len( 0 ); # ditto $fs->l_whence( SEEK_SET ); # ditto my $res = $fs->lock( $fh, F_SETLK ); if ( defined $res ) { $fs->l_type( F_UNLCK ); $res = $fs->lock( $fh, F_SETLK ); print "# Dropping read lock failed: $! (" . $fs->lock_errno . ")\n" unless defined $res; } else { print "# Read lock failed: $! (" . $fs->lock_errno . ")\n"; } close $fh; return defined $res; } ############################################## # Function run fot test 10, 13 and 16: tests if we can get an write lock # on a test file and release it again sub test_write_lock { my $module = shift; my $fh; unless ( defined open $fh, '>', './fcntllock_test' ) { print "# Can't open a file for writing: $!\n"; return 0; } unlink './fcntllock_test'; my $fs = $module->new( ); $fs->l_type( F_WRLCK ); my $res = $fs->lock( $fh, F_SETLK ); if ( defined $res ) { $fs->l_type( F_UNLCK ); $res = $fs->lock( $fh, F_SETLK ); print "# Dropping write lock failed: $! (" . $fs->lock_errno . ")\n" unless defined $res; } else { print "# Write lock failed: $! (" . $fs->lock_errno . ")\n"; } close $fh; return defined $res; } ############################################## # Function run for test 11, 14 and 17: the child process grabs a write lock # on a test file for 2 secs while the parent repeatedly tests if it can get # the lock. After the child finally releases the lock the parent should be # able to obtain and again release it. Note that there are systems that do # not support F_GETLK and in that case we can only try to obtain the lock # directly and check for the reason it failed. sub test_concurrent_locking { my $module = shift; my $fh; unless ( defined open $fh, '>', './fcntllock_test' ) { print "# Can't open a file for writing: $!\n"; return 0; } unlink './fcntllock_test'; my $fs = $module->new( l_type => F_WRLCK, l_whence => SEEK_SET, l_start => 0, l_len => 0 ); my $res = 0; if ( my $pid = fork ) { sleep 1; # leave some time for the child to get the lock my $failed = 1; while ( 1 ) { # Check for abnormal exit of the child process last if $pid == waitpid( $pid, WNOHANG ) and $?; # F_GETLK is not supported on all systems in which case errno # is set to ENOSYS. In that case we have to resort to trying to # obtain the lock directly and testing the reasons for failure, # not being able to obtain information about the holder of the # lock. if ( ! defined $fs->lock( $fh, F_GETLK ) ) { last unless $!{ ENOSYS }; $fs->l_type( F_WRLCK ); if ( ! defined $fs->lock( $fh, F_SETLK ) ) { last unless $!{ EACCES } or ! $!{ EAGAIN }; } else { $fs->l_type( F_UNLCK ); last unless defined $fs->lock( $fh, F_SETLK ); $failed = 0; last; } } else { last if $fs->l_type == F_WRLCK and $fs->l_pid != $pid; if ( $fs->l_type == F_UNLCK ) { $failed = 0; last; } } select undef, undef, undef, 0.25; } if ( ! $failed ) { $res = $fs->l_type( F_WRLCK ), $fs->lock( $fh, F_SETLK ) and $fs->l_type( F_UNLCK ), $fs->lock( $fh, F_SETLK ); } } elsif ( defined $pid ) { # child's code $fs->lock( $fh, F_SETLKW ) or exit 1; sleep 2; $fs->l_type( F_UNLCK ) or exit 1; $fs->lock( $fh, F_SETLK ) or exit 1; exit 0; } else { print "# Can't fork: $!\n"; } close $fh; return $res; } # Local variables: # tab-width: 4 # indent-tabs-mode: nil # End: File-FcntlLock-0.22/FcntlLock.xs0000644000175000017500000000535312336476133015122 0ustar jensjens/* This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (C) 2002-2014 Jens Thoms Toerring */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include MODULE = File::FcntlLock PACKAGE = File::FcntlLock PROTOTYPES: ENABLE SV * C_fcntl_lock( fd, function, flock_hash, int_err ) int fd int function SV *flock_hash SV *int_err INIT: struct flock flock_struct; HV *fs; SV **sv_type, **sv_whence, **sv_start, **sv_len; sv_setiv( int_err, 0 ); if ( ! SvROK( flock_hash ) ) { sv_setiv( int_err, 1 ); XSRETURN_UNDEF; } fs = ( HV * ) SvRV( flock_hash ); CODE: /* Let's be careful and not assume that anything at all will work */ if ( ( sv_type = hv_fetch( fs, "l_type", 6, 0 ) ) == NULL || ( sv_whence = hv_fetch( fs, "l_whence", 8, 0 ) ) == NULL || ( sv_start = hv_fetch( fs, "l_start", 7, 0 ) ) == NULL || ( sv_len = hv_fetch( fs, "l_len", 5, 0 ) ) == NULL ) { sv_setiv( int_err, 1 ); XSRETURN_UNDEF; } flock_struct.l_type = SvIV( *sv_type ); flock_struct.l_whence = SvIV( *sv_whence ); flock_struct.l_start = SvIV( *sv_start ); flock_struct.l_len = SvIV( *sv_len ); /* Now call fcntl(2) - if we want the lock immediately but some other process is holding it we return 'undef' (people can find out about the reasons by checking errno). The same happens if we wait for the lock but receive a signal before we obtain the lock. */ if ( fcntl( fd, function, &flock_struct ) != 0 ) XSRETURN_UNDEF; /* Now to find out who's holding the lock we now must unpack the structure we got back from fcntl(2) and store it in the hash we got passed. */ if ( function == F_GETLK ) { hv_store( fs, "l_type", 6, newSViv( flock_struct.l_type ), 0 ); hv_store( fs, "l_whence", 8, newSViv( flock_struct.l_whence ), 0 ); hv_store( fs, "l_start", 7, newSViv( flock_struct.l_start ), 0 ); hv_store( fs, "l_len", 5, newSViv( flock_struct.l_len ), 0 ); hv_store( fs, "l_pid", 5, newSViv( flock_struct.l_pid ), 0 ); } /* Return the systems return value of the fcntl(2) call (which is 0) but in a way that can't be mistaken as meaning false (shamelessly stolen from pp_sys.c in the the Perl sources). */ RETVAL = newSVpvn( "0 but true", 10 ); OUTPUT: RETVAL File-FcntlLock-0.22/Pure_build/0000755000175000017500000000000012366521615014752 5ustar jensjensFile-FcntlLock-0.22/Pure_build/builder.c0000644000175000017500000001357212341105756016551 0ustar jensjens/*----------------------------------------------------------------* * This program is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * * Copyright (C) 2002-2014 Jens Thoms Toerring *----------------------------------------------------------------*/ #include #include #include #include #include #include #define membersize( type, member ) ( sizeof( ( ( type * ) NULL )->member ) ) #define NUM_ELEMS( p ) ( sizeof p / sizeof *p ) /* Structure for names, sizes and offsets of the flcok struct */ typedef struct { const char * name; size_t size; size_t offset; } Params; /*-------------------------------------------------* * Called from qsort() for sorting an array of Params structures * in ascending order of their 'offset' members *-------------------------------------------------*/ static int comp( const void * a, const void * b ) { if ( a == b ) return 0; return ( ( Params * ) a )->offset < ( ( Params * ) b )->offset ? -1 : 1; } /*-------------------------------------------------* *-------------------------------------------------*/ int main( void ) { Params params[ ] = { { "l_type", CHAR_BIT * membersize( struct flock, l_type ), CHAR_BIT * offsetof( struct flock, l_type ) }, { "l_whence", CHAR_BIT * membersize( struct flock, l_whence ), CHAR_BIT * offsetof( struct flock, l_whence ) }, { "l_start", CHAR_BIT * membersize( struct flock, l_start ), CHAR_BIT * offsetof( struct flock, l_start ) }, { "l_len", CHAR_BIT * membersize( struct flock, l_len ), CHAR_BIT * offsetof( struct flock, l_len ) }, { "l_pid", CHAR_BIT * membersize( struct flock, l_pid ), CHAR_BIT * offsetof( struct flock, l_pid ) } }; size_t size = CHAR_BIT * sizeof( struct flock ); size_t i; size_t pos = 0; char packstr[ 128 ] = ""; /* All sizes and offsets must be divisable by 8 and the sizes of the members must be either 8-, 16-, 32- or 64-bit values, otherwise there's no good way to pack them. */ if ( size % 8 ) exit( EXIT_FAILURE ); size /= 8; for ( i = 0; i < NUM_ELEMS( params ); ++i ) { if ( params[ i ].size % 8 || params[ i ].offset % 8 || ( params[ i ].size != 8 && params[ i ].size != 16 && params[ i ].size != 32 && params[ i ].size != 64 ) ) exit( EXIT_FAILURE ); params[ i ].size /= 8; params[ i ].offset /= 8; } /* Sort the array of structures for the members in ascending order of the offset */ qsort( params, NUM_ELEMS( params ), sizeof *params, comp ); /* Cobble together the template string to be passed to pack(), taking care of padding and also extra members we're not interested in. All the interesting members have signed integer types. */ for ( i = 0; i < NUM_ELEMS( params ); ++i ) { if ( pos != params[ i ].offset ) sprintf( packstr + strlen( packstr ), "x%lu", ( unsigned long )( params[ i ].offset - pos ) ); pos = params[ i ].offset; switch ( params[ i ].size ) { case 1 : strcat( packstr, "c" ); break; case 2 : strcat( packstr, "s" ); break; case 4 : strcat( packstr, "l" ); break; case 8 : #if defined NO_Q_FORMAT /* There seem to be some 32-bit systems out there where off_t is a 64-bit integer but Perl has no 'q' format for its pack() and unpack() functions. For these systemsthere doesn't seem to be a good way for setting up the flock structure properly using pure Perl. */ exit( EXIT_FAILURE ); #endif strcat( packstr, "q" ); break; default : exit( EXIT_FAILURE ); } pos += params[ i ].size; } if ( pos < size ) sprintf( packstr + strlen( packstr ), "x%lu", (unsigned long ) ( size - pos ) ); printf( "###########################################################\n\n" "# Method created automatically while running 'perl Makefile.PL'\n" "# (based on the the C 'struct flock' in ) for packing\n" "# the data from the 'flock_struct' into a binary blob to be\n" "# passed to fcntl().\n\n" "sub pack_flock {\n" " my $self = shift;\n" " return pack( '%s',\n", packstr ); for ( i = 0; i < NUM_ELEMS( params ); ++i ) printf( " $self->{ %s }%s", params[ i ].name, i == NUM_ELEMS( params ) - 1 ? " " : ",\n" ); printf( ");\n}\n\n\n" "###########################################################\n\n" "# Method created automatically while running 'perl Makefile.PL'\n" "# (based on the the C 'struct flock' in ) for unpacking\n" "# the binary blob received from a call of fcntl() into the\n" "# 'flock_struct'.\n\n" "sub unpack_flock {\n" " my ( $self, $data ) = @_;\n" " ( " ); for ( i = 0; i < NUM_ELEMS( params ); ++i ) printf( "$self->{ %-8s }%s", params[ i ].name, i == NUM_ELEMS( params ) - 1 ? " " : ",\n " ); printf( ") = unpack( '%s', $data );\n}\n", packstr ); return 0; } /* * Local variables: * tab-width: 4 * indent-tabs-mode: nil * End: */ File-FcntlLock-0.22/Pure_build/Pure.tmpl0000644000175000017500000000233112366520445016562 0ustar jensjens# -*- cperl -*- # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright (C) 2002-2014 Jens Thoms Toerring # Package for file locking with fcntl(2) in which the binary layout of # the C flock struct has been determined via a C program on installation # and appropriate Perl code been appended to the package. package File::FcntlLock::Pure; use 5.006; use strict; use warnings; use base qw( File::FcntlLock::Core ); our $VERSION = File::FcntlLock::Core->VERSION; our @EXPORT = @File::FcntlLock::Core::EXPORT; ########################################################### # Function for doing the actual fcntl() call: assembles the binary # structure that must be passed to fcntl() from the File::FcntlLock # object we get passed, calls it and then modifies the File::FcntlLock # with the data from the flock structure sub lock { my ( $self, $fh, $action ) = @_; my $buf = $self->pack_flock( ); my $ret = fcntl( $fh, $action, $buf ); if ( $ret ) { $self->unpack_flock( $buf ); $self->{ errno } = $self->{ error } = undef; } else { $self->get_error( $self->{ errno } = $! + 0 ); } return $ret; } File-FcntlLock-0.22/Inline_build/0000755000175000017500000000000012366521615015255 5ustar jensjensFile-FcntlLock-0.22/Inline_build/Inline.pm.in0000644000175000017500000001651012366520466017444 0ustar jensjens# -*- cperl -*- # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright (C) 2002-2014 Jens Thoms Toerring # Package for file locking with fcntl(2) in which the binary layout of # the C flock struct is determined via compiling and running a C program # each time the package is loaded package File::FcntlLock::Inline; use 5.006001; use strict; use warnings; use Fcntl; use Config; use File::Temp; use File::Spec; use base qw( File::FcntlLock::Core ); our $VERSION = File::FcntlLock::Core->VERSION; our @EXPORT = @File::FcntlLock::Core::EXPORT; my ( $packstr, @member_list ); ########################################################### BEGIN { # Create a C file in the preferred directory for temporary files for # probing the layout of the C 'flock struct'. Since __DATA__ can't # be used in a BEGIN block we've got to do with a HEREDOC. my $c_file = File::Temp->new( TEMPLATE => 'File-FcntlLock-XXXXXX', SUFFIX => '.c', DIR => File::Spec->tmpdir( ) ); print $c_file < #include #include #include #include #include #define membersize( type, member ) ( sizeof( ( ( type * ) NULL )->member ) ) #define NUM_ELEMS( p ) ( sizeof p / sizeof *p ) typedef struct { const char * name; size_t size; size_t offset; } Params; /*-------------------------------------------------* * Called from qsort() for sorting an array of Params structures * in ascending order of their 'offset' members *-------------------------------------------------*/ static int comp( const void * a, const void * b ) { if ( a == b ) return 0; return ( ( Params * ) a )->offset < ( ( Params * ) b )->offset ? -1 : 1; } /*-------------------------------------------------* *-------------------------------------------------*/ int main( void ) { Params params[ ] = { { "l_type", CHAR_BIT * membersize( struct flock, l_type ), CHAR_BIT * offsetof( struct flock, l_type ) }, { "l_whence", CHAR_BIT * membersize( struct flock, l_whence ), CHAR_BIT * offsetof( struct flock, l_whence ) }, { "l_start", CHAR_BIT * membersize( struct flock, l_start ), CHAR_BIT * offsetof( struct flock, l_start ) }, { "l_len", CHAR_BIT * membersize( struct flock, l_len ), CHAR_BIT * offsetof( struct flock, l_len ) }, { "l_pid", CHAR_BIT * membersize( struct flock, l_pid ), CHAR_BIT * offsetof( struct flock, l_pid ) } }; size_t size = CHAR_BIT * sizeof( struct flock ); size_t i; size_t pos = 0; char packstr[ 128 ] = ""; /* All sizes and offsets must be divisable by 8 and the sizes of the members must be either 8-, 16-, 32- or 64-bit values, otherwise there's no good way to pack them. */ if ( size % 8 ) exit( EXIT_FAILURE ); size /= 8; for ( i = 0; i < NUM_ELEMS( params ); ++i ) { if ( params[ i ].size % 8 || params[ i ].offset % 8 || ( params[ i ].size != 8 && params[ i ].size != 16 && params[ i ].size != 32 && params[ i ].size != 64 ) ) exit( EXIT_FAILURE ); params[ i ].size /= 8; params[ i ].offset /= 8; } /* Sort the array of structures for the members in ascending order of the offset */ qsort( params, NUM_ELEMS( params ), sizeof *params, comp ); /* Cobble together the template string to be passed to pack(), taking care of padding and also extra members we're not interested in. All the interesting members have signed integer types. */ for ( i = 0; i < NUM_ELEMS( params ); ++i ) { if ( pos != params[ i ].offset ) sprintf( packstr + strlen( packstr ), "x%lu", ( unsigned long )( params[ i ].offset - pos ) ); pos = params[ i ].offset; switch ( params[ i ].size ) { case 1 : strcat( packstr, "c" ); break; case 2 : strcat( packstr, "s" ); break; case 4 : strcat( packstr, "l" ); break; case 8 : #if defined NO_Q_FORMAT exit( EXIT_FAILURE ); #endif strcat( packstr, "q" ); break; default : exit( EXIT_FAILURE ); } pos += params[ i ].size; } if ( pos < size ) sprintf( packstr + strlen( packstr ), "x%lu", (unsigned long ) ( size - pos ) ); printf( "%s\\n", packstr ); for ( i = 0; i < NUM_ELEMS( params ); ++i ) printf( "%s\\n", params[ i ].name ); return 0; } EOF close $c_file; # Try to compile and link the file. my $exec_file = File::Temp->new( TEMPLATE => 'File=FcntlLock-XXXXXX', DIR => File::Spec->tmpdir( ) ); close $exec_file; my $qflag = eval { pack 'q', 1 }; $qflag = $@ ? '-DNO_Q_FORMAT' : ''; die "Failed to run the C compiler '$Config{cc}'\n" if system "$Config{cc} $Config{ccflags} $qflag -o $exec_file $c_file"; # Run the program and read it's output, it writes out the template string # we need for packing and unpacking the binary C struct flock required for # fcntl() and then the members of the structures in the sequence they are # defined in there. open my $pipe, '-|', $exec_file or die "Failed to run a compiled program: $!\n"; chomp( $packstr = <$pipe> ); while ( my $line = <$pipe> ) { chomp $line; push @member_list, $line; } # Make sure we got all information needed die "Your Perl version does not support the 'q' format for pack() " . "and unpack()\n" unless defined $packstr; die "Failed to obtain all needed data about the C struct flock\n" unless @member_list == 5; } ########################################################### # Function for doing the actual fcntl() call: assembles the binary # structure that must be passed to fcntl() from the File::FcntlLock # object we get passed, calls it and then modifies the File::FcntlLock # with the data from the flock structure sub lock { my ( $self, $fh, $action ) = @_; my $buf = $self->pack_flock( ); my $ret = fcntl( $fh, $action, $buf ); if ( $ret ) { $self->unpack_flock( $buf ); $self->{ errno } = $self->{ error } = undef; } else { $self->get_error( $self->{ errno } = $! + 0 ); } return $ret; } ########################################################### # Method for packing the data from the 'flock_struct' into a # binary blob to be passed to fcntl(). sub pack_flock { my $self = shift; my @args; push @args, $self->{ $_ } for @member_list; return pack $packstr, @args; } ########################################################### # Method for unpacking the binary blob received from a call of # fcntl() into the 'flock_struct'. sub unpack_flock { my ( $self, $data ) = @_; my @res = unpack $packstr, $data; $self->{ $_ } = shift @res for @member_list; } =cut 1; # Local variables: # tab-width: 4 # indent-tabs-mode: nil # End: File-FcntlLock-0.22/MANIFEST0000644000175000017500000000052012366521615014006 0ustar jensjensChanges FcntlLock.xs lib/File/FcntlLock.pm lib/File/FcntlLock.pod lib/File/FcntlLock/Core.pm lib/File/FcntlLock/XS.pm lib/File/FcntlLock/Errors.pm Pure_build/Pure.tmpl Pure_build/builder.c Inline_build/Inline.pm.in Makefile.PL MANIFEST README t/FcntlLock.t META.yml Module meta-data (added by MakeMaker) File-FcntlLock-0.22/Changes0000644000175000017500000001041012366521402014141 0ustar jensjensRevision history for Perl extension File::FcntlLock 0.22 Thu July 31 2014 - Exports still didn't work from the XS, Pure and Inline modules, hopefully fixed. 0.21 Thu July 31 2014 - Missing @EXPORT of constants fixed with patch supplied by Raphaël Hertzog (thank you;-) 0.20 Tue May 27 2014 - Problem on GNU Hurd hopefully fixed and some cosmetic changes. 0.19 Tue May 27 2014 - Builds failed on 32-bit systems due to missing CFLAGS derived from the Perl installation. 0.18 Mon May 26 2014 - CPAN didn't find the version number in FcntlLock.pm which was derived from that of Core.pm:-( 0.17 Mon May 26 2014 - CPAN testing showed that there are 32-bit systems where the off_t member of the flock struct is a 64-bit integer but Perl doesn't support the 'q' format for pack() and unpack(). On these systems there seem to be no good way of assembling a flock structure useing "pure Perl" and thus the File::FcntlLock::Pure and File::FcntlLock::Inline modules won't get installed. 0.16 Sun May 25 2014 - Missing file in 0.15, Pure.pm, in MANIFEST added. 0.15 Thu May 20 2014 - Module rewritten as three modules, one working exactly as before, and two new ones that instead of being XS-based use Perl code. For the first one the Perl code for packing/unpacking the C flock struct is generated when 'perl Makefile.PL' is run. For the other a C program is created, compiled and run each time the module gets loaded. This is in response to some concerns the Debian dpkg package managers (who use the module) had for certain circumstances when new Perl versions need to be installed (as far as I understand;-) 0.14 Thu Oct 29 2011 - Changed the test script to get it to pass under GNU Hurd, using only the rather limited fcntl() locking capabilities available on that system. Thanks to Julián Moreno Patiño for bringing the problem to my attention and helping me to set up a virtual GNU Hurd system for testing. 0.13 Thu Oct 11 2011 - Spelling errors fixed in the documentation, thanks to Julián Moreno Patiño (Debian Package Maintainer). 0.12 Thu Oct 8 2009 - Stupid bug in Makefile removed that assumed a certain layout of the flock structure - thanks to Glenn Herteg for spotting this. 0.11 Wed Oct 7 2009 - Module did use only 32-bit flock structure, making it impossible to obtain locks on parts of files above 4 GB. Now it also should work for large files. - Mistakes in documentation removed as pointed out by FANY and Glenn Herteg. 0.10 Wed May 14 2008 - Removed an issue in Makefile.PL that kept the module from being built on some systems 0.09 Sun Aug 26 2007 - Renamed module from Fcntl_Lock to FcntlLock to make it fit into the namespace newly allocated on CPAN 0.08 Sun Aug 12 2007 - Changes in error handling within the module - Makefile.PL changed so that it hopefully won't fail on (Net|Free|Open)BSD (and perhaps Cygwin) where locks on STDIN and STDOUT are not supported - Tests changed for the same reasons 0.07 Sun Aug 5 2007 - Module made ready for upload to CPAN - Changed name from Fcntl_Lock to File::Fcntl_Lock - Renamed some methods - Corrected some of the test cases - Updated documentation 0.06 Sun Apr 28 2002 - Error texts changed to reflect SUSv3 - Documentation updated 0.05 Mon Apr 22 2002 - Error texts changed to reflect TRUE64 man page - Internal module errors now call die instead of setting errno to EINVAL - Small bug fixes 0.04 Mon Apr 22 2002 - Added further test cases - Improved check on availability of fcntl(2) in Makefile.PL - Methods for simpler error determination - Update of documentation 0.03 Sat Apr 20 2002 - Removed a bug in Makefile.PL pointed out by "Frodo Baggins" - Added checks in Makefile.PL for compiler and 0.02 Sat Apr 20 2002 - Added tests in test.pl - Some changes in Makefile.PL thanks to Mark Jason Dominus - Module now recognizes file handles and descriptors correctly - Update of documentation 0.01 Thu Apr 18 2002 - original version; created by h2xs 1.21 with options -A -n Fcntl_Lock File-FcntlLock-0.22/Makefile.PL0000755000175000017500000001312312341033204014616 0ustar jensjens#!/usr/bin/perl # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # Copyright (C) 2002-2014 Jens Thoms Toerring use strict; use warnings; use Config; use ExtUtils::MakeMaker; # We need a compiler and, of course, a system that has a fcntl(2) system # call. Check for both. Then set up things to also create the Pure and # Inline sub-modules if possible. check_for_compiler( ); check_for_fcntl( ); link 'lib/File/FcntlLock.pod', 'lib/File/FcntlLock/XS.pod'; assemble_inline( ) if assemble_pure( ); # Finally create the Makefile WriteMakefile( NAME => 'File::FcntlLock', VERSION_FROM => 'lib/File/FcntlLock.pm', ABSTRACT_FROM => 'lib/File/FcntlLock.pod', LICENSE => 'perl', AUTHOR => 'Jens Thoms Toerring jt@toerring.de', PREREQ_PM => { POSIX => 0, Errno => 0, Carp => 0, Exporter => 0, DynaLoader => 0, Config => 0 }, test => { TESTS => 't/*.t' }, clean => { FILES => join ' ', qw{ lib/File/FcntlLock/XS.pod lib/File/FcntlLock/Pure.pm lib/File/FcntlLock/Inline.pm lib/File/FcntlLock/Pure.pod lib/File/FcntlLock/Inline.pod } } ); ########################################################### # Function for testing if the C compiler used for buildimg Perl is # available on the system, otherwise there's no chance of building # the module sub check_for_compiler { print "Checking if there's a C compiler\n"; open my $fh, '>', 'cc_test.c' or die "Failed to open a file for writing: $!\n"; print $fh "int main(void)\n{\nreturn 0;\n}\n"; close $fh; if ( system "$Config{cc} $Config{ccflags} -o cc_test cc_test.c" ) { unlink 'cc_test.c'; die "Can't run C compiler '$Config{cc}'\n"; } unlink 'cc_test'; unlink 'cc_test.c'; } ########################################################### # Function for testing if the system has a fcntl(2) function, # without it this module makes no sense at all. sub check_for_fcntl { print "Checking if there's a fcntl(2) system call\n"; open my $fh, '>', 'fcntl_test.c' or die "Failed to open a file for writing: $!\n"; print $fh < #include #include int main( void ) { int fd = fileno( fopen( "fcntl_test.c", "r" ) ); struct flock f; f.l_type = F_RDLCK; f.l_whence = SEEK_SET; f.l_start = 0; f.l_len = 0; return fcntl( fd, F_SETLK, &f ) != -1 ? EXIT_SUCCESS : EXIT_FAILURE; } EOF close $fh; if ( system "$Config{cc} $Config{ccflags} -o fcntl_test fcntl_test.c" ) { unlink 'fcntl_test.c'; die "OS unsupported\n"; } unlink 'fcntl_test'; unlink 'fcntl_test.c'; } ########################################################### # Function for assembling a "pure Perl" version of the module. # For that we need to determine the layout of the C flock struct # used by fcntl(2) and create some Perl code that can fill in such # a structure via pack() and retrieve its values using unpack(). # This code then is combined with the template file 'Pure/Pure.tmpl' # to make up the required module. (Failure is not a big issue, # there are two other ways of attempting to use fcntl(2), one via # an XS based module and one that attempts to obtain the same kind # of information in its BEGIN block.) # Note: there seem to be some 32-bit systems, where the flock struct # contails 64-bit off_t members, but there's no 'q' format for # Perl's pack() and unpack() function. For these systems I do # not know of any proper way of setting up the flock structure # using pure Perl... sub assemble_pure { use File::Copy; my $success = 0; return 0 unless chdir 'Pure_build'; # Compile with the 'NO_Q_FORMAT' macro defined unless Perl supports # the 'q' format for pack() and unpack(). If the system uses a 64-bit # off_t type in its flock struct this will make the program for con- # structing the code for assembling and disassembling the flock struct # output nothing and we abandon trying to build the "pure Perl" modules. my $qflag = eval { pack 'q', 1; }; $qflag = $@ ? '-DNO_Q_FORMAT' : ''; goto FAIL if system "$Config{cc} $Config{ccflags} $qflag -o builder builder.c"; goto FAIL unless copy 'Pure.tmpl', 'Pure.pm'; goto FAIL unless open my $out, '>>', 'Pure.pm'; goto FAIL unless open my $in, "-|", './builder'; unless ( my $line = <$in> ) { close $in; close $out; goto FAIL; } else { print $out $line; } print $out $_ for <$in>; close $in; print $out "\n\n1;\n"; close $out; goto FAIL unless move 'Pure.pm', '../lib/File/FcntlLock'; link '../lib/File/FcntlLock.pod', '../lib/File/FcntlLock/Pure.pod'; $success = 1; FAIL: print "Warning: Support for modules `File::FcntlLock::Pure' and " . "`File::FcntlLock::Inline' had to be disabled\n" unless $success; unlink 'builder'; chdir '..'; return $success; } ########################################################### # Function for setting up the Inline package - this only happens # when we can use pure Perl to setup the flock struct (i.e., if # the assemble_pure() function was successful). sub assemble_inline { use File::Copy; return unless copy 'Inline_build/Inline.pm.in', 'lib/File/FcntlLock/Inline.pm'; link 'lib/File/FcntlLock.pod', 'lib/File/FcntlLock/Inline.pod'; } # Local variables: # tab-width: 4 # indent-tabs-mode: nil # End: File-FcntlLock-0.22/META.yml0000664000175000017500000000120712366521615014133 0ustar jensjens--- #YAML:1.0 name: File-FcntlLock version: 0.22 abstract: File locking with L author: - Jens Thoms Toerring jt@toerring.de license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Carp: 0 Config: 0 DynaLoader: 0 Errno: 0 Exporter: 0 POSIX: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 File-FcntlLock-0.22/lib/0000755000175000017500000000000012366521615013426 5ustar jensjensFile-FcntlLock-0.22/lib/File/0000755000175000017500000000000012366521615014305 5ustar jensjensFile-FcntlLock-0.22/lib/File/FcntlLock/0000755000175000017500000000000012366521615016164 5ustar jensjensFile-FcntlLock-0.22/lib/File/FcntlLock/Errors.pm0000644000175000017500000001003512341111073017757 0ustar jensjens# -*- cperl -*- # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright (C) 2002-2014 Jens Thoms Toerring # Helper package for File::FcntLock::Core for handling error messages package File::FcntlLock::Errors; use 5.006; use strict; use warnings; use Errno; my %fcntl_error_texts; BEGIN { # Set up a hash with the error messages, but only for errno's that Errno # knows about. The texts represent what is written in SUSv3 and in the # man pages for Linux, TRUE64, OpenBSD3 and Solaris8. 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 or not opened 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"; } } ########################################################### # Function for converting an errno to a useful, human readable # message. sub get_error { my ( $self, $err ) = @_; return $self->{ error } = defined $fcntl_error_texts{ $err } ? $fcntl_error_texts{ $err } : "Unexpected error: $!"; } ########################################################### # Method returns the error number from the latest call of the # derived classes lock() function. If the last call did not # result in an error the method returns undef. sub lock_errno { return shift->{ errno }; } ########################################################### # Method returns a short description of the error that happenend # on the latest call of derived classes lock() method with the # object. If there was no error the method returns undef. sub error { return shift->{ error }; } ########################################################### # Method returns the "normal" system error message associated # with errno. The method returns undef if there was no error. sub system_error { local $!; my $self = shift; return $self->{ errno } ? $! = $self->{ errno } : undef; } 1; # Local variables: # tab-width: 4 # indent-tabs-mode: nil # End: File-FcntlLock-0.22/lib/File/FcntlLock/XS.pm0000644000175000017500000000075612366520530017057 0ustar jensjens# -*- cperl -*- # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright (C) 2002-2014 Jens Thoms Toerring # Alias for package for File::FcntlLock package File::FcntlLock::XS; use v5.6.1; use strict; use warnings; use base qw( File::FcntlLock ); our $VERSION = File::FcntlLock->VERSION; our @EXPORT = @File::FcntlLock::EXPORT; 1; # Local variables: # tab-width: 4 # indent-tabs-mode: nil # End: File-FcntlLock-0.22/lib/File/FcntlLock/Core.pm0000644000175000017500000000644412366521255017422 0ustar jensjens# -*- cperl -*- # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright (C) 2002-2014 Jens Thoms Toerring # Base class for the three modules for file locking using fcntl(2) package File::FcntlLock::Core; use 5.006; use strict; use warnings; use POSIX; use Carp; use base qw( File::FcntlLock::Errors Exporter ); our $VERSION = '0.22'; # 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 ); ########################################################### # # Make our exports exportable by child classes sub import { File::FcntlLock::Core->export_to_level( 1, @_ ); } ########################################################### # Method for creating the object 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; } ########################################################### # Method for setting or querying the 'l_type' property sub l_type { my $self = 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; } $self->{ l_type } = $l_type; } return $self->{ l_type }; } ########################################################### # Method for setting or querying the 'l_whence' property sub l_whence { my $self = 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; } $self->{ l_whence } = $l_whence; } return $self->{ l_whence }; } ########################################################### # Method to set or query of the 'l_start' property sub l_start { my $self = shift; $self->{ l_start } = shift if @_; return $self->{ l_start }; } ########################################################### # Method to set or query the 'l_len' property sub l_len { my $self = shift; $self->{ l_len } = shift if @_; return $self->{ l_len }; } ########################################################### # Method to query the 'l_pid' property sub l_pid { return shift->{ l_pid }; } 1; # Local variables: # tab-width: 4 # indent-tabs-mode: nil # End: File-FcntlLock-0.22/lib/File/FcntlLock.pm0000644000175000017500000000333112366521246016522 0ustar jensjens# -*- cperl -*- # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright (C) 2002-2014 Jens Thoms Toerring package File::FcntlLock; use 5.006; use strict; use warnings; use POSIX; use Errno; use Carp; use base qw( File::FcntlLock::Core DynaLoader ); our $VERSION = '0.22'; bootstrap File::FcntlLock $VERSION; our @EXPORT = @File::FcntlLock::Core::EXPORT; ########################################################### # # Make our exports exportable by child classes sub import { File::FcntlLock->export_to_level( 1, @_ ); } ########################################################### # # Function for locking or unlocking a file or determining which # process holds a lock. sub lock { my ( $self, $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, $self, $err ) ) { $self->{ errno } = $self->{ error } = undef; } elsif ( $err ) { die "Internal error in File::FcntlLock module detected"; } else { $self->get_error( $self->{ errno } = $! + 0 ); } return $ret; } 1; # Local variables: # tab-width: 4 # indent-tabs-mode: nil # End: File-FcntlLock-0.22/lib/File/FcntlLock.pod0000644000175000017500000002473712341120200016657 0ustar jensjens=head1 NAME File::FcntlLock - File locking with L This text also documents the following sub-packages: =over 2 =item File::FcntlLock::XS =item File::FcntlLock::Pure =item File::FcntlLock::Inline =back =head1 SYNOPSIS 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"; =head1 DESCRIPTION File locking in Perl is usually done using the C function. Unfortunately, this only allows locks on whole files and is often implemented in terms of the L system function which has some shortcomings (especially concerning locks on remotely mounted file systems) and slightly different behaviour than L. Using this module file locking via L can be done (obviously, this restricts the use of the module to systems that have a L system call). Before a file (or parts of a file) can be locked, an object simulating a flock structure, containing information in a binary format to be passed to L for locking requests, must be created and its properties set. Afterwards, by calling the L method a lock can be set and removed or it can be determined if and which process currently holds the lock. File::FcntlLock (or its alias File::FcntlLock::XS) uses a shared library, build during installation, to call the L system function directly. If this is unsuitable there are two alternatives, File::FcntlLock::Pure and File::FcntlLock::Inline. Both call the Perl C function instead and use Perl code to assemble and disassemble the structure. For this at some time the (system-dependent) binary layout of the flock structure must have been determined via a program written in C. The difference between File::FcntlLock::Pure and File::FcntlLock::Inline is that for the former this happened when the package is installed while for the latter it is done each time the package is loaded (e.g., with C). Thus, for File::FcntlLock::Inline to work a C compiler must be available. There are some minor differences in the functionality and the behaviour on passing the method for locking invalid arguments to be described below. =head2 Creating objects =over 4 =item C To create a new object, representing a flock structure, call L: $fs = new File::FcntlLock; The object has a number of properties, reflecting the members of the flock structure to be passed to L (see below). Per default on object creation the L property is set to C, L to C, and both L and L to 0, i.e., the settings for a read lock on the whole file. These defaults can be overruled by passing the L 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 intend to obtain a write lock for the first 100 bytes of a file. =back =head2 Object properties Once the object simulating the flock structure has been created the following methods allow to query and, in most cases, to also modify its properties. =over 4 =item C If called without an argument the method returns the current setting of the lock type, otherwise the lock type is set to the argument's value which must be either C, C or C (for read lock, write lock or unlock). =item C This method sets, when called with an argument, the L property of the flock object, determining if the L value is relative to the start of the file, to the current position in the file or to the end of the file. These values are C, C and C (also see the man page for L). If called with no argument the current value of the property is returned. =item C Queries or sets the start position (offset) of the lock in the file according to the mode selected by the L member. See also the man page for L. =item C Queries or sets the length of the region (in bytes) in the file to be locked. A value of 0 is interpreted to mean a lock, starting at C, to the end of the file. E.g., a lock obtained with L set to C and both L and L set to 0 locks the complete file. According to SUSv3 support for negative values for L are permitted, resulting in a lock ranging from C up to and including C. But not all systems support negative values for L and will return an error when you try to obtain such a lock, so please read the L man page of the system carefully for details. =item C If a call of the L method with C indicates that another process is holding the lock (in which case the L property will be either C or C) a call of the L method returns the PID of the process holding the lock. This method does not accept any arguments. =back =head2 Locking After having set up the object representing a flock structure one can then try to obtain a lock, release it or determine the current holder of the lock by invoking the L method: =over 4 =item C This method expects two arguments. The first one is a file handle (or typeglob). File::FcntlLock, and thus File::FcntlLock::XS (B File::FcntlLock::Pure B File::FcntlLock::Inline), also accepts a "raw" integer file descriptor. The second argument is a flag indicating the action to be taken. So call it as in $fs->lock( $fh, F_SETLK ); There are three values that can be used as the second argument: =over 4 =item C With C the L method tries to obtain a lock (when L is set to either C or C) or releases it (if L is set to C). If an attempt is made to obtain a lock but a lock is already being held by some other process the method returns C and C is set to C or C (please see the the man page for L for more details). =item C is similar to C, but instead of returning an error if the lock can't be obtained immediately it puts the calling process to sleep, i.e., it blocks, until the lock is obtained at some later time. If a signal is received while waiting for the lock the method returns C and C is set to C. =item C With C the L method determines if and which process currently is holding the lock. If there's no other lock the L property will be set to C. Otherwise the flock structure object is set to the values that would prevent us from obtaining a lock. There may be several processes that keep us from getting a lock, including some that themselves are blocked waiting to obtain a lock. C will only make details of one of these processes visible, and one has no control over which process this is. =back On success the L method returns the string "0 but true", i.e., a value that is true in boolean but 0 in numeric context. If the method fails (as indicated by an C return value) you can either immediately evaluate the error number (using $!, $ERRNO or $OS_ERROR) or check for it via the methods discussed below at some later time. =back =head2 Error handling There are minor differences between File::FcntlLock on the one hand and File::FcntlLock::Pure and File::FcntlLock::Inline on the other, due to the first calling the system function L directly while the latter two invoke the Perl C function. Perl's C function already returns a Perl error on some types of invalid arguments. In contrast File::FcntlLock passes them on to the L system call and then returns the systems response to the caller. There are three methods for obtaining information about the reason the a call of the L method failed: =over 4 =item C Returns the C error number from the latest call of L. If the last call did not result in an error C is returned. =item C Returns a short description of the error that happened during the latest call of L. 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 C. =item C While the L method tries to return a string with some direct 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 C. The method returns C if there was no error. =back =head2 EXPORT The package exports the following constants: =over 2 =item F_GETLK F_SETLK F_SETLKW =item F_RDLCK F_WRLCK F_UNLCK =item SEEK_SET SEEK_CUR SEEK_END =back =head1 INCOMPATIBILITIES Obviously, this module requires that there's a L system call. Note also that under certain circumstances the File::FcntlLock::Pure and File::FcntlLock::Inline modules may not have been installed. This happens on 32-bit systems that use 64-bit integers in their flock structure but where the installed Perl version doesn't support the 'q' format for its C and C functions. =head1 CREDITS Thanks to Mark Jason Dominus and Benjamin Goldberg for helpful discussions, code examples and encouragement. Glenn Herteg pointed out several problems and also helped improve the documentation. Julian Moreno Patino helped correcting the documentation and pointed out problems arising on GNU Hurd which seems to have only very rudimentary support for locking with L. Niko Tyni and Guillem Jover encouraged and helped with implementing alternatives to an XS-only approach which hopefully will make the module more useful under certain circumstances. =head1 AUTHOR Jens Thoms Toerring =head1 SEE ALSO L, L, L. =head1 LICENSE This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself.