File Coverage

blib/lib/File/Rsync/Mirror/Recentfile/Done.pm

Criterion	Covered	Total	%
statement	142	165	86.0
branch	64	86	74.4
condition	31	36	86.1
subroutine	16	16	100.0
pod	5	5	100.0
total	258	308	83.7

package File::Rsync::Mirror::Recentfile::Done;

# use warnings;
use strict;

use File::Rsync::Mirror::Recentfile::FakeBigFloat qw(:all);

=encoding utf-8

=head1 NAME

File::Rsync::Mirror::Recentfile::Done - intervals of already rsynced timespans

=cut

use version; our $VERSION = qv('0.0.8');

=head1 SYNOPSIS

 my $done = File::Rsync::Mirror::Recentfile::Done->new;
 $done->register ( $recent_events, [3,4,5,9] ); # registers elements 3-5 and 9
 my $boolean = $done->covered ( $epoch );

=head1 DESCRIPTION

Keeping track of already rsynced timespans.

=head1 EXPORT

No exports.

=head1 CONSTRUCTORS

=head2 my $obj = CLASS->new(%hash)

Constructor. On every argument pair the key is a method name and the
value is an argument to that method name.

=cut

sub new {
    my($class, @args) = @_;
    my $self = bless {}, $class;
    while (@args) {
        my($method,$arg) = splice @args, 0, 2;
        $self->$method($arg);
    }
    return $self;
}

=head1 ACCESSORS

=cut

my @accessors;

