view release on metacpan or  search on metacpan

lib/App/JobLog/Command/truncate.pm  view on Meta::CPAN

package App::JobLog::Command::truncate;
$App::JobLog::Command::truncate::VERSION = '1.042';
# ABSTRACT: decapitate the log


use App::JobLog -command;
use autouse 'App::JobLog::TimeGrammar' => qw(parse);
use Class::Autouse
  qw(IO::File App::JobLog::Log App::JobLog::Log::Line File::Temp File::Spec);
use autouse 'App::JobLog::Time'   => qw(now);
use autouse 'App::JobLog::Config' => qw(log dir);
use autouse 'File::Copy'          => qw(move);

use Modern::Perl;
no if $] >= 5.018, warnings => "experimental::smartmatch";

sub execute {
    my ( $self, $opt, $args ) = @_;
    my $expression = join ' ', @$args;
    my ( $s, $is_interval );
    eval { ( $s, undef, $is_interval ) = parse $expression; };
    $self->usage_error($@) if $@;
    $self->usage_error('truncation date must not be a interval')
      if $is_interval;

    # determine name of head log
    my $log = App::JobLog::Log->new;
    my ($p) = $log->find_previous($s);
    $self->usage("no event in log prior to $expression") unless $p;
    my ($e) = $log->first_event;
    my $base = 'log-' . $e->start->ymd . '--' . $p->start->ymd;

    # create output handle for head log
    my $io =
      $opt->compression ? _pick_compression( $opt->compression ) : 'IO::File';
    my $suffix = '';
    my @args   = ();
    for ($io) {
        when ('IO::File') { push @args, 'w' }
        when ('IO::Compress::Zip') {
            $suffix = '.zip';
            push @args, Name => $base;
        }
        when ('IO::Compress::Gzip')  { $suffix = '.gz' }
        when ('IO::Compress::Bzip2') { $suffix = '.bz2' }
        when ('IO::Compress::Lzma')  { $suffix = '.lzma' }
        default { die "unprepared to handle $io; please report bug" };
    }
    my $old_f = File::Spec->catfile( dir, $base . $suffix );
    my $old_fh     = $io->new( $old_f, @args );
    my $fh         = File::Temp->new;
    my $current_fh = $old_fh;
    my $log_handle = IO::File->new( log, 'r' );
    my ( $unswitched, @buffer, $previous ) = (1);
    while ( defined( my $line = $log_handle->getline ) ) {
        my $ll = App::JobLog::Log::Line->parse($line);
        if ( $ll->is_event ) {
            if ($unswitched) {
                $previous = $ll if $ll->is_beginning;
                if ( $ll->time > $s ) {
                    if ($previous) {    # event spanning border
                        my $end_time = $s->clone->subtract( seconds => 1 );
                        $current_fh->print(
                            App::JobLog::Log::Line->new(
                                done => 1,
                                time => $end_time
                            )
                        );
                        $previous->time = $s;
                        $line = $previous->to_string . "\n";
                    }
                    $current_fh->close;
                    $current_fh = $fh;
                    _header( $base, $suffix, \@buffer );