view release on metacpan or  search on metacpan

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

    # FYI: if privilege is dropped from superuser, the failure is usually at
    # locking the lock file (permission denied).

    my @msg = (map( {@$_} @{ $self->{_buffer} } ), @_);

    eval {
        my $lock = $self->_get_lock;

        $self->_rotate_and_open;

        $self->{hook_before_write}->($self, \@msg, $self->{_fh})
            if $self->{hook_before_write};

        print { $self->{_fh} } @msg;
        $self->{_buffer} = [];

    };
    my $err = $@;

    if ($err) {
        if (($self->{buffer_size} // 0) > @{ $self->{_buffer} }) {
            # put message to buffer temporarily
            push @{ $self->{_buffer} }, [@_];
        } else {
            # buffer is already full, let's dump the buffered + current message
            # to the die message anyway.
            die join(
                "",
                "Can't write",
                (
                    @{ $self->{_buffer} }
                    ? " (buffer is full, "
                      . scalar(@{ $self->{_buffer} })
                      . " message(s))"
                    : ""
                ),
                ": $err, message(s)=",
                @msg
            );
        }
    }
}

sub compress {
    my ($self) = shift;

    my $lock           = $self->_get_lock;
    my $files_ref        = $self->_get_files;
    my $done_compression = 0;

    if (@{$files_ref}) {
        require Proc::PID::File;

        my $pid = Proc::PID::File->new(
            dir    => $self->{dir},
            name   => "$self->{prefix}-compress",
            verify => 1,
        );
        my $latest_period = $files_ref->[-1][2];

        if ($pid->alive) {
            warn "Another compression is in progress";
        } else {
            my @tocompress;
            #use DD; dd $self;
            for my $file_ref (@{$files_ref}) {
                my ($orig, $rs, $period, $cs) = @{ $file_ref };
                #say "D:compress: orig=<$orig> rs=<$rs> period=<$period> cs=<$cs>";
                next if $cs; # already compressed
                next if !$self->{period} && !$rs; # not old file
                next if  $self->{period} && $period eq $latest_period; # not old file
                push @tocompress, File::Spec->catfile($self->{dir}, $orig);
            }

            if (@tocompress) {
                for my $file (@tocompress) {
                    gzip($file => "$file.gz")
                        or do { warn "gzip failed: $GzipError\n"; next };
                    unlink $file;
                }
                $done_compression = 1;
            }
        }
    }

    return $done_compression;

}

sub DESTROY {
    my ($self) = @_;

    # Proc::PID::File's DESTROY seem to create an empty PID file, remove it.
    unlink "$self->{dir}/$self->{prefix}-compress.pid";
}

1;

# ABSTRACT: Write to files that archive/rotate themselves

__END__

=pod

=encoding UTF-8

=head1 NAME

File::Write::Rotate - Write to files that archive/rotate themselves

=head1 VERSION

This document describes version 0.321 of File::Write::Rotate (from Perl distribution File-Write-Rotate), released on 2019-06-27.

=head1 SYNOPSIS

 use File::Write::Rotate;

 my $fwr = File::Write::Rotate->new(
     dir          => '/var/log',    # required
     prefix       => 'myapp',       # required