view release on metacpan or  search on metacpan

lib/File/Write/Rotate.pm  view on Meta::CPAN

## no critic: InputOutput::ProhibitOneArgSelect

package File::Write::Rotate;

our $DATE = '2019-06-27'; # DATE
our $VERSION = '0.321'; # VERSION

use 5.010001;
use strict;
use warnings;

# we must not use Log::Any, looping if we are used as log output
#use Log::Any '$log';

use File::Spec;
use IO::Compress::Gzip qw(gzip $GzipError);
use Scalar::Util qw(weaken);
#use Taint::Runtime qw(untaint is_tainted);
use Time::HiRes 'time';

our $Debug;

sub new {
    my $class = shift;
    my %args0 = @_;

    my %args;

    defined($args{dir} = delete $args0{dir})
        or die "Please specify dir";
    defined($args{prefix} = delete $args0{prefix})
        or die "Please specify prefix";
    $args{suffix} = delete($args0{suffix}) // "";

    $args{size} = delete($args0{size}) // 0;

    $args{period} = delete($args0{period});
    if ($args{period}) {
        $args{period} =~ /\A(daily|day|month|monthly|year|yearly)\z/
            or die "Invalid period, please use daily/monthly/yearly";
    }

    for (map {"hook_$_"} qw(before_rotate after_rotate after_create
                            before_write a)) {
        next unless $args0{$_};
        $args{$_} = delete($args0{$_});
        die "Invalid $_, please supply a coderef"
            unless ref($args{$_}) eq 'CODE';
    }

    if (!$args{period} && !$args{size}) {
        $args{size} = 10 * 1024 * 1024;
    }

    $args{histories} = delete($args0{histories}) // 10;

    $args{binmode} = delete($args0{binmode});

    $args{buffer_size} = delete($args0{buffer_size});

    $args{lock_mode} = delete($args0{lock_mode}) // 'write';
    $args{lock_mode} =~ /\A(none|write|exclusive)\z/
        or die "Invalid lock_mode, please use none/write/exclusive";

    $args{rotate_probability} = delete($args0{rotate_probability});
    if (defined $args{rotate_probability}) {
        $args{rotate_probability} > 0 && $args{rotate_probability} < 1.0
            or die "Invalid rotate_probability, must be 0 < x < 1";
    }

    if (keys %args0) {
        die "Unknown arguments to new(): ".join(", ", sort keys %args0);
    }

    $args{_buffer} = [];

    my $self = bless \%args, $class;

lib/File/Write/Rotate.pm  view on Meta::CPAN

    my $self = shift;
    $self->{_fh};
}

sub path {
    my $self = shift;
    $self->{_fp};
}

# file path, without the rotate suffix
sub _file_path {
    my ($self) = @_;

    # _now is calculated every time we access this method
    $self->{_now} = time();

    my @lt = localtime($self->{_now});
    $lt[5] += 1900;
    $lt[4]++;

    my $period;
    if ($self->{period}) {
        if ($self->{period} =~ /year/i) {
            $period = sprintf("%04d", $lt[5]);
        } elsif ($self->{period} =~ /month/) {
            $period = sprintf("%04d-%02d", $lt[5], $lt[4]);
        } elsif ($self->{period} =~ /day|daily/) {
            $period = sprintf("%04d-%02d-%02d", $lt[5], $lt[4], $lt[3]);
        }
    } else {
        $period = "";
    }

    my $path = join(
        '',
        $self->{dir}, '/',
        $self->{prefix},
        length($period) ? ".$period" : "",
        $self->{suffix},
    );
    if (wantarray) {
        return ($path, $period);
    } else {
        return $path;
    }
}

sub lock_file_path {
    my ($self) = @_;
    return File::Spec->catfile($self->{dir}, $self->{prefix} . '.lck');
}

sub _get_lock {
    my ($self) = @_;
    return undef if $self->{lock_mode} eq 'none';
    return $self->{_weak_lock} if defined($self->{_weak_lock});

    require File::Flock::Retry;
    my $lock = File::Flock::Retry->lock($self->lock_file_path);
    $self->{_weak_lock} = $lock;
    weaken $self->{_weak_lock};
    return $lock;
}

# will return \@files. each entry is [filename without compress suffix,
# rotate_suffix (for sorting), period (for sorting), compress suffix (for
# renaming back)]
sub _get_files {
    my ($self) = @_;

    opendir my ($dh), $self->{dir} or do {
        warn "Can't opendir '$self->{dir}': $!";
        return;
    };

    my @files;
    while (my $e = readdir($dh)) {
        my $cs; $cs = $1 if $e =~ s/(\.gz)\z//; # compress suffix
        next unless $e =~ /\A\Q$self->{prefix}\E
                           (?:\. (?<period>\d{4}(?:-\d\d(?:-\d\d)?)?) )?
                           \Q$self->{suffix}\E
                           (?:\. (?<rotate_suffix>\d+) )?
                           \z
                          /x;
        push @files,
          [ $e, $+{rotate_suffix} // 0, $+{period} // "", $cs // "" ];
    }
    closedir($dh);

    [ sort { $a->[2] cmp $b->[2] || $b->[1] <=> $a->[1] } @files ];
}

# rename (increase rotation suffix) and keep only n histories. note: failure in
# rotating should not be fatal, we just warn and return.
sub _rotate_and_delete {
    my ($self, %opts) = @_;

    my $delete_only = $opts{delete_only};
    my $lock = $self->_get_lock;
  CASE:
    {
        my $files = $self->_get_files or last CASE;

        # is there a compression process in progress? this is marked by the
        # existence of <prefix>-compress.pid PID file.
        #
        # XXX check validity of PID file, otherwise a stale PID file will always
        # prevent rotation to be done
        if (-f "$self->{dir}/$self->{prefix}-compress.pid") {
            warn "Compression is in progress, rotation is postponed";
            last CASE;
        }

        $self->{hook_before_rotate}->($self, [map {$_->[0]} @$files])
            if $self->{hook_before_rotate};

        my @deleted;
        my @renamed;

        my $i;
        my $dir = $self->{dir};