22

✏️ Editing: Inline.pm

# -*- 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 <jt@toerring.de>

# 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 <<EOF;
#include <stdio.h>
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <fcntl.h>
#include <limits.h>

#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

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

MR SKB