File Coverage

blib/lib/Dir/Write/Rotate.pm

Criterion	Covered	Total	%
statement	120	130	92.3
branch	52	68	76.4
condition	12	15	80.0
subroutine	9	9	100.0
pod	3	3	100.0
total	196	225	87.1

package Dir::Write::Rotate;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-11-17'; # DATE
our $DIST = 'Dir-Write-Rotate'; # DIST
our $VERSION = '0.004'; # VERSION

use strict;
use warnings;

use Fcntl qw(:DEFAULT);

sub _debug {
    return unless $ENV{DIR_WRITE_ROTATE_DEBUG};
    warn "[Dir::Write::Rotate] debug: $_[0]\n";
}

sub new {
    my ($pkg, %args) = @_;

    my $self = {};
    if (defined(my $v = delete $args{path})) {
        $self->{path} = $v;
    } else {
        die "Please specify path";
    }
    if (defined(my $v = delete $args{filename_pattern})) {
        $self->{filename_pattern} = $v;
    } else {
        $self->{filename_pattern} = '%Y-%m-%d-%H%M%S.pid-%{pid}.%{ext}';
    }
    if (defined(my $v = delete $args{filename_sub})) {
        $self->{filename_sub} = $v;
    }
    if (defined(my $v = delete $args{max_size})) {
        $self->{max_size} = $v;
    }
    if (defined(my $v = delete $args{max_files})) {
        $self->{max_files} = $v;
    }
    if (defined(my $v = delete $args{max_age})) {
        $self->{max_age} = $v;
    }
    if (defined(my $v = delete $args{rotate_probability})) {
        $self->{rotate_probability} = $v;
    } else {
        $self->{rotate_probability} = 0.25;
    }
    if (keys %args) {
        die "Unknown argument(s): ".join(", ", sort keys %args);
    }
    _debug "instantiated with params: ".
        join(", ", map {"$_=$self->{$_}"} sort keys %$self);
    bless $self, $pkg;
}

my $default_ext = 'log';
my $libmagic;
sub _resolve_pattern {
    my ($self, $content) = @_;

    if ($self->{filename_sub}) {
        return $self->{filename_sub}($self, $content);
    }

    require POSIX;

    my $pat = $self->{filename_pattern};
    my $now = time;

    my @vars = qw(Y y m d H M S z Z %);
    my $strftime = POSIX::strftime(join("|", map {"%$_"} @vars),
                                   localtime($now));
    my %vars;
    my $i = 0;
    for (split /\|/, $strftime) {
        $vars{ $vars[$i] } = $_;
        $i++;
    }

    push @vars, "{pid}";
    $vars{"{pid}"} = $$;

    push @vars, "{ext}";
    $vars{"{ext}"} = sub {
        unless (defined $libmagic) {
            if (eval { require File::LibMagic;
                       require Media::Type::Simple; 1 }) {
                $libmagic = File::LibMagic->new;
            } else {
                $libmagic = 0;
            }
        }
        return $default_ext unless $libmagic;
        my $type = $libmagic->checktype_contents($content);
        return $default_ext unless $type;
        $type =~ s/[; ].*//; # only get the mime type
        my $ext = Media::Type::Simple::ext_from_type($type);
        ($ext) = $ext =~ /(.+)/ if $ext; # untaint
        return $ext || $default_ext;
    };

    my $res = $pat;
    $res =~ s[%(\{\w+\}|\S)]
             [defined($vars{$1}) ?
                  ( ref($vars{$1}) eq 'CODE' ?
                        $vars{$1}->() : $vars{$1} ) :
                            die("Invalid format in filename_pattern `%$1'")]eg;
    $res;
}

sub write {
    my ($self, $content) = @_;

    my $filename0 = $self->_resolve_pattern($content);

    my $filename = "$self->{path}/$filename0";
    my $i = 0;
    my $fh;
    while (1) {
        if (-e $filename) {
            $i++;
            $filename = "$self->{path}/$filename0.$i";
            next;
        }
        # to avoid race condition
        sysopen($fh, $filename, O_WRONLY|O_CREAT|O_EXCL)
            or die "Can't open $filename: $!";
        last;
    }
    print $fh $content or die "Can't print to $filename: $!";
    close $fh or die "Can't write to $filename: $!";
    $self->rotate if (rand() < $self->{rotate_probability});
}

sub rotate {
    my $self = shift;

    my $ms = $self->{max_size};
    my $mf = $self->{max_files};
    my $ma = $self->{max_age};

    return unless (defined($ms) || defined($mf) || defined($ma));

    my @entries;
    my $now = time;
    my $path = $self->{path};
    opendir my $dh, $path or die "Can't open dir $path: $!";
    while (my $e = readdir $dh) {
        ($e) = $e =~ /(.*)/s; # untaint
        next if $e eq '.' || $e eq '..';
        my @st = stat "$path/$e";
        push @entries, {name => $e, age => ($now-$st[10]), size => $st[7]};
    }
    closedir $dh;

    @entries = sort {
        $a->{age} <=> $b->{age} ||
            $b->{name} cmp $a->{name}
    } @entries;

    # max files
    if (defined($mf) && @entries > $mf) {
        for (splice @entries, $mf) {
            my $fpath = "$path/$_->{name}";
            _debug "rotate: unlinking $fpath (max_files $mf exceeded)";
            unlink $fpath or warn "Can't unlink $fpath: $!";
        }
    }

    # max age
    if (defined($ma)) {
        my $i = 0;
        for (@entries) {
            if ($_->{age} > $ma) {
                for (splice @entries, $i) {
                    my $fpath = "$path/$_->{name}";
                    _debug "rotate: unlinking $fpath (age=$_->{age}) (max_age $ma exceeded)";
                    unlink $fpath or warn "Can't unlink $fpath: $!";
                }
                last;
            }
            $i++;
        }
    }

    # max size
    if (defined($ms)) {
        my $i = 0;
        my $tot_size = 0;
        for (@entries) {
            $tot_size += $_->{size};
            if ($tot_size > $ms) {
                for (splice @entries, $i) {
                    my $fpath = "$path/$_->{name}";
                    _debug "rotate: unlinking $fpath (size=$_->{size}) (max_size $ms exceeded)";
                    unlink $fpath or warn "Can't unlink $fpath: $!";
                }
                last;
            }
            $i++;
        }
    }
}

1;
# ABSTRACT: Write files to a directory, with rotate options

__END__