File Coverage

blib/lib/App/Rolling.pm

Criterion	Covered	Total	%
statement	58	72	80.5
branch	14	34	41.1
condition	3	8	37.5
subroutine	13	15	86.6
pod	1	1	100.0
total	89	130	68.4

package App::Rolling;
use strict;
use warnings;
use Carp qw/croak/;
use Getopt::Long qw/GetOptionsFromArray/;
use Pod::Usage;
use Path::Class qw/dir file/;
use IO::File;
use IO::Interactive qw/is_interactive/;

our $VERSION = '0.12';

sub run {
    my ($class, @argv) = @_;

    my %config = $class->_process(@argv);

    if (!$config{file}) {
        croak "-f --file is required";
    }
    else {
        $class->_roll(%config);
    }

    return 1;
}

sub _process {
    my ($self, @argv) = @_;

    my %config = $self->_config_read;

    pod2usage(2) unless @argv;

    GetOptionsFromArray(
        \@argv,
        'f|file=s'     => \$config{file},
        'a|age=i'      => \$config{age},
        'i|interval=i' => \$config{interval},
        't|through'    => \$config{through},
        'nr|no-rotate' => \$config{no_rotate},
        'h|help'       => sub {
            pod2usage(2);
        },
        'v|version'     => sub {
            print "roll v$App::Rolling::VERSION\n";
            exit 1;
        },
    ) or pod2usage(2);

    $config{file} = shift @argv unless $config{file};

    $config{age}      = 5  unless $config{age};
    $config{interval} = 60 unless $config{interval};

    return %config;
}

sub _config_read {
    my $self = shift;

    my $filename = $self->_config_file;

    return unless -e $filename;

    my $fh = IO::File->new($filename, '<')
        or croak "[ERROR] couldn't open config file $filename: $!";

    my %config;
    while (<$fh>) {
        chomp;
        next if /\A\s*\Z/sm;
        if (/\A(\w+):\s*(.+)\Z/sm) { $config{$1} = $2; }
    }

    undef $fh;

    return %config;
}

sub _config_file {
    my $self = shift;

    my $configdir = $ENV{'ROLLING_DIR'} || '';

    if ( !$configdir && $ENV{'HOME'} ) {
        $configdir = dir( $ENV{'HOME'}, '.rolling' );
    }

    return file($configdir, 'config');
}

sub _roll {
    my ($self, %config) = @_;

    if ( !is_interactive() ) {
        while ( my $line =  ) {
            my $age_id = int(time / $config{interval});
            my $now_suffix = $config{no_rotate} ? '' : '.' . $age_id;
            if (!$config{no_rotate} && $config{age}) {
                my $old_suffix = $age_id - $config{age};
                if (-e "$config{file}\.$old_suffix") {
                    unlink "$config{file}\.$old_suffix";
                }
            }
            my $file = "$config{file}$now_suffix";
            my $fh = IO::File->new($file, '>>')
                        or croak "[ERROR] could't open file $file: $!";
            $fh->print($line);
            undef $fh;
            print $line if $config{through};
        }
    }
}

1;

__END__