File Coverage

blib/lib/App/JobLog/Vacation/Period.pm

Criterion	Covered	Total	%
statement	36	187	19.2
branch	0	66	0.0
condition	0	40	0.0
subroutine	12	33	36.3
pod	14	15	93.3
total	62	341	18.1

package App::JobLog::Vacation::Period;
$App::JobLog::Vacation::Period::VERSION = '1.041';
# ABSTRACT: extension of L to handle special properties of vacation periods


use Exporter 'import';
our @EXPORT_OK = qw(
  FLEX
  FIXED
  ANNUAL
  MONTHLY
);

use base 'App::JobLog::Log::Event';
use DateTime;
use App::JobLog::Log::Line;
use App::JobLog::Time qw(tz);
use Carp qw(carp);

use overload '""' => \&to_string;
use overload 'bool' => sub { 1 };

use constant FLEX    => 1;
use constant FIXED   => 2;
use constant ANNUAL  => 1;
use constant MONTHLY => 2;

sub new {
    my ( $class, $log_line, %opts ) = @_;
    $class = ref $class || $class;
    bless {
        log      => $log_line,
        type     => 0,
        repeats  => 0,
        tags     => [],
        events   => [],
        vacation => [],
        %opts
      },
      $class;
}


sub flex { $_[0]->{type} == FLEX }


sub fixed { $_[0]->{type} == FIXED }


sub annual { $_[0]->{repeats} == ANNUAL }


sub monthly { $_[0]->{repeats} == MONTHLY }


sub repeats { $_[0]->{repeats} }


sub description : lvalue {
    $_[0]->data->description;
}


sub clone {
    my ($self) = @_;
    my $clone = $self->SUPER::clone;
    $clone->{type}    = $self->{type};
    $clone->{repeats} = $self->{repeats};
    return $clone;
}


sub cmp {
    my ( $self, $other ) = @_;

    # when mixed with ordinary events
    if ( ref $other eq 'App::JobLog::Log::Event' ) {

        # treat as an ordinary event if fixed
        return $self->SUPER::cmp($other) if $self->fixed;

        # put after ordinary events
        return 1;
    }
    if ( $self->monthly ) {
        return -1 unless $other->monthly;
    }
    elsif ( $self->annual ) {
        return 1 if $other->monthly;
        return -1 unless $other->annual;
    }
    return $self->SUPER::cmp($other);
}

# some global variables for use in BNF regex
our ( @dates, $type, @tags, $description );

# log line parser
my $re = qr{
    ^ (?&ts) : (?&non_ts) $
    (?(DEFINE)
     (? (?&date) : (?&date) )
     (? (\d{4}\s++\d++\s++\d++\s++\d++\s++\d++\s++\d++) (?{push @dates, $^N}) )
     (? (?&flex) : (?&tags) : (?&description))
     (? ([012]{2}) (?{$type = $^N}))
     (? (?:(?&tag)(\s++(?&tag))*+)?)
     (? ((?:[^\s:\\]|(?&escaped))++) (?{push @tags, $^N}))
     (? \\.)
     (? (.++) (?{$description = $^N}))
    )
}xi;


sub parse {
    my ( $class, $text ) = @_;
    $class = ref $class || $class;
    local ( @dates, $type, @tags, $description );
    if ( $text =~ $re ) {
        my $start = _parse_time( $dates[0] );
        my $end   = _parse_time( $dates[1] );
        my %tags  = map { $_ => 1 } @tags;
        my $tags  = [ map { s/\\(.)/$1/g; $_ } sort keys %tags ];
        $description = [ map { s/\\(.)/$1/g; $_ } ($description) ];
        my ( $type, $repeats ) = split //, $type;
        $obj = $class->new(
            App::JobLog::Log::Line->new(
                description => $description,
                time        => $start,
                tags        => $tags
            ),
            type    => $type,
            repeats => $repeats,
            end     => $end
        );
        return $obj;
    }
    else {
        carp "malformed line in vacation file: '$text'";
    }
    return;
}

sub _parse_time {
    my @time = split /\s++/, $_[0];
    $date = DateTime->new(
        year      => $time[0],
        month     => $time[1],
        day       => $time[2],
        hour      => $time[3],
        minute    => $time[4],
        second    => $time[5],
        time_zone => tz,
    );
    return $date;
}


sub to_string {
    my ($self) = @_;
    my $text = $self->data->time_stamp( $self->start );
    $text .= ':';
    $text .= $self->data->time_stamp( $self->end );
    $text .= ':';
    if ( $self->flex ) {
        $text .= FLEX;
    }
    elsif ( $self->fixed ) {
        $text .= FIXED;
    }
    else {
        $text .= 0;
    }
    if ( $self->annual ) {
        $text .= ANNUAL;
    }
    elsif ( $self->monthly ) {
        $text .= MONTHLY;
    }
    else {
        $text .= 0;
    }
    $text .= ':';
    $self->tags ||= [];
    my %tags = map { $_ => 1 } @{ $self->tags };
    $text .= join ' ', map { s/([:\\\s])/\\$1/g; $_ } sort keys %tags;
    $text .= ':';
    $self->description ||= [];
    $text .= join ';',
      map { ( my $d = $_ ) =~ s/([;\\])/\\$1/g; $d } @{ $self->description };
}


sub conflicts {
    my ( $self, $other ) = @_;
    return 1 if $self->intersects($other);
    my $other_is_period = ref $other eq __PACKAGE__;
    if ( $self->annual || $other_is_period && $other->annual ) {
        if ( $self->start->year != $other->start->year ) {
            if ( !$self->annual ) {
                my $t = $self;
                $self  = $other;
                $other = $t;
            }
            $self = $self->clone;
            my $d = $self->start->year - $other->start->year;
            $self->start->subtract( years => $d );
            $self->end->subtract( years => $d );
            return $self->intersects($other);
        }
    }
    elsif ( $self->monthly || $other_is_period && $other->monthly ) {
        if (   $self->start->year != $other->start->year
            || $self->start->month != $other->start->month )
        {
            if ( !$self->monthly ) {
                my $t = $self;
                $self  = $other;
                $other = $t;
            }
            $self = $self->clone;
            my $d = $self->start->year - $other->start->year;
            $self->start->subtract( years => $d );
            $self->end->subtract( years => $d );
            $d = $self->start->month - $other->start->month;
            $self->start->subtract( months => $d );
            $self->end->subtract( months => $d );
            return $self->intersects($other);
        }
    }
    return 0;
}


sub parts {
    my ($self) = @_;
    return $self->_time, $self->_properties, $self->_tags, $self->_description;
}


sub single_day {
    my ($self) = @_;
    my ( $s, $e ) = ( $self->start, $self->end );
    return $s->year == $e->year && $s->month == $e->month && $s->day == $e->day;
}

# time part of summary
sub _time {
    my ($self) = @_;
    my $fmt;
    if ( $self->annual ) {
        $fmt = '%b %d';
    }
    elsif ( $self->monthly ) {
        $fmt = '%d';
    }
    else {
        $fmt = '%F';
    }
    $fmt .= ' %H:%M:%S' if $self->fixed;
    my $s;
    if ( $self->single_day ) {
        $s = $self->start->strftime($fmt);
    }
    else {
        $s = $self->start->strftime($fmt) . ' -- ' . $self->end->strftime($fmt);
    }
    return $s;
}

# properties part of summary
sub _properties {
    my ($self) = @_;
    my $s;
    if ( $self->fixed ) {
        $s = 'fixed';
    }
    elsif ( $self->flex ) {
        $s = 'flex';
    }
    else {
        $s = '';
    }
    if ( $self->annual ) {
        $s .= ' ' if $s;
        $s .= 'annual';
    }
    elsif ( $self->monthly ) {
        $s .= ' ' if $s;
        $s .= 'monthly';
    }
    return $s;
}


sub overlap {
    my ( $self, $start, $end ) = @_;
    if ( $self->annual || $self->monthly ) {

        # cloning here should be duplicated work, but better safe than sorry
        my $cloned = 0;
        if (   $self->annual
            || $self->monthly && $self->start->year != $start->year )
        {
            $self   = $self->clone;
            $cloned = 1;
            my $delta = $start->year - $self->start->year;
            $self->start->add( years => $delta );
            $self->end->add( years => $delta );
        }
        if ( $self->monthly && $self->start->month != $start->month ) {
            $self = $self->clone unless $cloned;
            my $delta = $start->month - $self->start->month;
            $self->start->add( months => $delta );
            $self->end->add( months => $delta );
        }
    }
    return $self->SUPER::overlap( $start, $end );
}

# tag part of summary
sub _tags {
    my ($self) = @_;
    return join ', ', @{ $self->tags };
}

# description part of summary
sub _description {
    my ($self) = @_;
    return join '; ', @{ $self->description };
}

1;

__END__