Acrux

 view release on metacpan or  search on metacpan

lib/Acrux/FileLock.pm  view on Meta::CPAN

    my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
    my $self  = bless {%$args}, $class;
    $self->{debug}      ||= 0;
    $self->{error}      = "";
    $self->{file}       //= File::Spec->catfile(getcwd, sprintf("%s.lock", basename($0)));
    $self->{pid}        ||= $$; # Current PID by default
    $self->{own}        ||= 0; # Owner PID
    $self->{auto}       //= 0;
    $self->{retries}    //= RETRIES;
    $self->{delay}      //= DELAY;
    $self->{_is_locked} = 0;
    croak("Incorrect pid attribute") unless $self->{pid} =~ /^[0-9]{1,11}$/;
    croak("Incorrect retries attribute") unless $self->{retries} =~ /^[0-9]{1,5}$/;
    croak("Incorrect delay attribute") unless $self->{delay} =~ /^[0-9]{1,5}$/;

    # Lock file
    return $self->lock if $self->{auto};
    return $self;
}

sub file { shift->{file} }

lib/Acrux/FileLock.pm  view on Meta::CPAN

sub error {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{error} = shift;
        return $self;
    }
    return $self->{error};
}
sub lock {
    my $self = shift;
    if ($self->_is_locked) {
        $self->_debug(sprintf("File %s already locked", $self->file));
        return $self;
    }

    # Signals
    $SIG{HUP} = $SIG{QUIT} = $SIG{INT} = $SIG{TERM} = sub {
        $self->_debug( "Caught SIG$_[0]" );
        exit;
    };

    # Save temp file
    my $tmp_file = sprintf("%s.%d", $self->file, $self->pid);
    if (open(my $fh, '>', $tmp_file)) {
        printf $fh "%d\n", $self->pid || $$;
        close $fh;

        # Rename temp file to lock file
        for my $try (0 .. $self->{retries}) {
            unless ($self->check()) { # not exists, ok
                if (rename($tmp_file, $self->file)) {
                    $self->{_is_locked} = 1;
                    $self->_debug("Got lock file");
                    return $self;
                }
            }
            if ($self->{retries} && ($try != $self->{retries})) {
                $self->_debug(sprintf("Retrying in %d seconds", $self->{delay}));
                sleep $self->{delay} unless ($try == $self->{retries});
            }
        }

lib/Acrux/FileLock.pm  view on Meta::CPAN

    } else {
        $self->error(sprintf("Could not read %s: $!", $self->file))->_debug($self->error);
    }

    return 0;
}
sub unlock {
    my $self = shift;

    # Remove lock file
    if ($self->_is_locked) {
        $self->error(sprintf("Could not unlink %s: $!", $self->file))->_debug($self->error)
            unless unlink $self->file;
        $self->own(0) unless -f $self->file; # Reset owner PID to 0
    } else {
        $self->own(0) # Reset owner PID to 0
    }

    # Remove temp file in silent mode
    my $tmp_file = sprintf("%s.%d", $self->file, $self->pid);
    unlink $tmp_file if -f $tmp_file;

    return $self;
}

sub _is_locked {
    my $self = shift;
    return ($self->{_is_locked} && -f $self->file) ? 1 : 0
}
sub _debug {
    my $self = shift;
    warn sprintf("%s: %s\n", ref($self), join("\n", @_)) if $self->{debug};
}

sub DESTROY {
    my $self = shift;
    return unless $self->{auto};
    $self->_debug("Cleaning up...");

lib/Acrux/Util.pm  view on Meta::CPAN

=item append

This argument is a boolean option, defaulted to false (C<0>).
Setting this argument to true (C<1>) will cause the data to be be written at the end of the current file.
Internally this sets the sysopen mode flag C<O_APPEND>

=item binmode

Set the layers to write the file with. The default will be something sensible on your platform

=item locked

This argument is a boolean option, defaulted to false (C<0>).
Setting this argument to true (C<1>) will ensure an that existing file will not be overwritten

=item mode

This numeric argument sets the default mode of opening files to write.
By default this argument to C<(O_WRONLY | O_CREAT)>.
Please DO NOT set this argument unless really necessary!

lib/Acrux/Util.pm  view on Meta::CPAN

    my $file = shift // '';
    my $data = shift // '';
    my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
    my $cleanup = 1;

    # Get binmode layer, mode and perms
    my $bm = $args->{binmode} // ':raw'; # read in :raw by default
    my $perms = $args->{perms} // 0666; # set file permissions
    my $mode = $args->{mode} // O_WRONLY | O_CREAT;
       $mode |= O_APPEND if $args->{append};
       $mode |= O_EXCL if $args->{locked};

    # Open filehandle
    my $fh;
    if (ref($file)) {
        $fh = $file;
        $cleanup = 0; # Disable closing filehandle for passed filehandle
    } else {
        $fh = IO::File->new($file, $mode, $perms);
        unless (defined $fh) {
            carp qq/Can't open file "$file": $!/;

t/13-filelock.t  view on Meta::CPAN

    is $l->pid, $$, "$$ current process by default";

    # Lock
    ok !$l->lock->error, "$$ lock file" or diag $l->error;

    # Get owner uid
    my $owner_uid = $l->owner // 0;
    ok $owner_uid, "$$ owner uid" and note "owner uid = $owner_uid";

    # Check
    ok $l->check, "$$ is locked";

    # Unlock
    ok $l->unlock, "$$ unlock file";
    #note explain $l;

    # Check
    ok !$l->check, "$$ is NOT locked";
};

subtest "Auto call" => sub {
    my $l = Acrux::FileLock->new(file => $file, auto => 1, debug => 0);

    # Check
    ok $l->check, "$$ is locked";

    # Lock again
    ok !$l->lock->error, "$$ lock file again" or diag $l->error;
};

subtest "Fork mode" => sub {

    # Parent process
    if (my $child = fork) {
        sleep 1;
        my $l = Acrux::FileLock->new(file => $file, auto => 1);
        note sprintf "Parent PID: %s; Parent Owner PID: %s", $l->pid, $l->own;

        # Check
        ok $l->check, "$$ is locked";

        waitpid $child, 0;
        return;
    }

    # Child process
    else {
        my $l = Acrux::FileLock->new(file => $file, auto => 1);
        unless ($l->check) {
           note sprintf "Start child process (Child PID: %s; Child Owner PID: %s)", $l->pid, $l->owner;