BEGIN {
    @accessors = (
                  "__intervals",
                  "_logfile", # undocced: a small yaml dump appended on every change
                  "_rfinterval", # undocced: the interval of the holding rf
                 );

    my @pod_lines =
        split /\n/, <<'=cut'; push @accessors, grep {s/^=item\s+//} @pod_lines; }

=over 4

=item verbose

Boolean to turn on a bit verbosity.

=back

=cut

use accessors @accessors;

=head1 METHODS

=head2 $boolean = $obj->covered ( $epoch1, $epoch2 )

=head2 $boolean = $obj->covered ( $epoch )

The first form returns true if both timestamps $epoch1 and $epoch2 in
floating point notation have been registered within one interval,
otherwise false.

The second form returns true if this timestamp has been registered.

=cut
sub _is_sorted {
    my($self,$ivs) = @_;
    my $Lup;
    my $is_sorted = 1;
    for my $i (0..$#$ivs) {
        if (defined $Lup) {
            if (_bigfloatge ($ivs->[$i][0],$Lup)) {
                warn "Warning (may be harmless): F:R:M:R:Done object contains unsorted internal data";
                $DB::single++;
                return 0;
            }
        }
        $Lup = $ivs->[$i][0];
    }
    return $is_sorted;
}
sub covered {
    my($self, $epoch_high, $epoch_low) = @_;
    die "Alert: covered() called without or with undefined first argument" unless defined $epoch_high;
    my $intervals = $self->_intervals;
    return unless @$intervals;
    if (defined $epoch_low) {
        ($epoch_high,$epoch_low) = ($epoch_low,$epoch_high) if _bigfloatgt($epoch_low,$epoch_high);
    }
    my $is_sorted = $self->_is_sorted($intervals);
    for my $iv (@$intervals) {
        my($upper,$lower) = @$iv; # may be the same
        if (defined $epoch_low) {
            my $goodbound = 0;
            for my $e ($epoch_high,$epoch_low) {
                $goodbound++ if
                    $e eq $upper || $e eq $lower || (_bigfloatlt($e,$upper) && _bigfloatgt($e,$lower));
            }
            return 1 if $goodbound > 1;
        } else {
            if ( _bigfloatle ( $epoch_high, $upper ) ) {
                if ( _bigfloatge ( $epoch_high, $lower )) {
                    return 1; # "between"
                }
            } elsif ($is_sorted) {
                return 0; # no chance anymore
            }
        }
    }
    return 0;
}

=head2 (void) $obj1->merge ( $obj2 )

Integrates all intervals in $obj2 into $obj1. Overlapping intervals
are conflated/folded/consolidated. Sort order is preserved as decreasing.

=cut
sub merge {
    my($self, $other) = @_;
    my $intervals = $self->_intervals;
    my $ointervals = $other->_intervals;
  OTHER: for my $oiv (@$ointervals) {
        my $splicepos;
        if (@$intervals) {
          SELF: for my $i (0..$#$intervals) {
                my $iv = $intervals->[$i];
                if ( _bigfloatlt ($oiv->[0],$iv->[1]) ) {
                    # both oiv lower than iv => next
                    next SELF;
                }
                if ( _bigfloatgt ($oiv->[1],$iv->[0]) ) {
                    # both oiv greater than iv => insert
                    $splicepos = $i;
                    last SELF;
                }
                # larger(left-iv,left-oiv) becomes left, smaller(right-iv,right-oiv) becomes right
                $iv->[0] = _bigfloatmax ($oiv->[0],$iv->[0]);
                $iv->[1] = _bigfloatmin ($oiv->[1],$iv->[1]);
                next OTHER;
            }
            unless (defined $splicepos) {
                if ( _bigfloatlt ($oiv->[0], $intervals->[-1][1]) ) {
                    $splicepos = @$intervals;
                } else {
                    die "Panic: left-oiv[$oiv->[0]] should be smaller than smallest[$intervals->[-1][1]]";
                }
            }
            splice @$intervals, $splicepos, 0, [@$oiv];
        } else {
            $intervals->[0] = [@$oiv];
        }
    }
}

=head2 (void) $obj->register ( $recent_events_arrayref, $register_arrayref )

=head2 (void) $obj->register ( $recent_events_arrayref )

The first arrayref is a list of hashes that contain a key called
C which is a string looking like a number. The second arrayref
is a list if integers which point to elements in the first arrayref to
be registered.

The second form registers all events in $recent_events_arrayref.

=cut

sub register {
    my($self, $re, $reg) = @_;
    my $intervals = $self->_intervals;
    unless ($reg) {
        $reg = [0..$#$re];
    }
  REGISTRANT: for my $i (@$reg) {
        my $logfile = $self->_logfile;
        if ($logfile) {
            require YAML::Syck;
            open my $fh, ">>", $logfile or die "Could not open '$logfile': $!";
            print $fh YAML::Syck::Dump({
                                        At => "before",
                                        Brfinterval => $self->_rfinterval,
                                        Ci => $i,
                                        ($i>0 ? ("Dre-1" => $re->[$i-1]) : ()),
                                        "Dre-0" => $re->[$i],
                                        ($i<$#$re ? ("Dre+1" => $re->[$i+1]) : ()),
                                        Eintervals => $intervals,
                                       });
        }
        $self->_register_one
            ({
              i => $i,
              re => $re,
              intervals => $intervals,
             });
        if ($logfile) {
            require YAML::Syck;
            open my $fh, ">>", $logfile or die "Could not open '$logfile': $!";
            print $fh YAML::Syck::Dump({
                                        At => "after",
                                        intervals => $intervals,
                                       });
        }
    }
}

sub _register_one {
    my($self, $one) = @_;
    my($i,$re,$intervals) = @{$one}{qw(i re intervals)};
    die sprintf "Panic: illegal i[%d] larger than number of events[%d]", $i, $#$re
        if $i > $#$re;
    my $epoch = $re->[$i]{epoch};
    return if $self->covered ( $epoch );
    if (@$intervals) {
        my $registered = 0;
    IV: for my $iv (@$intervals) {
            my($ivhi,$ivlo) = @$iv; # may be the same
            if ($i > 0
                && _bigfloatge($re->[$i-1]{epoch}, $ivlo)
                && _bigfloatle($re->[$i-1]{epoch}, $ivhi)
                && _bigfloatge($iv->[1],$epoch)
               ) {
                # if left neighbor in re belongs to this interval,
                # then I belong to it too; let us lower the ivlo
                $iv->[1] = $epoch;
                $registered++;
            }
            if ($i < $#$re
                && _bigfloatle($re->[$i+1]{epoch}, $ivhi)
                && _bigfloatge($re->[$i+1]{epoch}, $ivlo)
                && _bigfloatle($iv->[0],$epoch)
               ) {
                # ditto for right neighbor; increase the ivhi
                $iv->[0] = $epoch;
                $registered++;
            }
            last IV if $registered>=2;
        }
        if ($registered == 2) {
            $self->_register_one_fold2
                (
                 $intervals,
                 $epoch,
                );
        } elsif ($registered == 1) {
            $self->_register_one_fold1 ($intervals);
        } else {
            $self->_register_one_fold0
                (
                 $intervals,
                 $epoch,
                );
        }
    } else {
        $intervals->[0] = [($epoch)x2];
    }
}

sub _register_one_fold0 {
    my($self,
       $intervals,
       $epoch,
      ) = @_;
    my $splicepos;
    for my $i (0..$#$intervals) {
        if (_bigfloatgt ($epoch, $intervals->[$i][0])) {
            $splicepos = $i;
            last;
        }
    }
    unless (defined $splicepos) {
        if (_bigfloatlt ($epoch,   $intervals->[-1][1])) {
            $splicepos = @$intervals;
        } else {
            die "Panic: epoch[$epoch] should be smaller than smallest[$intervals->[-1][1]]";
        }
    }
    splice @$intervals, $splicepos, 0, [($epoch)x2];
}

# conflate: eliminate overlapping intervals
sub _register_one_fold1 {
    my($self,$intervals) = @_;
 LOOP: while () {
        my $splicepos;
        for my $i (0..$#$intervals-1) {
            if (_bigfloatle ($intervals->[$i][1],
                             $intervals->[$i+1][0])) {
                $intervals->[$i+1][0] = $intervals->[$i][0];
                $splicepos = $i;
                last;
            }
        }
        if (defined $splicepos) {
            splice @$intervals, $splicepos, 1;
        } else {
            last LOOP;
        }
    }
}

sub _register_one_fold2 {
    my($self,
       $intervals,
       $epoch,
      ) = @_;
    # we know we have hit twice, like in
    # 40:[45,40],        [40,35]
    # 40:[45,40],[42,37],[40,35]
    # 45:[45,40],        [45,35]
    # 45:[45,40],[42,37],[45,35]
    # 35:[45,35],        [40,35]
    # 35:[45,35],[42,37],[40,35]
    my($splicepos, $splicelen, %assert_between);
 INTERVAL: for my $i (0..$#$intervals) {
        if (   $epoch eq $intervals->[$i][0]
            or $epoch eq $intervals->[$i][1]
           ) {
            for (my $j = 1; $i+$j <= $#$intervals; $j++) {
                if (   $epoch eq $intervals->[$i+$j][0]
                    or $epoch eq $intervals->[$i+$j][1]) {
                    $intervals->[$i+$j][0] = _bigfloatmax($intervals->[$i][0],$intervals->[$i+$j][0]);
                    $intervals->[$i+$j][1] = _bigfloatmin($intervals->[$i][1],$intervals->[$i+$j][1]);
                    $splicepos = $i;
                    $splicelen = $j;
                    last INTERVAL;
                } else {
                    for my $k (0,1) {
                        $assert_between{$intervals->[$i+$j][$k]}++;
                    }
                }
            }
        }
    }
    if (defined $splicepos) {
        for my $k (keys %assert_between) {
            if (_bigfloatgt($k,$intervals->[$splicepos+$splicelen][0])
                or _bigfloatlt($k,$intervals->[$splicepos+$splicelen][1])){
                $DB::single=1;
                require Data::Dumper;
                die "Panic: broken intervals:".Data::Dumper::Dumper($intervals);
            }
        }
        splice @$intervals, $splicepos, $splicelen;
    } else {
        $DB::single=1;
        die "Panic: Could not find an interval position to insert '$epoch'";
    }
}

=head2 reset

Forgets everything ever done and gives way for a new round of
mirroring. Usually called when the dirtymark on upstream has changed.

=cut

sub reset {
    my($self) = @_;
    $self->_intervals(undef);
}

=head1 PRIVATE METHODS

=head2 _intervals

=cut
sub _intervals {
    my($self,$set) = @_;
    if (@_ >= 2) {
        $self->__intervals($set);
    }
    my $x = $self->__intervals;
    unless (defined $x) {
        $x = [];
        $self->__intervals ($x);
    }
    return $x;
}

=head1 COPYRIGHT & LICENSE

Copyright 2008, 2009 Andreas König.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of File::Rsync::Mirror::Recentfile

# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End: