projekt kivitendo

package DateTime::Event::Cron;

use 5.006;

use strict;

use warnings;

use Carp;

use vars qw($VERSION);

$VERSION = '0.08';

use constant DEBUG => 0;

use DateTime;

use DateTime::Set;

use Set::Crontab;

my %Object_Attributes;

###

sub from_cron {

  # Return cron as DateTime::Set

  my $class = shift;

  my %sparms = @_ == 1 ? (cron => shift) : @_;

  my %parms;

  $parms{cron}      = delete $sparms{cron};

  $parms{user_mode} = delete $sparms{user_mode};

  $parms{cron} or croak "Cron string parameter required.\n";

  my $dtc = $class->new(%parms);

  $dtc->as_set(%sparms);

}

sub from_crontab {

  # Return list of DateTime::Sets based on entries from

  # a crontab file.

  my $class = shift;

  my %sparms = @_ == 1 ? (file => shift) : @_;

  my $file = delete $sparms{file};

  delete $sparms{cron};

  my $fh = $class->_prepare_fh($file);

  my @cronsets;

  while (<$fh>) {

    chomp;

    my $set;

    eval { $set = $class->from_cron(%sparms, cron => $_) };

    push(@cronsets, $set) if ref $set && !$@;

  }

  @cronsets;

}

sub as_set {

  # Return self as DateTime::Set

  my $self = shift;

  my %sparms = @_;

  Carp::cluck "Recurrence callbacks overriden by ". ref $self . "\n"

    if $sparms{next} || $sparms{recurrence} || $sparms{previous};

  delete $sparms{next};

  delete $sparms{previous};

  delete $sparms{recurrence};

  $sparms{next}     = sub { $self->next(@_) };

  $sparms{previous} = sub { $self->previous(@_) };

  DateTime::Set->from_recurrence(%sparms);

}

###

sub new {

  my $class = shift;

  my $self = {};

  bless $self, $class;

  my %parms = @_ == 1 ? (cron => shift) : @_;

  my $crontab = $self->_make_cronset(%parms);

  $self->_cronset($crontab);

  $self;

}

sub new_from_cron { new(@_) }

sub new_from_crontab {

  my $class = shift;

  my %parms = @_ == 1 ? (file => shift()) : @_;

  my $fh = $class->_prepare_fh($parms{file});

  delete $parms{file};

  my @dtcrons;

  while (<$fh>) {

    my $dtc;

    eval { $dtc = $class->new(%parms, cron => $_) };

    if (ref $dtc && !$@) {

      push(@dtcrons, $dtc);

      $parms{user_mode} = 1 if defined $dtc->user;

    }

  }

  @dtcrons;

}

###

sub _prepare_fh {

  my $class = shift;

  my $fh = shift;

  if (! ref $fh) {

    my $file = $fh;

    local(*FH);

    $fh = do { local *FH; *FH }; # doubled *FH avoids warning

    open($fh, "<$file")

      or croak "Error opening $file for reading\n";

  }

  $fh;

}

###

sub valid {

  # Is the given date valid according the current cron settings?

  my($self, $date) = @_;

  return if !$date || $date->second;

  $self->minute->contains($date->minute)      &&

  $self->hour->contains($date->hour)          &&

  $self->days_contain($date->day, $date->dow) &&

  $self->month->contains($date->month);

}

sub match {

  # Does the given date match the cron spec?

  my($self, $date) = @_;

  $date = DateTime->now unless $date;

  $self->minute->contains($date->minute)      &&

  $self->hour->contains($date->hour)          &&

  $self->days_contain($date->day, $date->dow) &&

  $self->month->contains($date->month);

}

### Return adjacent dates without altering original date

sub next {

  my($self, $date) = @_;

  $date = DateTime->now unless $date;

  $self->increment($date->clone);

}

sub previous {

  my($self, $date) = @_;

  $date = DateTime->now unless $date;

  $self->decrement($date->clone);

}

### Change given date to adjacent dates

sub increment {

  my($self, $date) = @_;

  $date = DateTime->now unless $date;

  return $date if $date->is_infinite;

  do {

    $self->_attempt_increment($date);

  } until $self->valid($date);

  $date;

}

sub decrement {

  my($self, $date) = @_;

  $date = DateTime->now unless $date;

  return $date if $date->is_infinite;

  do {

    $self->_attempt_decrement($date);

  } until $self->valid($date);

  $date;

}

###

sub _attempt_increment {

  my($self, $date) = @_;

  ref $date or croak "Reference to datetime object reqired\n";

  $self->valid($date) ?

    $self->_valid_incr($date) :

    $self->_invalid_incr($date);

}

sub _attempt_decrement {

  my($self, $date) = @_;

  ref $date or croak "Reference to datetime object reqired\n";

  $self->valid($date) ?

    $self->_valid_decr($date) :

    $self->_invalid_decr($date);

}

sub _valid_incr { shift->_minute_incr(@_) }

sub _valid_decr { shift->_minute_decr(@_) }

sub _invalid_incr {

  # If provided date is valid, return it. Otherwise return

  # nearest valid date after provided date.

  my($self, $date) = @_;

  ref $date or croak "Reference to datetime object reqired\n";

  print STDERR "\nI GOT: ", $date->datetime, "\n" if DEBUG;

  $date->truncate(to => 'minute')->add(minutes => 1)

    if $date->second;

  print STDERR "RND: ", $date->datetime, "\n" if DEBUG;

  # Find our greatest invalid unit and clip

  if (!$self->month->contains($date->month)) {

    $date->truncate(to => 'month');

  }

  elsif (!$self->days_contain($date->day, $date->dow)) {

    $date->truncate(to => 'day');

  }

  elsif (!$self->hour->contains($date->hour)) {

    $date->truncate(to => 'hour');

  }

  else {

    $date->truncate(to => 'minute');

  }

  print STDERR "BBT: ", $date->datetime, "\n" if DEBUG;

  return $date if $self->valid($date);

  print STDERR "ZZT: ", $date->datetime, "\n" if DEBUG;

  # Extraneous durations clipped. Start searching.

  while (!$self->valid($date)) {

    $date->add(months => 1) until $self->month->contains($date->month);

    print STDERR "MON: ", $date->datetime, "\n" if DEBUG;

    my $day_orig = $date->day;

    $date->add(days => 1) until $self->days_contain($date->day, $date->dow);

    $date->truncate(to => 'month') && next if $date->day < $day_orig;

    print STDERR "DAY: ", $date->datetime, "\n" if DEBUG;

    my $hour_orig = $date->hour;

    $date->add(hours => 1) until $self->hour->contains($date->hour);

    $date->truncate(to => 'day') && next if $date->hour < $hour_orig;

    print STDERR "HOR: ", $date->datetime, "\n" if DEBUG;

    my $min_orig = $date->minute;

    $date->add(minutes => 1) until $self->minute->contains($date->minute);

    $date->truncate(to => 'hour') && next if $date->minute < $min_orig;

    print STDERR "MIN: ", $date->datetime, "\n" if DEBUG;

  }

  print STDERR "SET: ", $date->datetime, "\n" if DEBUG;

  $date;

}

sub _invalid_decr {

  # If provided date is valid, return it. Otherwise

  # return the nearest previous valid date.

  my($self, $date) = @_;

  ref $date or croak "Reference to datetime object reqired\n";

  print STDERR "\nD GOT: ", $date->datetime, "\n" if DEBUG;

  if (!$self->month->contains($date->month)) {

    $date->truncate(to => 'month');

  }

  elsif (!$self->days_contain($date->day, $date->dow)) {

    $date->truncate(to => 'day');

  }

  elsif (!$self->hour->contains($date->hour)) {

    $date->truncate(to => 'hour');

  }

  else {

    $date->truncate(to => 'minute');

  }

  print STDERR "BBT: ", $date->datetime, "\n" if DEBUG;

  return $date if $self->valid($date);

  print STDERR "ZZT: ", $date->datetime, "\n" if DEBUG;

  # Extraneous durations clipped. Start searching.

  while (!$self->valid($date)) {

    if (!$self->month->contains($date->month)) {

      $date->subtract(months => 1) until $self->month->contains($date->month);

      $self->_unit_peak($date, 'month');

      print STDERR "MON: ", $date->datetime, "\n" if DEBUG;

    }

    if (!$self->days_contain($date->day, $date->dow)) {

      my $day_orig = $date->day;

      $date->subtract(days => 1)

        until $self->days_contain($date->day, $date->dow);

      $self->_unit_peak($date, 'month') && next if ($date->day > $day_orig);

      $self->_unit_peak($date, 'day');

      print STDERR "DAY: ", $date->datetime, "\n" if DEBUG;

    }

    if (!$self->hour->contains($date->hour)) {

      my $hour_orig = $date->hour;

      $date->subtract(hours => 1) until $self->hour->contains($date->hour);

      $self->_unit_peak($date, 'day') && next if ($date->hour > $hour_orig);

      $self->_unit_peak($date, 'hour');

      print STDERR "HOR: ", $date->datetime, "\n" if DEBUG;

    }

    if (!$self->minute->contains($date->minute)) {

      my $min_orig = $date->minute;

      $date->subtract(minutes => 1)

        until $self->minute->contains($date->minute);

      $self->_unit_peak($date, 'hour') && next if ($date->minute > $min_orig);

      print STDERR "MIN: ", $date->datetime, "\n" if DEBUG;

    }

  }

  print STDERR "SET: ", $date->datetime, "\n" if DEBUG;

  $date;

}

###

sub _unit_peak {

  my($self, $date, $unit) = @_;

  $date && $unit or croak "DateTime ref and unit required.\n";

  $date->truncate(to => $unit)

       ->add($unit . 's' => 1)

       ->subtract(minutes => 1);

}

### Unit cascades

sub _minute_incr {

  my($self, $date) = @_;

  croak "datetime object required\n" unless $date;

  my $cur = $date->minute;

  my $next = $self->minute->next($cur);

  $date->set(minute => $next);

  $next <= $cur ? $self->_hour_incr($date) : $date;

}

sub _hour_incr {

  my($self, $date) = @_;

  croak "datetime object required\n" unless $date;

  my $cur = $date->hour;

  my $next = $self->hour->next($cur);

  $date->set(hour => $next);

  $next <= $cur ? $self->_day_incr($date) : $date;

}

sub _day_incr {

  my($self, $date) = @_;

  croak "datetime object required\n" unless $date;

  $date->add(days => 1);

  $self->_invalid_incr($date);

}

sub _minute_decr {

  my($self, $date) = @_;

  croak "datetime object required\n" unless $date;

  my $cur = $date->minute;

  my $next = $self->minute->previous($cur);

  $date->set(minute => $next);

  $next >= $cur ? $self->_hour_decr($date) : $date;

}

sub _hour_decr {

  my($self, $date) = @_;

  croak "datetime object required\n" unless $date;

  my $cur = $date->hour;

  my $next = $self->hour->previous($cur);

  $date->set(hour => $next);

  $next >= $cur ? $self->_day_decr($date) : $date;

}

sub _day_decr {

  my($self, $date) = @_;

  croak "datetime object required\n" unless $date;

  $date->subtract(days => 1);

  $self->_invalid_decr($date);

}

### Factories

sub _make_cronset { shift; DateTime::Event::Cron::IntegratedSet->new(@_) }

### Shortcuts

sub days_contain { shift->_cronset->days_contain(@_) }

sub minute   { shift->_cronset->minute  }

sub hour     { shift->_cronset->hour    }

sub day      { shift->_cronset->day     }

sub month    { shift->_cronset->month   }

sub dow      { shift->_cronset->dow     }

sub user     { shift->_cronset->user    }

sub command  { shift->_cronset->command }

sub original { shift->_cronset->original }

### Static acessors/mutators

sub _cronset { shift->_attr('cronset', @_) }

sub _attr {

  my $self = shift;

  my $name = shift;

  if (@_) {

    $Object_Attributes{$self}{$name} = shift;

  }

  $Object_Attributes{$self}{$name};

}

### debugging

sub _dump_sets {

  my($self, $date) = @_;

  foreach (qw(minute hour day month dow)) {

    print STDERR "$_: ", join(',',$self->$_->list), "\n";

  }

  if (ref $date) {

    $date = $date->clone;

    my @mod;

    my $mon = $date->month;

    $date->truncate(to => 'month');

    while ($date->month == $mon) {

      push(@mod, $date->day) if $self->days_contain($date->day, $date->dow);

      $date->add(days => 1);

    }

    print STDERR "mod for month($mon): ", join(',', @mod), "\n";

  }

  print STDERR "day_squelch: ", $self->_cronset->day_squelch, " ",

               "dow_squelch: ", $self->_cronset->dow_squelch, "\n";

  $self;

}

###

sub DESTROY { delete $Object_Attributes{shift()} }

##########

{

package DateTime::Event::Cron::IntegratedSet;

# IntegratedSet manages the collection of field sets for

# each cron entry, including sanity checks. Individual

# field sets are accessed through their respective names,

# i.e., minute hour day month dow.

#

# Also implements some merged field logic for day/dow

# interactions.

use strict;

use Carp;

my %Range = (

  minute => [0..59],

  hour   => [0..23],

  day    => [1..31],

  month  => [1..12],

  dow    => [1..7],

);

my @Month_Max = qw( 31 29 31 30 31 30 31 31 30 31 30 31 );

my %Object_Attributes;

sub new {

  my $self = [];

  bless $self, shift;

  $self->_range(\%Range);

  $self->set_cron(@_);

  $self;

}

sub set_cron {

  # Initialize

  my $self = shift;

  my %parms = @_;

  my $cron = $parms{cron};

  my $user_mode = $parms{user_mode};

  defined $cron or croak "Cron entry fields required\n";

  $self->_attr('original', $cron);

  my @line;

  if (ref $cron) {

    @line = grep(!/^\s*$/, @$cron);

  }

  else {

    $cron =~ s/^\s+//;

    $cron =~ s/\s+$//;

    @line = split(/\s+/, $cron);

  }

  @line >= 5 or croak "At least five cron entry fields required.\n";

  my @entry = splice(@line, 0, 5);

  my($user, $command);

  unless (defined $user_mode) {

    # auto-detect

    if (@line > 1 && $line[0] =~ /^\w+$/) {

      $user_mode = 1;

    }

  }

  $user = shift @line if $user_mode;

  $command = join(' ', @line);

  $self->_attr('command', $command);

  $self->_attr('user', $user);

  my $i = 0;

  foreach my $name (qw( minute hour day month dow )) {

    $self->_attr($name, $self->make_valid_set($name, $entry[$i]));

    ++$i;

  }

  my @day_list  = $self->day->list;

  my @dow_list  = $self->dow->list;

  my $day_range = $self->range('day');

  my $dow_range = $self->range('dow');

  $self->day_squelch(scalar @day_list == scalar @$day_range &&

                     scalar @dow_list != scalar @$dow_range ? 1 : 0);

  $self->dow_squelch(scalar @dow_list == scalar @$dow_range &&

                     scalar @day_list != scalar @$day_range ? 1 : 0);

  unless ($self->day_squelch) {

    my @days = $self->day->list;

    my $pass = 0;

    MONTH: foreach my $month ($self->month->list) {

      foreach (@days) {

        ++$pass && last MONTH if $_ <= $Month_Max[$month - 1];

      }

    }

    croak "Impossible last day for provided months.\n" unless $pass;

  }

  $self;

}

# Field range queries

sub range {

  my($self, $name) = @_;

  my $val = $self->_range->{$name} or croak "Unknown field '$name'\n";

  $val;

}

# Perform sanity checks when setting up each field set.

sub make_valid_set {

  my($self, $name, $str) = @_;

  my $range = $self->range($name);

  my $set = $self->make_set($str, $range);

  my @list = $set->list;

  croak "Malformed cron field '$str'\n" unless @list;

  croak "Field value ($list[-1]) out of range ($range->[0]-$range->[-1])\n"

    if $list[-1] > $range->[-1];

  if ($name eq 'dow' && $set->contains(0)) {

    shift(@list);

    push(@list, 7) unless $set->contains(7);

    $set = $self->make_set(join(',',@list), $range);

  }

  croak "Field value ($list[0]) out of range ($range->[0]-$range->[-1])\n"

    if $list[0] < $range->[0];

  $set;

}

# No sanity checks

sub make_set { shift; DateTime::Event::Cron::OrderedSet->new(@_) }

# Flags for when day/dow are applied.

sub day_squelch { shift->_attr('day_squelch', @_ ) }

sub dow_squelch { shift->_attr('dow_squelch', @_ ) }

# Merged logic for day/dow

sub days_contain {

  my($self, $day, $dow) = @_;

  defined $day && defined $dow

    or croak "Day of month and day of week required.\n";

  my $day_c = $self->day->contains($day);

  my $dow_c = $self->dow->contains($dow);

  return $dow_c if $self->day_squelch;

  return $day_c if $self->dow_squelch;

  $day_c || $dow_c;

}

# Set Accessors

sub minute   { shift->_attr('minute' ) }

sub hour     { shift->_attr('hour'   ) }

sub day      { shift->_attr('day'    ) }

sub month    { shift->_attr('month'  ) }

sub dow      { shift->_attr('dow'    ) }

sub user     { shift->_attr('user'   ) }

sub command  { shift->_attr('command') }

sub original { shift->_attr('original') }

# Accessors/mutators

sub _range       { shift->_attr('range', @_) }

sub _attr {

  my $self = shift;

  my $name = shift;

  if (@_) {

    $Object_Attributes{$self}{$name} = shift;

  }

  $Object_Attributes{$self}{$name};

}

sub DESTROY { delete $Object_Attributes{shift()} }

}

##########

{

package DateTime::Event::Cron::OrderedSet;

# Extends Set::Crontab with some progression logic (next/prev)

use strict;

use Carp;

use base 'Set::Crontab';

my %Object_Attributes;

sub new {

  my $class = shift;

  my($string, $range) = @_;

  defined $string && ref $range

    or croak "Cron field and range ref required.\n";

  my $self = Set::Crontab->new($string, $range);

  bless $self, $class;

  my @list = $self->list;

  my(%next, %prev);

  foreach (0 .. $#list) {

    $next{$list[$_]} = $list[($_+1)%@list];

    $prev{$list[$_]} = $list[($_-1)%@list];

  }

  $self->_attr('next', \%next);

  $self->_attr('previous', \%prev);

  $self;

}

sub next {

  my($self, $entry) = @_;

  my $hash = $self->_attr('next');

  croak "Missing entry($entry) in set\n" unless exists $hash->{$entry};

  my $next = $hash->{$entry};

  wantarray ? ($next, $next <= $entry) : $next;

}

sub previous {

  my($self, $entry) = @_;

  my $hash = $self->_attr('previous');

  croak "Missing entry($entry) in set\n" unless exists $hash->{$entry};

  my $prev = $hash->{$entry};

  wantarray ? ($prev, $prev >= $entry) : $prev;

}

sub _attr {

  my $self = shift;

  my $name = shift;

  if (@_) {

    $Object_Attributes{$self}{$name} = shift;

  }

  $Object_Attributes{$self}{$name};

}

sub DESTROY { delete $Object_Attributes{shift()} }

}

###

1;

__END__

=head1 NAME

DateTime::Event::Cron - DateTime extension for generating recurrence

sets from crontab lines and files.

=head1 SYNOPSIS

  use DateTime::Event::Cron;

  # check if a date matches (defaults to current time)

  my $c = DateTime::Event::Cron->new('* 2 * * *');

  if ($c->match) {

    # do stuff

  }

  if ($c->match($date)) {

    # do something else for datetime $date

  }

  # DateTime::Set construction from crontab line

  $crontab = '*/3 15 1-10 3,4,5 */2';

  $set = DateTime::Event::Cron->from_cron($crontab);

  $iter = $set->iterator(after => DateTime->now);

  while (1) {

    my $next = $iter->next;

    my $now  = DateTime->now;

    sleep(($next->subtract_datetime_absolute($now))->seconds);

    # do stuff...

  }

  # List of DateTime::Set objects from crontab file

  @sets = DateTime::Event::Cron->from_crontab(file => '/etc/crontab');

  $now = DateTime->now;

  print "Now: ", $now->datetime, "\n";

  foreach (@sets) {

    my $next = $_->next($now);

    print $next->datetime, "\n";

  }

  # DateTime::Set parameters

  $crontab = '* * * * *';

  $now = DateTime->now;

  %set_parms = ( after => $now );

  $set = DateTime::Event::Cron->from_cron(cron => $crontab, %set_parms);

  $dt = $set->next;

  print "Now: ", $now->datetime, " and next: ", $dt->datetime, "\n";

  # Spans for DateTime::Set

  $crontab = '* * * * *';

  $now = DateTime->now;

  $now2 = $now->clone;

  $span = DateTime::Span->from_datetimes(

            start => $now->add(minutes => 1),

	    end   => $now2->add(hours => 1),

	  );

  %parms = (cron => $crontab, span => $span);

  $set = DateTime::Event::Cron->from_cron(%parms);

  # ...do things with the DateTime::Set

  # Every RTFCT relative to 12am Jan 1st this year

  $crontab = '7-10 6,12-15 10-28/2 */3 3,4,5';

  $date = DateTime->now->truncate(to => 'year');

  $set = DateTime::Event::Cron->from_cron(cron => $crontab, after => $date);

  # Rather than generating DateTime::Set objects, next/prev

  # calculations can be made directly:

  # Every day at 10am, 2pm, and 6pm. Reference date

  # defaults to DateTime->now.

  $crontab = '10,14,18 * * * *';

  $dtc = DateTime::Event::Cron->new_from_cron(cron => $crontab);

  $next_datetime = $dtc->next;

  $last_datetime = $dtc->previous;

  ...

  # List of DateTime::Event::Cron objects from

  # crontab file

  @dtc = DateTime::Event::Cron->new_from_crontab(file => '/etc/crontab');

  # Full cron lines with user, such as from /etc/crontab

  # or files in /etc/cron.d, are supported and auto-detected:

  $crontab = '* * * * * gump /bin/date';

  $dtc = DateTime::Event::Cron->new(cron => $crontab);

  # Auto-detection of users is disabled if you explicitly

  # enable/disable via the user_mode parameter:

  $dtc = DateTime::Event::Cron->new(cron => $crontab, user_mode => 1);

  my $user = $dtc->user;

  my $command = $dtc->command;

  # Unparsed original cron entry

  my $original = $dtc->original;

=head1 DESCRIPTION

DateTime::Event::Cron generated DateTime events or DateTime::Set objects

based on crontab-style entries.

=head1 METHODS

The cron fields are typical crontab-style entries. For more information,

see L<crontab(5)> and extensions described in L<Set::Crontab>. The

fields can be passed as a single string or as a reference to an array

containing each field. Only the first five fields are retained.

=head2 DateTime::Set Factories

See L<DateTime::Set> for methods provided by Set objects, such as

C<next()> and C<previous()>.

=over 4

=item from_cron($cronline)

=item from_cron(cron => $cronline, %parms, %set_parms)

Generates a DateTime::Set recurrence for the cron line provided. See

new() for details on %parms. Optionally takes parameters for

DateTime::Set.

=item from_crontab(file => $crontab_fh, %parms, %set_parms)

Returns a list of DateTime::Set recurrences based on lines from a

crontab file. C<$crontab_fh> can be either a filename or filehandle

reference. See new() for details on %parm. Optionally takes parameters

for DateTime::Set which will be passed along to each set for each line.

=item as_set(%set_parms)

Generates a DateTime::Set recurrence from an existing

DateTime::Event::Cron object.

=back

=head2 Constructors

=over 4

=item new_from_cron(cron => $cronstring, %parms)

Returns a DateTime::Event::Cron object based on the cron specification.

Optional parameters include the boolean 'user_mode' which indicates that

the crontab entry includes a username column before the command.

=item new_from_crontab(file => $fh, %parms)

Returns a list of DateTime::Event::Cron objects based on the lines of a

crontab file. C<$fh> can be either a filename or a filehandle reference.

Optional parameters include the boolean 'user_mode' as mentioned above.

=back

=head2 Other methods

=over 4

=item next()

=item next($date)

Returns the next valid datetime according to the cron specification.

C<$date> defaults to DateTime->now unless provided.

=item previous()

=item previous($date)

Returns the previous valid datetime according to the cron specification.

C<$date> defaults to DateTime->now unless provided.

=item increment($date)

=item decrement($date)

Same as C<next()> and C<previous()> except that the provided datetime is

modified to the new datetime.

=item match($date)

Returns whether or not the given datetime (defaults to current time)

matches the current cron specification. Dates are truncated to minute

resolution.

=item valid($date)

A more strict version of match(). Returns whether the given datetime is

valid under the current cron specification. Cron dates are only accurate

to the minute -- datetimes with seconds greater than 0 are invalid by

default. (note: never fear, all methods accepting dates will accept

invalid dates -- they will simply be rounded to the next nearest valid

date in all cases except this particular method)

=item command()

Returns the command string, if any, from the original crontab entry.

Currently no expansion is performed such as resolving environment

variables, etc.

=item user()

Returns the username under which this cron command was to be executed,

assuming such a field was present in the original cron entry.

=item original()

Returns the original, unparsed cron string including any user or

command fields.

=back

=head1 AUTHOR

Matthew P. Sisk E<lt>sisk@mojotoad.comE<gt>

=head1 COPYRIGHT

Copyright (c) 2003 Matthew P. Sisk. All rights reserved. All wrongs

revenged. This program is free software; you can distribute it and/or

modify it under the same terms as Perl itself.

=head1 SEE ALSO

DateTime(3), DateTime::Set(3), DateTime::Event::Recurrence(3),

DateTime::Event::ICal(3), DateTime::Span(3), Set::Crontab(3), crontab(5)

=cut

package DateTime::Set;

use strict;

use Carp;

use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );

use DateTime 0.12;  # this is for version checking only

use DateTime::Duration;

use DateTime::Span;

use Set::Infinite 0.59;

use Set::Infinite::_recurrence;

use vars qw( $VERSION );

use constant INFINITY     =>       100 ** 100 ** 100 ;

use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);

BEGIN {

    $VERSION = '0.28';

}

sub _fix_datetime {

    # internal function -

    # (not a class method)

    #

    # checks that the parameter is an object, and

    # also protects the object against mutation

    return $_[0]

        unless defined $_[0];      # error

    return $_[0]->clone

        if ref( $_[0] );           # "immutable" datetime

    return DateTime::Infinite::Future->new 

        if $_[0] == INFINITY;      # Inf

    return DateTime::Infinite::Past->new

        if $_[0] == NEG_INFINITY;  # -Inf

    return $_[0];                  # error

}

sub _fix_return_datetime {

    my ( $dt, $dt_arg ) = @_;

    # internal function -

    # (not a class method)

    #

    # checks that the returned datetime has the same

    # time zone as the parameter

    # TODO: set locale

    return unless $dt;

    return unless $dt_arg;

    if ( $dt_arg->can('time_zone_long_name') &&

         !( $dt_arg->time_zone_long_name eq 'floating' ) )

    {

        $dt->set_time_zone( $dt_arg->time_zone );

    }

    return $dt;

}

sub iterate {

    # deprecated method - use map() or grep() instead

    my ( $self, $callback ) = @_;

    my $class = ref( $self );

    my $return = $class->empty_set;

    $return->{set} = $self->{set}->iterate( 

        sub {

            my $min = $_[0]->min;

            $callback->( $min->clone ) if ref($min);

        }

    );

    $return;

}

sub map {

    my ( $self, $callback ) = @_;

    my $class = ref( $self );

    die "The callback parameter to map() must be a subroutine reference"

        unless ref( $callback ) eq 'CODE';

    my $return = $class->empty_set;

    $return->{set} = $self->{set}->iterate( 

        sub {

            local $_ = $_[0]->min;

            next unless ref( $_ );

            $_ = $_->clone;

            my @list = $callback->();

            my $set = Set::Infinite::_recurrence->new();

            $set = $set->union( $_ ) for @list;

            return $set;

        }

    );

    $return;

}

sub grep {

    my ( $self, $callback ) = @_;

    my $class = ref( $self );

    die "The callback parameter to grep() must be a subroutine reference"

        unless ref( $callback ) eq 'CODE';

    my $return = $class->empty_set;

    $return->{set} = $self->{set}->iterate( 

        sub {

            local $_ = $_[0]->min;

            next unless ref( $_ );

            $_ = $_->clone;

            my $result = $callback->();

            return $_ if $result;

            return;

        }

    );

    $return;

}

sub add { return shift->add_duration( DateTime::Duration->new(@_) ) }

sub subtract { return shift->subtract_duration( DateTime::Duration->new(@_) ) }

sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }

sub add_duration {

    my ( $self, $dur ) = @_;

    $dur = $dur->clone;  # $dur must be "immutable"

    $self->{set} = $self->{set}->iterate(

        sub {

            my $min = $_[0]->min;

            $min->clone->add_duration( $dur ) if ref($min);

        },

        backtrack_callback => sub { 

            my ( $min, $max ) = ( $_[0]->min, $_[0]->max );

            if ( ref($min) )

            {

                $min = $min->clone;

                $min->subtract_duration( $dur );

            }

            if ( ref($max) )

            {

                $max = $max->clone;

                $max->subtract_duration( $dur );

            }

            return Set::Infinite::_recurrence->new( $min, $max );

        },

    );

    $self;

}

sub set_time_zone {

    my ( $self, $tz ) = @_;

    $self->{set} = $self->{set}->iterate(

        sub {

            my $min = $_[0]->min;

            $min->clone->set_time_zone( $tz ) if ref($min);

        },

        backtrack_callback => sub {

            my ( $min, $max ) = ( $_[0]->min, $_[0]->max );

            if ( ref($min) )

            {

                $min = $min->clone;

                $min->set_time_zone( $tz );

            }

            if ( ref($max) )

            {

                $max = $max->clone;

                $max->set_time_zone( $tz );

            }

            return Set::Infinite::_recurrence->new( $min, $max );

        },

    );

    $self;

}

sub set {

    my $self = shift;

    my %args = validate( @_,

                         { locale => { type => SCALAR | OBJECT,

                                       default => undef },

                         }

                       );

    $self->{set} = $self->{set}->iterate( 

        sub {

            my $min = $_[0]->min;

            $min->clone->set( %args ) if ref($min);

        },

    );

    $self;

}

sub from_recurrence {

    my $class = shift;

    my %args = @_;

    my %param;

    # Parameter renaming, such that we can use either

    #   recurrence => xxx   or   next => xxx, previous => xxx

    $param{next} = delete $args{recurrence} || delete $args{next};

    $param{previous} = delete $args{previous};

    $param{span} = delete $args{span};

    # they might be specifying a span using begin / end

    $param{span} = DateTime::Span->new( %args ) if keys %args;

    my $self = {};

    die "Not enough arguments in from_recurrence()"

        unless $param{next} || $param{previous}; 

    if ( ! $param{previous} ) 

    {

        my $data = {};

        $param{previous} =

                sub {

                    _callback_previous ( _fix_datetime( $_[0] ), $param{next}, $data );

                }

    }

    else

    {

        my $previous = $param{previous};

        $param{previous} =

                sub {

                    $previous->( _fix_datetime( $_[0] ) );

                }

    }

    if ( ! $param{next} ) 

    {

        my $data = {};

        $param{next} =

                sub {

                    _callback_next ( _fix_datetime( $_[0] ), $param{previous}, $data );

                }

    }

    else

    {

        my $next = $param{next};

        $param{next} =

                sub {

                    $next->( _fix_datetime( $_[0] ) );

                }

    }

    my ( $min, $max );

    $max = $param{previous}->( DateTime::Infinite::Future->new );

    $min = $param{next}->( DateTime::Infinite::Past->new );

    $max = INFINITY if $max->is_infinite;

    $min = NEG_INFINITY if $min->is_infinite;

    my $base_set = Set::Infinite::_recurrence->new( $min, $max );

    $base_set = $base_set->intersection( $param{span}->{set} )

         if $param{span};

    # warn "base set is $base_set\n";

    my $data = {};

    $self->{set} = 

            $base_set->_recurrence(

                $param{next}, 

                $param{previous},

                $data,

        );

    bless $self, $class;

    return $self;

}

sub from_datetimes {

    my $class = shift;

    my %args = validate( @_,

                         { dates => 

                           { type => ARRAYREF,

                           },

                         }

                       );

    my $self = {};

    $self->{set} = Set::Infinite::_recurrence->new;

    # possible optimization: sort datetimes and use "push"

    for( @{ $args{dates} } ) 

    {

        # DateTime::Infinite objects are not welcome here,

        # but this is not enforced (it does't hurt)

        carp "The 'dates' argument to from_datetimes() must only contain ".

             "datetime objects"

            unless UNIVERSAL::can( $_, 'utc_rd_values' );

        $self->{set} = $self->{set}->union( $_->clone );

    }

    bless $self, $class;

    return $self;

}

sub empty_set {

    my $class = shift;

    return bless { set => Set::Infinite::_recurrence->new }, $class;

}

sub clone { 

    my $self = bless { %{ $_[0] } }, ref $_[0];

    $self->{set} = $_[0]->{set}->copy;

    return $self;

}

# default callback that returns the 

# "previous" value in a callback recurrence.

#

# This is used to simulate a 'previous' callback,

# when then 'previous' argument in 'from_recurrence' is missing.

#

sub _callback_previous {

    my ($value, $callback_next, $callback_info) = @_; 

    my $previous = $value->clone;

    return $value if $value->is_infinite;

    my $freq = $callback_info->{freq};

    unless (defined $freq) 

    { 

        # This is called just once, to setup the recurrence frequency

        my $previous = $callback_next->( $value );

        my $next =     $callback_next->( $previous );

        $freq = 2 * ( $previous - $next );

        # save it for future use with this same recurrence

        $callback_info->{freq} = $freq;

    }

    $previous->add_duration( $freq );  

    $previous = $callback_next->( $previous );

    if ($previous >= $value) 

    {

        # This error happens if the event frequency oscilates widely

        # (more than 100% of difference from one interval to next)

        my @freq = $freq->deltas;

        print STDERR "_callback_previous: Delta components are: @freq\n";

        warn "_callback_previous: iterator can't find a previous value, got ".

            $previous->ymd." after ".$value->ymd;

    }

    my $previous1;

    while (1) 

    {

        $previous1 = $previous->clone;

        $previous = $callback_next->( $previous );

        return $previous1 if $previous >= $value;

    }

}

# default callback that returns the 

# "next" value in a callback recurrence.

#

# This is used to simulate a 'next' callback,

# when then 'next' argument in 'from_recurrence' is missing.

#

sub _callback_next {

    my ($value, $callback_previous, $callback_info) = @_; 

    my $next = $value->clone;

    return $value if $value->is_infinite;

    my $freq = $callback_info->{freq};

    unless (defined $freq) 

    { 

        # This is called just once, to setup the recurrence frequency

        my $next =     $callback_previous->( $value );

        my $previous = $callback_previous->( $next );

        $freq = 2 * ( $next - $previous );

        # save it for future use with this same recurrence

        $callback_info->{freq} = $freq;

    }

    $next->add_duration( $freq );  

    $next = $callback_previous->( $next );

    if ($next <= $value) 

    {

        # This error happens if the event frequency oscilates widely

        # (more than 100% of difference from one interval to next)

        my @freq = $freq->deltas;

        print STDERR "_callback_next: Delta components are: @freq\n";

        warn "_callback_next: iterator can't find a previous value, got ".

            $next->ymd." before ".$value->ymd;

    }

    my $next1;

    while (1) 

    {

        $next1 = $next->clone;

        $next =  $callback_previous->( $next );

        return $next1 if $next >= $value;

    }

}

sub iterator {

    my $self = shift;

    my %args = @_;

    my $span;

    $span = delete $args{span};

    $span = DateTime::Span->new( %args ) if %args;

    return $self->intersection( $span ) if $span;

    return $self->clone;

}

# next() gets the next element from an iterator()

# next( $dt ) returns the next element after a datetime.

sub next {

    my $self = shift;

    return undef unless ref( $self->{set} );

    if ( @_ ) 

    {

        if ( $self->{set}->_is_recurrence )

        {

            return _fix_return_datetime(

                       $self->{set}->{param}[0]->( $_[0] ), $_[0] );

        }

        else 

        {

            my $span = DateTime::Span->from_datetimes( after => $_[0] );

            return _fix_return_datetime(

                        $self->intersection( $span )->next, $_[0] );

        }

    }

    my ($head, $tail) = $self->{set}->first;

    $self->{set} = $tail;

    return $head->min if defined $head;

    return $head;

}

# previous() gets the last element from an iterator()

# previous( $dt ) returns the previous element before a datetime.

sub previous {

    my $self = shift;

    return undef unless ref( $self->{set} );

    if ( @_ ) 

    {

        if ( $self->{set}->_is_recurrence ) 

        {

            return _fix_return_datetime(

                      $self->{set}->{param}[1]->( $_[0] ), $_[0] );

        }

        else 

        {

            my $span = DateTime::Span->from_datetimes( before => $_[0] );

            return _fix_return_datetime(

                      $self->intersection( $span )->previous, $_[0] );

        }

    }

    my ($head, $tail) = $self->{set}->last;

    $self->{set} = $tail;

    return $head->max if defined $head;

    return $head;

}

# "current" means less-or-equal to a datetime

sub current {

    my $self = shift;

    return undef unless ref( $self->{set} );

    if ( $self->{set}->_is_recurrence )

    {

        my $tmp = $self->next( $_[0] );

        return $self->previous( $tmp );

    }

    return $_[0] if $self->contains( $_[0] );

    $self->previous( $_[0] );

}

sub closest {

    my $self = shift;

    # return $_[0] if $self->contains( $_[0] );

    my $dt1 = $self->current( $_[0] );

    my $dt2 = $self->next( $_[0] );

    return $dt2 unless defined $dt1;

    return $dt1 unless defined $dt2;

    my $delta = $_[0] - $dt1;

    return $dt1 if ( $dt2 - $delta ) >= $_[0];

    return $dt2;

}

sub as_list {

    my $self = shift;

    return undef unless ref( $self->{set} );

    my %args = @_;

    my $span;

    $span = delete $args{span};

    $span = DateTime::Span->new( %args ) if %args;

    my $set = $self->clone;

    $set = $set->intersection( $span ) if $span;

    return if $set->{set}->is_null;  # nothing = empty

    # Note: removing this line means we may end up in an infinite loop!

    ## return undef if $set->{set}->is_too_complex;  # undef = no begin/end

    return undef

        if $set->max->is_infinite ||

           $set->min->is_infinite;

    my @result;

    my $next = $self->min;

    if ( $span ) {

        my $next1 = $span->min;

        $next = $next1 if $next1 && $next1 > $next;

        $next = $self->current( $next );

    }

    my $last = $self->max;

    if ( $span ) {

        my $last1 = $span->max;

        $last = $last1 if $last1 && $last1 < $last;

    }

    do {

        push @result, $next if !$span || $span->contains($next);

        $next = $self->next( $next );

    }

    while $next && $next <= $last;

    return @result;

}

sub intersection {

    my ($set1, $set2) = ( shift, shift );

    my $class = ref($set1);

    my $tmp = $class->empty_set();

    $set2 = $set2->as_set

        if $set2->can( 'as_set' );

    $set2 = $class->from_datetimes( dates => [ $set2, @_ ] ) 

        unless $set2->can( 'union' );

    $tmp->{set} = $set1->{set}->intersection( $set2->{set} );

    return $tmp;

}

sub intersects {

    my ($set1, $set2) = ( shift, shift );

    my $class = ref($set1);

    $set2 = $set2->as_set

        if $set2->can( 'as_set' );

    unless ( $set2->can( 'union' ) )

    {

        if ( $set1->{set}->_is_recurrence )

        {

            for ( $set2, @_ )

            {

                return 1 if $set1->current( $_ ) == $_;

            }

            return 0;

        }

        $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )

    }

    return $set1->{set}->intersects( $set2->{set} );

}

sub contains {

    my ($set1, $set2) = ( shift, shift );

    my $class = ref($set1);

    $set2 = $set2->as_set

        if $set2->can( 'as_set' );

    unless ( $set2->can( 'union' ) )

    {

        if ( $set1->{set}->_is_recurrence )

        {

            for ( $set2, @_ ) 

            {

                return 0 unless $set1->current( $_ ) == $_;

            }

            return 1;

        }

        $set2 = $class->from_datetimes( dates => [ $set2, @_ ] ) 

    }

    return $set1->{set}->contains( $set2->{set} );

}

sub union {

    my ($set1, $set2) = ( shift, shift );

    my $class = ref($set1);

    my $tmp = $class->empty_set();

    $set2 = $set2->as_set

        if $set2->can( 'as_set' );

    $set2 = $class->from_datetimes( dates => [ $set2, @_ ] ) 

        unless $set2->can( 'union' );

    $tmp->{set} = $set1->{set}->union( $set2->{set} );

    bless $tmp, 'DateTime::SpanSet' 

        if $set2->isa('DateTime::Span') or $set2->isa('DateTime::SpanSet');

    return $tmp;

}

sub complement {