--- /dev/null
+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
--- /dev/null
+
+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 {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ if (defined $set2)
+ {
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ # TODO: "compose complement";
+ $tmp->{set} = $set1->{set}->complement( $set2->{set} );
+ }
+ else
+ {
+ $tmp->{set} = $set1->{set}->complement;
+ bless $tmp, 'DateTime::SpanSet';
+ }
+ return $tmp;
+}
+
+sub min {
+ return _fix_datetime( $_[0]->{set}->min );
+}
+
+sub max {
+ return _fix_datetime( $_[0]->{set}->max );
+}
+
+# returns a DateTime::Span
+sub span {
+ my $set = $_[0]->{set}->span;
+ my $self = bless { set => $set }, 'DateTime::Span';
+ return $self;
+}
+
+sub count {
+ 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 $set->{set}->count
+ unless $set->{set}->is_too_complex;
+
+ return undef
+ if $set->max->is_infinite ||
+ $set->min->is_infinite;
+
+ my $count = 0;
+ my $iter = $set->iterator;
+ $count++ while $iter->next;
+ return $count;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DateTime::Set - Datetime sets and set math
+
+=head1 SYNOPSIS
+
+ use DateTime;
+ use DateTime::Set;
+
+ $date1 = DateTime->new( year => 2002, month => 3, day => 11 );
+ $set1 = DateTime::Set->from_datetimes( dates => [ $date1 ] );
+ # set1 = 2002-03-11
+
+ $date2 = DateTime->new( year => 2003, month => 4, day => 12 );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $date1, $date2 ] );
+ # set2 = 2002-03-11, and 2003-04-12
+
+ $date3 = DateTime->new( year => 2003, month => 4, day => 1 );
+ print $set2->next( $date3 )->ymd; # 2003-04-12
+ print $set2->previous( $date3 )->ymd; # 2002-03-11
+ print $set2->current( $date3 )->ymd; # 2002-03-11
+ print $set2->closest( $date3 )->ymd; # 2003-04-12
+
+ # a 'monthly' recurrence:
+ $set = DateTime::Set->from_recurrence(
+ recurrence => sub {
+ return $_[0] if $_[0]->is_infinite;
+ return $_[0]->truncate( to => 'month' )->add( months => 1 )
+ },
+ span => $date_span1, # optional span
+ );
+
+ $set = $set1->union( $set2 ); # like "OR", "insert", "both"
+ $set = $set1->complement( $set2 ); # like "delete", "remove"
+ $set = $set1->intersection( $set2 ); # like "AND", "while"
+ $set = $set1->complement; # like "NOT", "negate", "invert"
+
+ if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $set1->contains( $set2 ) ) { ... # like "is-fully-inside"
+
+ # data extraction
+ $date = $set1->min; # first date of the set
+ $date = $set1->max; # last date of the set
+
+ $iter = $set1->iterator;
+ while ( $dt = $iter->next ) {
+ print $dt->ymd;
+ };
+
+=head1 DESCRIPTION
+
+DateTime::Set is a module for datetime sets. It can be used to handle
+two different types of sets.
+
+The first is a fixed set of predefined datetime objects. For example,
+if we wanted to create a set of datetimes containing the birthdays of
+people in our family for the current year.
+
+The second type of set that it can handle is one based on a
+recurrence, such as "every Wednesday", or "noon on the 15th day of
+every month". This type of set can have fixed starting and ending
+datetimes, but neither is required. So our "every Wednesday set"
+could be "every Wednesday from the beginning of time until the end of
+time", or "every Wednesday after 2003-03-05 until the end of time", or
+"every Wednesday between 2003-03-05 and 2004-01-07".
+
+This module also supports set math operations, so you do things like
+create a new set from the union or difference of two sets, check
+whether a datetime is a member of a given set, etc.
+
+This is different from a C<DateTime::Span>, which handles a continuous
+range as opposed to individual datetime points. There is also a module
+C<DateTime::SpanSet> to handle sets of spans.
+
+=head1 METHODS
+
+=over 4
+
+=item * from_datetimes
+
+Creates a new set from a list of datetimes.
+
+ $dates = DateTime::Set->from_datetimes( dates => [ $dt1, $dt2, $dt3 ] );
+
+The datetimes can be objects from class C<DateTime>, or from a
+C<DateTime::Calendar::*> class.
+
+C<DateTime::Infinite::*> objects are not valid set members.
+
+=item * from_recurrence
+
+Creates a new set specified via a "recurrence" callback.
+
+ $months = DateTime::Set->from_recurrence(
+ span => $dt_span_this_year, # optional span
+ recurrence => sub {
+ return $_[0]->truncate( to => 'month' )->add( months => 1 )
+ },
+ );
+
+The C<span> parameter is optional. It must be a C<DateTime::Span> object.
+
+The span can also be specified using C<begin> / C<after> and C<before>
+/ C<end> parameters, as in the C<DateTime::Span> constructor. In this
+case, if there is a C<span> parameter it will be ignored.
+
+ $months = DateTime::Set->from_recurrence(
+ after => $dt_now,
+ recurrence => sub {
+ return $_[0]->truncate( to => 'month' )->add( months => 1 );
+ },
+ );
+
+The recurrence function will be passed a single parameter, a datetime
+object. The parameter can be an object from class C<DateTime>, or from
+one of the C<DateTime::Calendar::*> classes. The parameter can also
+be a C<DateTime::Infinite::Future> or a C<DateTime::Infinite::Past>
+object.
+
+The recurrence must return the I<next> event after that object. There
+is no guarantee as to what the returned object will be set to, only
+that it will be greater than the object passed to the recurrence.
+
+If there are no more datetimes after the given parameter, then the
+recurrence function should return C<DateTime::Infinite::Future>.
+
+It is ok to modify the parameter C<$_[0]> inside the recurrence
+function. There are no side-effects.
+
+For example, if you wanted a recurrence that generated datetimes in
+increments of 30 seconds, it would look like this:
+
+ sub every_30_seconds {
+ my $dt = shift;
+ if ( $dt->second < 30 ) {
+ return $dt->truncate( to => 'minute' )->add( seconds => 30 );
+ } else {
+ return $dt->truncate( to => 'minute' )->add( minutes => 1 );
+ }
+ }
+
+Note that this recurrence takes leap seconds into account. Consider
+using C<truncate()> in this manner to avoid complicated arithmetic
+problems!
+
+It is also possible to create a recurrence by specifying either or both
+of 'next' and 'previous' callbacks.
+
+The callbacks can return C<DateTime::Infinite::Future> and
+C<DateTime::Infinite::Past> objects, in order to define I<bounded
+recurrences>. In this case, both 'next' and 'previous' callbacks must
+be defined:
+
+ # "monthly from $dt until forever"
+
+ my $months = DateTime::Set->from_recurrence(
+ next => sub {
+ return $dt if $_[0] < $dt;
+ $_[0]->truncate( to => 'month' );
+ $_[0]->add( months => 1 );
+ return $_[0];
+ },
+ previous => sub {
+ my $param = $_[0]->clone;
+ $_[0]->truncate( to => 'month' );
+ $_[0]->subtract( months => 1 ) if $_[0] == $param;
+ return $_[0] if $_[0] >= $dt;
+ return DateTime::Infinite::Past->new;
+ },
+ );
+
+Bounded recurrences are easier to write using C<span> parameters. See above.
+
+See also C<DateTime::Event::Recurrence> and the other
+C<DateTime::Event::*> factory modules for generating specialized
+recurrences, such as sunrise and sunset times, and holidays.
+
+=item * empty_set
+
+Creates a new empty set.
+
+ $set = DateTime::Set->empty_set;
+ print "empty set" unless defined $set->max;
+
+=item * clone
+
+This object method returns a replica of the given object.
+
+C<clone> is useful if you want to apply a transformation to a set,
+but you want to keep the previous value:
+
+ $set2 = $set1->clone;
+ $set2->add_duration( year => 1 ); # $set1 is unaltered
+
+=item * add_duration( $duration )
+
+This method adds the specified duration to every element of the set.
+
+ $dt_dur = new DateTime::Duration( year => 1 );
+ $set->add_duration( $dt_dur );
+
+The original set is modified. If you want to keep the old values use:
+
+ $new_set = $set->clone->add_duration( $dt_dur );
+
+=item * add
+
+This method is syntactic sugar around the C<add_duration()> method.
+
+ $meetings_2004 = $meetings_2003->clone->add( years => 1 );
+
+=item * subtract_duration( $duration_object )
+
+When given a C<DateTime::Duration> object, this method simply calls
+C<invert()> on that object and passes that new duration to the
+C<add_duration> method.
+
+=item * subtract( DateTime::Duration->new parameters )
+
+Like C<add()>, this is syntactic sugar for the C<subtract_duration()>
+method.
+
+=item * set_time_zone( $tz )
+
+This method will attempt to apply the C<set_time_zone> method to every
+datetime in the set.
+
+=item * set( locale => .. )
+
+This method can be used to change the C<locale> of a datetime set.
+
+=item * min
+
+=item * max
+
+The first and last C<DateTime> in the set. These methods may return
+C<undef> if the set is empty. It is also possible that these methods
+may return a C<DateTime::Infinite::Past> or
+C<DateTime::Infinite::Future> object.
+
+These methods return just a I<copy> of the actual boundary value.
+If you modify the result, the set will not be modified.
+
+=item * span
+
+Returns the total span of the set, as a C<DateTime::Span> object.
+
+=item * iterator / next / previous
+
+These methods can be used to iterate over the datetimes in a set.
+
+ $iter = $set1->iterator;
+ while ( $dt = $iter->next ) {
+ print $dt->ymd;
+ }
+
+ # iterate backwards
+ $iter = $set1->iterator;
+ while ( $dt = $iter->previous ) {
+ print $dt->ymd;
+ }
+
+The boundaries of the iterator can be limited by passing it a C<span>
+parameter. This should be a C<DateTime::Span> object which delimits
+the iterator's boundaries. Optionally, instead of passing an object,
+you can pass any parameters that would work for one of the
+C<DateTime::Span> class's constructors, and an object will be created
+for you.
+
+Obviously, if the span you specify is not restricted both at the start
+and end, then your iterator may iterate forever, depending on the
+nature of your set. User beware!
+
+The C<next()> or C<previous()> method will return C<undef> when there
+are no more datetimes in the iterator.
+
+=item * as_list
+
+Returns the set elements as a list of C<DateTime> objects. Just as
+with the C<iterator()> method, the C<as_list()> method can be limited
+by a span.
+
+ my @dt = $set->as_list( span => $span );
+
+Applying C<as_list()> to a large recurrence set is a very expensive
+operation, both in CPU time and in the memory used. If you I<really>
+need to extract elements from a large set, you can limit the set with
+a shorter span:
+
+ my @short_list = $large_set->as_list( span => $short_span );
+
+For I<infinite> sets, C<as_list()> will return C<undef>. Please note
+that this is explicitly not an empty list, since an empty list is a
+valid return value for empty sets!
+
+=item * count
+
+Returns a count of C<DateTime> objects in the set. Just as with the
+C<iterator()> method, the C<count()> method can be limited by a span.
+
+ defined( my $n = $set->count) or die "can't count";
+
+ my $n = $set->count( span => $span );
+ die "can't count" unless defined $n;
+
+Applying C<count()> to a large recurrence set is a very expensive
+operation, both in CPU time and in the memory used. If you I<really>
+need to count elements from a large set, you can limit the set with a
+shorter span:
+
+ my $count = $large_set->count( span => $short_span );
+
+For I<infinite> sets, C<count()> will return C<undef>. Please note
+that this is explicitly not a scalar zero, since a zero count is a
+valid return value for empty sets!
+
+=item * union
+
+=item * intersection
+
+=item * complement
+
+These set operation methods can accept a C<DateTime> list, a
+C<DateTime::Set>, a C<DateTime::Span>, or a C<DateTime::SpanSet>
+object as an argument.
+
+ $set = $set1->union( $set2 ); # like "OR", "insert", "both"
+ $set = $set1->complement( $set2 ); # like "delete", "remove"
+ $set = $set1->intersection( $set2 ); # like "AND", "while"
+ $set = $set1->complement; # like "NOT", "negate", "invert"
+
+The C<union> of a C<DateTime::Set> with a C<DateTime::Span> or a
+C<DateTime::SpanSet> object returns a C<DateTime::SpanSet> object.
+
+If C<complement> is called without any arguments, then the result is a
+C<DateTime::SpanSet> object representing the spans between each of the
+set's elements. If complement is given an argument, then the return
+value is a C<DateTime::Set> object representing the I<set difference>
+between the sets.
+
+All other operations will always return a C<DateTime::Set>.
+
+=item * intersects
+
+=item * contains
+
+These set operations result in a boolean value.
+
+ if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $set1->contains( $dt ) ) { ... # like "is-fully-inside"
+
+These methods can accept a C<DateTime> list, a C<DateTime::Set>, a
+C<DateTime::Span>, or a C<DateTime::SpanSet> object as an argument.
+
+=item * previous
+
+=item * next
+
+=item * current
+
+=item * closest
+
+ my $dt = $set->next( $dt );
+ my $dt = $set->previous( $dt );
+ my $dt = $set->current( $dt );
+ my $dt = $set->closest( $dt );
+
+These methods are used to find a set member relative to a given
+datetime.
+
+The C<current()> method returns C<$dt> if $dt is an event, otherwise
+it returns the previous event.
+
+The C<closest()> method returns C<$dt> if $dt is an event, otherwise
+it returns the closest event (previous or next).
+
+All of these methods may return C<undef> if there is no matching
+datetime in the set.
+
+These methods will try to set the returned value to the same time zone
+as the argument, unless the argument has a 'floating' time zone.
+
+=item * map ( sub { ... } )
+
+ # example: remove the hour:minute:second information
+ $set = $set2->map(
+ sub {
+ return $_->truncate( to => day );
+ }
+ );
+
+ # example: postpone or antecipate events which
+ # match datetimes within another set
+ $set = $set2->map(
+ sub {
+ return $_->add( days => 1 ) while $holidays->contains( $_ );
+ }
+ );
+
+This method is the "set" version of Perl "map".
+
+It evaluates a subroutine for each element of the set (locally setting
+"$_" to each datetime) and returns the set composed of the results of
+each such evaluation.
+
+Like Perl "map", each element of the set may produce zero, one, or
+more elements in the returned value.
+
+Unlike Perl "map", changing "$_" does not change the original
+set. This means that calling map in void context has no effect.
+
+The callback subroutine may be called later in the program, due to
+lazy evaluation. So don't count on subroutine side-effects. For
+example, a C<print> inside the subroutine may happen later than you
+expect.
+
+The callback return value is expected to be within the span of the
+C<previous> and the C<next> element in the original set. This is a
+limitation of the backtracking algorithm used in the C<Set::Infinite>
+library.
+
+For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
+result for the value C<2010> is expected to be within the span C<[
+2001 .. 2015 ]>.
+
+=item * grep ( sub { ... } )
+
+ # example: filter out any sundays
+ $set = $set2->grep(
+ sub {
+ return ( $_->day_of_week != 7 );
+ }
+ );
+
+This method is the "set" version of Perl "grep".
+
+It evaluates a subroutine for each element of the set (locally setting
+"$_" to each datetime) and returns the set consisting of those
+elements for which the expression evaluated to true.
+
+Unlike Perl "grep", changing "$_" does not change the original
+set. This means that calling grep in void context has no effect.
+
+Changing "$_" does change the resulting set.
+
+The callback subroutine may be called later in the program, due to
+lazy evaluation. So don't count on subroutine side-effects. For
+example, a C<print> inside the subroutine may happen later than you
+expect.
+
+=item * iterate ( sub { ... } )
+
+I<deprecated method - please use "map" or "grep" instead.>
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+The API was developed together with Dave Rolsky and the DateTime
+Community.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003-2006 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can distribute it and/or modify it
+under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file included
+with this module.
+
+=head1 SEE ALSO
+
+Set::Infinite
+
+For details on the Perl DateTime Suite project please see
+L<http://datetime.perl.org>.
+
+=cut
+
--- /dev/null
+# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package DateTime::Span;
+
+use strict;
+
+use DateTime::Set;
+use DateTime::SpanSet;
+
+use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
+use vars qw( $VERSION );
+
+use constant INFINITY => DateTime::INFINITY;
+use constant NEG_INFINITY => DateTime::NEG_INFINITY;
+$VERSION = $DateTime::Set::VERSION;
+
+sub set_time_zone {
+ my ( $self, $tz ) = @_;
+
+ $self->{set} = $self->{set}->iterate(
+ sub {
+ my %tmp = %{ $_[0]->{list}[0] };
+ $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
+ $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
+ \%tmp;
+ }
+ );
+ return $self;
+}
+
+# note: the constructor must clone its DateTime parameters, such that
+# the set elements become immutable
+sub from_datetimes {
+ my $class = shift;
+ my %args = validate( @_,
+ { start =>
+ { type => OBJECT,
+ optional => 1,
+ },
+ end =>
+ { type => OBJECT,
+ optional => 1,
+ },
+ after =>
+ { type => OBJECT,
+ optional => 1,
+ },
+ before =>
+ { type => OBJECT,
+ optional => 1,
+ },
+ }
+ );
+ my $self = {};
+ my $set;
+
+ die "No arguments given to DateTime::Span->from_datetimes\n"
+ unless keys %args;
+
+ if ( exists $args{start} && exists $args{after} ) {
+ die "Cannot give both start and after arguments to DateTime::Span->from_datetimes\n";
+ }
+ if ( exists $args{end} && exists $args{before} ) {
+ die "Cannot give both end and before arguments to DateTime::Span->from_datetimes\n";
+ }
+
+ my ( $start, $open_start, $end, $open_end );
+ ( $start, $open_start ) = ( NEG_INFINITY, 0 );
+ ( $start, $open_start ) = ( $args{start}, 0 ) if exists $args{start};
+ ( $start, $open_start ) = ( $args{after}, 1 ) if exists $args{after};
+ ( $end, $open_end ) = ( INFINITY, 0 );
+ ( $end, $open_end ) = ( $args{end}, 0 ) if exists $args{end};
+ ( $end, $open_end ) = ( $args{before}, 1 ) if exists $args{before};
+
+ if ( $start > $end ) {
+ die "Span cannot start after the end in DateTime::Span->from_datetimes\n";
+ }
+ $set = Set::Infinite::_recurrence->new( $start, $end );
+ if ( $start != $end ) {
+ # remove start, such that we have ">" instead of ">="
+ $set = $set->complement( $start ) if $open_start;
+ # remove end, such that we have "<" instead of "<="
+ $set = $set->complement( $end ) if $open_end;
+ }
+
+ $self->{set} = $set;
+ bless $self, $class;
+ return $self;
+}
+
+sub from_datetime_and_duration {
+ my $class = shift;
+ my %args = @_;
+
+ my $key;
+ my $dt;
+ # extract datetime parameters
+ for ( qw( start end before after ) ) {
+ if ( exists $args{$_} ) {
+ $key = $_;
+ $dt = delete $args{$_};
+ }
+ }
+
+ # extract duration parameters
+ my $dt_duration;
+ if ( exists $args{duration} ) {
+ $dt_duration = $args{duration};
+ }
+ else {
+ $dt_duration = DateTime::Duration->new( %args );
+ }
+ # warn "Creating span from $key => ".$dt->datetime." and $dt_duration";
+ my $other_date = $dt->clone->add_duration( $dt_duration );
+ # warn "Creating span from $key => ".$dt->datetime." and ".$other_date->datetime;
+ my $other_key;
+ if ( $dt_duration->is_positive ) {
+ # check if have to invert keys
+ $key = 'after' if $key eq 'end';
+ $key = 'start' if $key eq 'before';
+ $other_key = 'before';
+ }
+ else {
+ # check if have to invert keys
+ $other_key = 'end' if $key eq 'after';
+ $other_key = 'before' if $key eq 'start';
+ $key = 'start';
+ }
+ return $class->new( $key => $dt, $other_key => $other_date );
+}
+
+# This method is intentionally not documented. It's really only for
+# use by ::Set and ::SpanSet's as_list() and iterator() methods.
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ # If we find anything _not_ appropriate for from_datetimes, we
+ # assume it must be for durations, and call this constructor.
+ # This way, we don't need to hardcode the DateTime::Duration
+ # parameters.
+ foreach ( keys %args )
+ {
+ return $class->from_datetime_and_duration(%args)
+ unless /^(?:before|after|start|end)$/;
+ }
+
+ return $class->from_datetimes(%args);
+}
+
+sub clone {
+ bless {
+ set => $_[0]->{set}->copy,
+ }, ref $_[0];
+}
+
+# Set::Infinite methods
+
+sub intersection {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ my $tmp = {}; # $class->new();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
+
+ # intersection() can generate something more complex than a span.
+ bless $tmp, 'DateTime::SpanSet';
+
+ return $tmp;
+}
+
+sub intersects {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ return $set1->{set}->intersects( $set2->{set} );
+}
+
+sub contains {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ return $set1->{set}->contains( $set2->{set} );
+}
+
+sub union {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ my $tmp = {}; # $class->new();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->union( $set2->{set} );
+
+ # union() can generate something more complex than a span.
+ bless $tmp, 'DateTime::SpanSet';
+
+ # # We have to check it's internal structure to find out.
+ # if ( $#{ $tmp->{set}->{list} } != 0 ) {
+ # bless $tmp, 'Date::SpanSet';
+ # }
+
+ return $tmp;
+}
+
+sub complement {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ my $tmp = {}; # $class->new;
+ if (defined $set2) {
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->complement( $set2->{set} );
+ }
+ else {
+ $tmp->{set} = $set1->{set}->complement;
+ }
+
+ # complement() can generate something more complex than a span.
+ bless $tmp, 'DateTime::SpanSet';
+
+ # # We have to check it's internal structure to find out.
+ # if ( $#{ $tmp->{set}->{list} } != 0 ) {
+ # bless $tmp, 'Date::SpanSet';
+ # }
+
+ return $tmp;
+}
+
+sub start {
+ return DateTime::Set::_fix_datetime( $_[0]->{set}->min );
+}
+
+*min = \&start;
+
+sub end {
+ return DateTime::Set::_fix_datetime( $_[0]->{set}->max );
+}
+
+*max = \&end;
+
+sub start_is_open {
+ # min_a returns info about the set boundary
+ my ($min, $open) = $_[0]->{set}->min_a;
+ return $open;
+}
+
+sub start_is_closed { $_[0]->start_is_open ? 0 : 1 }
+
+sub end_is_open {
+ # max_a returns info about the set boundary
+ my ($max, $open) = $_[0]->{set}->max_a;
+ return $open;
+}
+
+sub end_is_closed { $_[0]->end_is_open ? 0 : 1 }
+
+
+# span == $self
+sub span { @_ }
+
+sub duration {
+ my $dur;
+
+ local $@;
+ eval {
+ local $SIG{__DIE__}; # don't want to trap this (rt ticket 5434)
+ $dur = $_[0]->end->subtract_datetime_absolute( $_[0]->start )
+ };
+
+ return $dur if defined $dur;
+
+ return DateTime::Infinite::Future->new -
+ DateTime::Infinite::Past->new;
+}
+*size = \&duration;
+
+1;
+
+__END__
+
+=head1 NAME
+
+DateTime::Span - Datetime spans
+
+=head1 SYNOPSIS
+
+ use DateTime;
+ use DateTime::Span;
+
+ $date1 = DateTime->new( year => 2002, month => 3, day => 11 );
+ $date2 = DateTime->new( year => 2003, month => 4, day => 12 );
+ $set2 = DateTime::Span->from_datetimes( start => $date1, end => $date2 );
+ # set2 = 2002-03-11 until 2003-04-12
+
+ $set = $set1->union( $set2 ); # like "OR", "insert", "both"
+ $set = $set1->complement( $set2 ); # like "delete", "remove"
+ $set = $set1->intersection( $set2 ); # like "AND", "while"
+ $set = $set1->complement; # like "NOT", "negate", "invert"
+
+ if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $set1->contains( $set2 ) ) { ... # like "is-fully-inside"
+
+ # data extraction
+ $date = $set1->start; # first date of the span
+ $date = $set1->end; # last date of the span
+
+=head1 DESCRIPTION
+
+C<DateTime::Span> is a module for handling datetime spans, otherwise
+known as ranges or periods ("from X to Y, inclusive of all datetimes
+in between").
+
+This is different from a C<DateTime::Set>, which is made of individual
+datetime points as opposed to a range. There is also a module
+C<DateTime::SpanSet> to handle sets of spans.
+
+=head1 METHODS
+
+=over 4
+
+=item * from_datetimes
+
+Creates a new span based on a starting and ending datetime.
+
+A 'closed' span includes its end-dates:
+
+ $span = DateTime::Span->from_datetimes( start => $dt1, end => $dt2 );
+
+An 'open' span does not include its end-dates:
+
+ $span = DateTime::Span->from_datetimes( after => $dt1, before => $dt2 );
+
+A 'semi-open' span includes one of its end-dates:
+
+ $span = DateTime::Span->from_datetimes( start => $dt1, before => $dt2 );
+ $span = DateTime::Span->from_datetimes( after => $dt1, end => $dt2 );
+
+A span might have just a beginning date, or just an ending date.
+These spans end, or start, in an imaginary 'forever' date:
+
+ $span = DateTime::Span->from_datetimes( start => $dt1 );
+ $span = DateTime::Span->from_datetimes( end => $dt2 );
+ $span = DateTime::Span->from_datetimes( after => $dt1 );
+ $span = DateTime::Span->from_datetimes( before => $dt2 );
+
+You cannot give both a "start" and "after" argument, nor can you give
+both an "end" and "before" argument. Either of these conditions will
+cause the C<from_datetimes()> method to die.
+
+To summarize, a datetime passed as either "start" or "end" is included
+in the span. A datetime passed as either "after" or "before" is
+excluded from the span.
+
+=item * from_datetime_and_duration
+
+Creates a new span.
+
+ $span = DateTime::Span->from_datetime_and_duration(
+ start => $dt1, duration => $dt_dur1 );
+ $span = DateTime::Span->from_datetime_and_duration(
+ after => $dt1, hours => 12 );
+
+The new "end of the set" is I<open> by default.
+
+=item * clone
+
+This object method returns a replica of the given object.
+
+=item * set_time_zone( $tz )
+
+This method accepts either a time zone object or a string that can be
+passed as the "name" parameter to C<< DateTime::TimeZone->new() >>.
+If the new time zone's offset is different from the old time zone,
+then the I<local> time is adjusted accordingly.
+
+If the old time zone was a floating time zone, then no adjustments to
+the local time are made, except to account for leap seconds. If the
+new time zone is floating, then the I<UTC> time is adjusted in order
+to leave the local time untouched.
+
+=item * duration
+
+The total size of the set, as a C<DateTime::Duration> object, or as a
+scalar containing infinity.
+
+Also available as C<size()>.
+
+=item * start
+
+=item * end
+
+First or last dates in the span.
+
+It is possible that the return value from these methods may be a
+C<DateTime::Infinite::Future> or a C<DateTime::Infinite::Past>xs object.
+
+If the set ends C<before> a date C<$dt>, it returns C<$dt>. Note that
+in this case C<$dt> is not a set element - but it is a set boundary.
+
+=cut
+
+# scalar containing either negative infinity
+# or positive infinity.
+
+=item * start_is_closed
+
+=item * end_is_closed
+
+Returns true if the first or last dates belong to the span ( begin <= x <= end ).
+
+=item * start_is_open
+
+=item * end_is_open
+
+Returns true if the first or last dates are excluded from the span ( begin < x < end ).
+
+=item * union
+
+=item * intersection
+
+=item * complement
+
+Set operations may be performed not only with C<DateTime::Span>
+objects, but also with C<DateTime::Set> and C<DateTime::SpanSet>
+objects. These set operations always return a C<DateTime::SpanSet>
+object.
+
+ $set = $span->union( $set2 ); # like "OR", "insert", "both"
+ $set = $span->complement( $set2 ); # like "delete", "remove"
+ $set = $span->intersection( $set2 ); # like "AND", "while"
+ $set = $span->complement; # like "NOT", "negate", "invert"
+
+=item * intersects
+
+=item * contains
+
+These set functions return a boolean value.
+
+ if ( $span->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $span->contains( $dt ) ) { ... # like "is-fully-inside"
+
+These methods can accept a C<DateTime>, C<DateTime::Set>,
+C<DateTime::Span>, or C<DateTime::SpanSet> object as an argument.
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+The API was developed together with Dave Rolsky and the DateTime Community.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003-2006 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can distribute it and/or modify it
+under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file
+included with this module.
+
+=head1 SEE ALSO
+
+Set::Infinite
+
+For details on the Perl DateTime Suite project please see
+L<http://datetime.perl.org>.
+
+=cut
+
--- /dev/null
+# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package DateTime::SpanSet;
+
+use strict;
+
+use DateTime::Set;
+use DateTime::Infinite;
+
+use Carp;
+use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
+use vars qw( $VERSION );
+
+use constant INFINITY => 100 ** 100 ** 100 ;
+use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
+$VERSION = $DateTime::Set::VERSION;
+
+sub iterate {
+ my ( $self, $callback ) = @_;
+ my $class = ref( $self );
+ my $return = $class->empty_set;
+ $return->{set} = $self->{set}->iterate(
+ sub {
+ my $span = bless { set => $_[0] }, 'DateTime::Span';
+ $callback->( $span->clone );
+ $span = $span->{set}
+ if UNIVERSAL::can( $span, 'union' );
+ return $span;
+ }
+ );
+ $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 $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
+ my @list = $callback->();
+ my $set = $class->empty_set;
+ $set = $set->union( $_ ) for @list;
+ return $set->{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 $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
+ my $result = $callback->();
+ return $_ if $result;
+ return;
+ }
+ );
+ $return;
+}
+
+sub set_time_zone {
+ my ( $self, $tz ) = @_;
+
+ # TODO - use iterate() instead
+
+ my $result = $self->{set}->iterate(
+ sub {
+ my %tmp = %{ $_[0]->{list}[0] };
+ $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
+ $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
+ \%tmp;
+ },
+ backtrack_callback => sub {
+ my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
+ if ( ref($min) )
+ {
+ $min = $min->clone;
+ $min->set_time_zone( 'floating' );
+ }
+ if ( ref($max) )
+ {
+ $max = $max->clone;
+ $max->set_time_zone( 'floating' );
+ }
+ return Set::Infinite::_recurrence->new( $min, $max );
+ },
+ );
+
+ ### this code enables 'subroutine method' behaviour
+ $self->{set} = $result;
+ return $self;
+}
+
+sub from_spans {
+ my $class = shift;
+ my %args = validate( @_,
+ { spans =>
+ { type => ARRAYREF,
+ optional => 1,
+ },
+ }
+ );
+ my $self = {};
+ my $set = Set::Infinite::_recurrence->new();
+ $set = $set->union( $_->{set} ) for @{ $args{spans} };
+ $self->{set} = $set;
+ bless $self, $class;
+ return $self;
+}
+
+sub from_set_and_duration {
+ # set => $dt_set, days => 1
+ my $class = shift;
+ my %args = @_;
+ my $set = delete $args{set} ||
+ carp "from_set_and_duration needs a 'set' parameter";
+
+ $set = $set->as_set
+ if UNIVERSAL::can( $set, 'as_set' );
+ unless ( UNIVERSAL::can( $set, 'union' ) ) {
+ carp "'set' must be a set" };
+
+ my $duration = delete $args{duration} ||
+ new DateTime::Duration( %args );
+ my $end_set = $set->clone->add_duration( $duration );
+ return $class->from_sets( start_set => $set,
+ end_set => $end_set );
+}
+
+sub from_sets {
+ my $class = shift;
+ my %args = validate( @_,
+ { start_set =>
+ { # can => 'union',
+ optional => 0,
+ },
+ end_set =>
+ { # can => 'union',
+ optional => 0,
+ },
+ }
+ );
+ my $start_set = delete $args{start_set};
+ my $end_set = delete $args{end_set};
+
+ $start_set = $start_set->as_set
+ if UNIVERSAL::can( $start_set, 'as_set' );
+ $end_set = $end_set->as_set
+ if UNIVERSAL::can( $end_set, 'as_set' );
+
+ unless ( UNIVERSAL::can( $start_set, 'union' ) ) {
+ carp "'start_set' must be a set" };
+ unless ( UNIVERSAL::can( $end_set, 'union' ) ) {
+ carp "'end_set' must be a set" };
+
+ my $self;
+ $self->{set} = $start_set->{set}->until(
+ $end_set->{set} );
+ bless $self, $class;
+ return $self;
+}
+
+sub start_set {
+ if ( exists $_[0]->{set}{method} &&
+ $_[0]->{set}{method} eq 'until' )
+ {
+ return bless { set => $_[0]->{set}{parent}[0] }, 'DateTime::Set';
+ }
+ my $return = DateTime::Set->empty_set;
+ $return->{set} = $_[0]->{set}->start_set;
+ $return;
+}
+
+sub end_set {
+ if ( exists $_[0]->{set}{method} &&
+ $_[0]->{set}{method} eq 'until' )
+ {
+ return bless { set => $_[0]->{set}{parent}[1] }, 'DateTime::Set';
+ }
+ my $return = DateTime::Set->empty_set;
+ $return->{set} = $_[0]->{set}->end_set;
+ $return;
+}
+
+sub empty_set {
+ my $class = shift;
+
+ return bless { set => Set::Infinite::_recurrence->new }, $class;
+}
+
+sub clone {
+ bless {
+ set => $_[0]->{set}->copy,
+ }, ref $_[0];
+}
+
+
+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()
+sub next {
+ my ($self) = shift;
+
+ # TODO: this is fixing an error from elsewhere
+ # - find out what's going on! (with "sunset.pl")
+ return undef unless ref $self->{set};
+
+ if ( @_ )
+ {
+ my $max;
+ $max = $_[0]->max if UNIVERSAL::can( $_[0], 'union' );
+ $max = $_[0] if ! defined $max;
+
+ return undef if ! ref( $max ) && $max == INFINITY;
+
+ my $span = DateTime::Span->from_datetimes( start => $max );
+ my $iterator = $self->intersection( $span );
+ my $return = $iterator->next;
+
+ return $return if ! defined $return;
+ return $return if ! $return->intersects( $max );
+
+ return $iterator->next;
+ }
+
+ my ($head, $tail) = $self->{set}->first;
+ $self->{set} = $tail;
+ return $head unless ref $head;
+ my $return = {
+ set => $head,
+ };
+ bless $return, 'DateTime::Span';
+ return $return;
+}
+
+# previous() gets the last element from an iterator()
+sub previous {
+ my ($self) = shift;
+
+ return undef unless ref $self->{set};
+
+ if ( @_ )
+ {
+ my $min;
+ $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
+ $min = $_[0] if ! defined $min;
+
+ return undef if ! ref( $min ) && $min == INFINITY;
+
+ my $span = DateTime::Span->from_datetimes( end => $min );
+ my $iterator = $self->intersection( $span );
+ my $return = $iterator->previous;
+
+ return $return if ! defined $return;
+ return $return if ! $return->intersects( $min );
+
+ return $iterator->previous;
+ }
+
+ my ($head, $tail) = $self->{set}->last;
+ $self->{set} = $tail;
+ return $head unless ref $head;
+ my $return = {
+ set => $head,
+ };
+ bless $return, 'DateTime::Span';
+ return $return;
+}
+
+# "current" means less-or-equal to a DateTime
+sub current {
+ my $self = shift;
+
+ my $previous;
+ my $next;
+ {
+ my $min;
+ $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
+ $min = $_[0] if ! defined $min;
+ return undef if ! ref( $min ) && $min == INFINITY;
+ my $span = DateTime::Span->from_datetimes( end => $min );
+ my $iterator = $self->intersection( $span );
+ $previous = $iterator->previous;
+ $span = DateTime::Span->from_datetimes( start => $min );
+ $iterator = $self->intersection( $span );
+ $next = $iterator->next;
+ }
+ return $previous unless defined $next;
+
+ my $dt1 = defined $previous
+ ? $next->union( $previous )
+ : $next;
+
+ my $return = $dt1->intersected_spans( $_[0] );
+
+ $return = $previous
+ if !defined $return->max;
+
+ bless $return, 'DateTime::SpanSet'
+ if defined $return;
+ return $return;
+}
+
+sub closest {
+ my $self = shift;
+ my $dt = shift;
+
+ my $dt1 = $self->current( $dt );
+ my $dt2 = $self->next( $dt );
+ bless $dt2, 'DateTime::SpanSet'
+ if defined $dt2;
+
+ return $dt2 unless defined $dt1;
+ return $dt1 unless defined $dt2;
+
+ $dt = DateTime::Set->from_datetimes( dates => [ $dt ] )
+ unless UNIVERSAL::can( $dt, 'union' );
+
+ return $dt1 if $dt1->contains( $dt );
+
+ my $delta = $dt->min - $dt1->max;
+ return $dt1 if ( $dt2->min - $delta ) >= $dt->max;
+
+ 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;
+
+ # 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 if $set->{set}->is_null; # nothing = empty
+ my @result;
+ # we should extract _copies_ of the set elements,
+ # such that the user can't modify the set indirectly
+
+ my $iter = $set->iterator;
+ while ( my $dt = $iter->next )
+ {
+ push @result, $dt
+ if ref( $dt ); # we don't want to return INFINITY value
+ };
+
+ return @result;
+}
+
+# Set::Infinite methods
+
+sub intersection {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
+ return $tmp;
+}
+
+sub intersected_spans {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->intersected_spans( $set2->{set} );
+ return $tmp;
+}
+
+sub intersects {
+ my ($set1, $set2) = ( shift, shift );
+
+ unless ( $set2->can( 'union' ) )
+ {
+ for ( $set2, @_ )
+ {
+ return 1 if $set1->contains( $_ );
+ }
+ return 0;
+ }
+
+ my $class = ref($set1);
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ return $set1->{set}->intersects( $set2->{set} );
+}
+
+sub contains {
+ my ($set1, $set2) = ( shift, shift );
+
+ unless ( $set2->can( 'union' ) )
+ {
+ if ( exists $set1->{set}{method} &&
+ $set1->{set}{method} eq 'until' )
+ {
+ my $start_set = $set1->start_set;
+ my $end_set = $set1->end_set;
+
+ for ( $set2, @_ )
+ {
+ my $start = $start_set->next( $set2 );
+ my $end = $end_set->next( $set2 );
+
+ goto ABORT unless defined $start && defined $end;
+
+ return 0 if $start < $end;
+ }
+ return 1;
+
+ ABORT: ;
+ # don't know
+ }
+ }
+
+ my $class = ref($set1);
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ 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_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->union( $set2->{set} );
+ return $tmp;
+}
+
+sub complement {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ if (defined $set2) {
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->complement( $set2->{set} );
+ }
+ else {
+ $tmp->{set} = $set1->{set}->complement;
+ }
+ return $tmp;
+}
+
+sub min {
+ return DateTime::Set::_fix_datetime( $_[0]->{set}->min );
+}
+
+sub max {
+ return DateTime::Set::_fix_datetime( $_[0]->{set}->max );
+}
+
+# returns a DateTime::Span
+sub span {
+ my $set = $_[0]->{set}->span;
+ my $self = bless { set => $set }, 'DateTime::Span';
+ return $self;
+}
+
+# returns a DateTime::Duration
+sub duration {
+ my $dur;
+
+ return DateTime::Duration->new( seconds => 0 )
+ if $_[0]->{set}->is_empty;
+
+ local $@;
+ eval {
+ local $SIG{__DIE__}; # don't want to trap this (rt ticket 5434)
+ $dur = $_[0]->{set}->size
+ };
+
+ return $dur if defined $dur && ref( $dur );
+ return DateTime::Infinite::Future->new -
+ DateTime::Infinite::Past->new;
+ # return INFINITY;
+}
+*size = \&duration;
+
+1;
+
+__END__
+
+=head1 NAME
+
+DateTime::SpanSet - set of DateTime spans
+
+=head1 SYNOPSIS
+
+ $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span, $dt_span ] );
+
+ $set = $spanset->union( $set2 ); # like "OR", "insert", "both"
+ $set = $spanset->complement( $set2 ); # like "delete", "remove"
+ $set = $spanset->intersection( $set2 ); # like "AND", "while"
+ $set = $spanset->complement; # like "NOT", "negate", "invert"
+
+ if ( $spanset->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $spanset->contains( $set2 ) ) { ... # like "is-fully-inside"
+
+ # data extraction
+ $date = $spanset->min; # first date of the set
+ $date = $spanset->max; # last date of the set
+
+ $iter = $spanset->iterator;
+ while ( $dt = $iter->next ) {
+ # $dt is a DateTime::Span
+ print $dt->start->ymd; # first date of span
+ print $dt->end->ymd; # last date of span
+ };
+
+=head1 DESCRIPTION
+
+C<DateTime::SpanSet> is a class that represents sets of datetime
+spans. An example would be a recurring meeting that occurs from
+13:00-15:00 every Friday.
+
+This is different from a C<DateTime::Set>, which is made of individual
+datetime points as opposed to ranges.
+
+=head1 METHODS
+
+=over 4
+
+=item * from_spans
+
+Creates a new span set from one or more C<DateTime::Span> objects.
+
+ $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span ] );
+
+=item * from_set_and_duration
+
+Creates a new span set from one or more C<DateTime::Set> objects and a
+duration.
+
+The duration can be a C<DateTime::Duration> object, or the parameters
+to create a new C<DateTime::Duration> object, such as "days",
+"months", etc.
+
+ $spanset =
+ DateTime::SpanSet->from_set_and_duration
+ ( set => $dt_set, days => 1 );
+
+=item * from_sets
+
+Creates a new span set from two C<DateTime::Set> objects.
+
+One set defines the I<starting dates>, and the other defines the I<end
+dates>.
+
+ $spanset =
+ DateTime::SpanSet->from_sets
+ ( start_set => $dt_set1, end_set => $dt_set2 );
+
+The spans have the starting date C<closed>, and the end date C<open>,
+like in C<[$dt1, $dt2)>.
+
+If an end date comes without a starting date before it, then it
+defines a span like C<(-inf, $dt)>.
+
+If a starting date comes without an end date after it, then it defines
+a span like C<[$dt, inf)>.
+
+=item * empty_set
+
+Creates a new empty set.
+
+=item * clone
+
+This object method returns a replica of the given object.
+
+=item * set_time_zone( $tz )
+
+This method accepts either a time zone object or a string that can be
+passed as the "name" parameter to C<< DateTime::TimeZone->new() >>.
+If the new time zone's offset is different from the old time zone,
+then the I<local> time is adjusted accordingly.
+
+If the old time zone was a floating time zone, then no adjustments to
+the local time are made, except to account for leap seconds. If the
+new time zone is floating, then the I<UTC> time is adjusted in order
+to leave the local time untouched.
+
+=item * min
+
+=item * max
+
+First or last dates in the set. These methods may return C<undef> if
+the set is empty. It is also possible that these methods may return a
+scalar containing infinity or negative infinity.
+
+=item * duration
+
+The total size of the set, as a C<DateTime::Duration> object.
+
+The duration may be infinite.
+
+Also available as C<size()>.
+
+=item * span
+
+The total span of the set, as a C<DateTime::Span> object.
+
+=item * next
+
+ my $span = $set->next( $dt );
+
+This method is used to find the next span in the set,
+after a given datetime or span.
+
+The return value is a C<DateTime::Span>, or C<undef> if there is no matching
+span in the set.
+
+=item * previous
+
+ my $span = $set->previous( $dt );
+
+This method is used to find the previous span in the set,
+before a given datetime or span.
+
+The return value is a C<DateTime::Span>, or C<undef> if there is no matching
+span in the set.
+
+
+=item * current
+
+ my $span = $set->current( $dt );
+
+This method is used to find the "current" span in the set,
+that intersects a given datetime or span. If no current span
+is found, then the "previous" span is returned.
+
+The return value is a C<DateTime::SpanSet>, or C<undef> if there is no
+matching span in the set.
+
+If a span parameter is given, it may happen that "current" returns
+more than one span.
+
+See also: C<intersected_spans()> method.
+
+=item * closest
+
+ my $span = $set->closest( $dt );
+
+This method is used to find the "closest" span in the set, given a
+datetime or span.
+
+The return value is a C<DateTime::SpanSet>, or C<undef> if the set is
+empty.
+
+If a span parameter is given, it may happen that "closest" returns
+more than one span.
+
+=item * as_list
+
+Returns a list of C<DateTime::Span> objects.
+
+ my @dt_span = $set->as_list( span => $span );
+
+Just as with the C<iterator()> method, the C<as_list()> method can be
+limited by a span.
+
+Applying C<as_list()> to a large recurring spanset is a very expensive
+operation, both in CPU time and in the memory used.
+
+For this reason, when C<as_list()> operates on large recurrence sets,
+it will return at most approximately 200 spans. For larger sets, and
+for I<infinite> sets, C<as_list()> will return C<undef>.
+
+Please note that this is explicitly not an empty list, since an empty
+list is a valid return value for empty sets!
+
+If you I<really> need to extract spans from a large set, you can:
+
+- limit the set with a shorter span:
+
+ my @short_list = $large_set->as_list( span => $short_span );
+
+- use an iterator:
+
+ my @large_list;
+ my $iter = $large_set->iterator;
+ push @large_list, $dt while $dt = $iter->next;
+
+=item * union
+
+=item * intersection
+
+=item * complement
+
+Set operations may be performed not only with C<DateTime::SpanSet>
+objects, but also with C<DateTime>, C<DateTime::Set> and
+C<DateTime::Span> objects. These set operations always return a
+C<DateTime::SpanSet> object.
+
+ $set = $spanset->union( $set2 ); # like "OR", "insert", "both"
+ $set = $spanset->complement( $set2 ); # like "delete", "remove"
+ $set = $spanset->intersection( $set2 ); # like "AND", "while"
+ $set = $spanset->complement; # like "NOT", "negate", "invert"
+
+=item * intersected_spans
+
+This method can accept a C<DateTime> list, a C<DateTime::Set>, a
+C<DateTime::Span>, or a C<DateTime::SpanSet> object as an argument.
+
+ $set = $set1->intersected_spans( $set2 );
+
+The method always returns a C<DateTime::SpanSet> object, containing
+all spans that are intersected by the given set.
+
+Unlike the C<intersection> method, the spans are not modified. See
+diagram below:
+
+ set1 [....] [....] [....] [....]
+ set2 [................]
+
+ intersection [.] [....] [.]
+
+ intersected_spans [....] [....] [....]
+
+=item * intersects
+
+=item * contains
+
+These set functions return a boolean value.
+
+ if ( $spanset->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $spanset->contains( $dt ) ) { ... # like "is-fully-inside"
+
+These methods can accept a C<DateTime>, C<DateTime::Set>,
+C<DateTime::Span>, or C<DateTime::SpanSet> object as an argument.
+
+=item * iterator / next / previous
+
+This method can be used to iterate over the spans in a set.
+
+ $iter = $spanset->iterator;
+ while ( $dt = $iter->next ) {
+ # $dt is a DateTime::Span
+ print $dt->min->ymd; # first date of span
+ print $dt->max->ymd; # last date of span
+ }
+
+The boundaries of the iterator can be limited by passing it a C<span>
+parameter. This should be a C<DateTime::Span> object which delimits
+the iterator's boundaries. Optionally, instead of passing an object,
+you can pass any parameters that would work for one of the
+C<DateTime::Span> class's constructors, and an object will be created
+for you.
+
+Obviously, if the span you specify does is not restricted both at the
+start and end, then your iterator may iterate forever, depending on
+the nature of your set. User beware!
+
+The C<next()> or C<previous()> methods will return C<undef> when there
+are no more spans in the iterator.
+
+=item * start_set
+
+=item * end_set
+
+These methods do the inverse of the C<from_sets> method:
+
+C<start_set> retrieves a DateTime::Set with the start datetime of each
+span.
+
+C<end_set> retrieves a DateTime::Set with the end datetime of each
+span.
+
+=item * map ( sub { ... } )
+
+ # example: enlarge the spans
+ $set = $set2->map(
+ sub {
+ my $start = $_->start;
+ my $end = $_->end;
+ return DateTime::Span->from_datetimes(
+ start => $start,
+ before => $end,
+ );
+ }
+ );
+
+This method is the "set" version of Perl "map".
+
+It evaluates a subroutine for each element of the set (locally setting
+"$_" to each DateTime::Span) and returns the set composed of the
+results of each such evaluation.
+
+Like Perl "map", each element of the set may produce zero, one, or
+more elements in the returned value.
+
+Unlike Perl "map", changing "$_" does not change the original
+set. This means that calling map in void context has no effect.
+
+The callback subroutine may not be called immediately. Don't count on
+subroutine side-effects. For example, a C<print> inside the subroutine
+may happen later than you expect.
+
+The callback return value is expected to be within the span of the
+C<previous> and the C<next> element in the original set.
+
+For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
+result for the value C<2010> is expected to be within the span C<[
+2001 .. 2015 ]>.
+
+=item * grep ( sub { ... } )
+
+ # example: filter out all spans happening today
+ my $today = DateTime->today;
+ $set = $set2->grep(
+ sub {
+ return ( ! $_->contains( $today ) );
+ }
+ );
+
+This method is the "set" version of Perl "grep".
+
+It evaluates a subroutine for each element of the set (locally setting
+"$_" to each DateTime::Span) and returns the set consisting of those
+elements for which the expression evaluated to true.
+
+Unlike Perl "grep", changing "$_" does not change the original
+set. This means that calling grep in void context has no effect.
+
+Changing "$_" does change the resulting set.
+
+The callback subroutine may not be called immediately. Don't count on
+subroutine side-effects. For example, a C<print> inside the subroutine
+may happen later than you expect.
+
+=item * iterate
+
+I<Internal method - use "map" or "grep" instead.>
+
+This function apply a callback subroutine to all elements of a set and
+returns the resulting set.
+
+The parameter C<$_[0]> to the callback subroutine is a
+C<DateTime::Span> object.
+
+If the callback returns C<undef>, the datetime is removed from the
+set:
+
+ sub remove_sundays {
+ $_[0] unless $_[0]->start->day_of_week == 7;
+ }
+
+The callback return value is expected to be within the span of the
+C<previous> and the C<next> element in the original set.
+
+For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
+result for the value C<2010> is expected to be within the span C<[
+2001 .. 2015 ]>.
+
+The callback subroutine may not be called immediately. Don't count on
+subroutine side-effects. For example, a C<print> inside the subroutine
+may happen later than you expect.
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+The API was developed together with Dave Rolsky and the DateTime Community.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can distribute it and/or
+modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file
+included with this module.
+
+=head1 SEE ALSO
+
+Set::Infinite
+
+For details on the Perl DateTime Suite project please see
+L<http://datetime.perl.org>.
+
+=cut
+
--- /dev/null
+# Copyright 2001 Abhijit Menon-Sen <ams@toroid.org>
+
+package Set::Crontab;
+
+use strict;
+use Carp;
+use vars qw( $VERSION );
+
+$VERSION = '1.03';
+
+sub _expand
+{
+ my (@list, @and, @not);
+ my ($self, $spec, $range) = @_;
+
+ # 1,2-4,*/3,!13,>9,<15
+ foreach (split /,/, $spec) {
+ my @pick;
+ my $step = $1 if s#/(\d+)$##;
+
+ # 0+"01" == 1
+ if (/^(\d+)$/) { push @pick, 0+$1; }
+ elsif (/^\*$/) { push @pick, @$range; }
+ elsif (/^(\d+)-(\d+)$/) { push @pick, 0+$1..0+$2; }
+ elsif (/^!(\d+)$/) { push @not, "\$_ != 0+$1"; }
+ elsif (/^([<>])(\d+)$/) { push @and, "\$_ $1 0+$2"; }
+
+ if ($step) {
+ my $i;
+ @pick = grep { defined $_ if $i++ % $step == 0 } @pick;
+ }
+
+ push @list, @pick;
+ }
+
+ if (@and) {
+ my $and = join q{ && }, @and;
+ push @list, grep { defined $_ if eval $and } @$range;
+ }
+
+ if (@not) {
+ my $not = join q{ && }, @not;
+ @list = grep { defined $_ if eval $not } (@list ? @list : @$range);
+ }
+
+ @list = sort { $a <=> $b } @list;
+ return \@list;
+}
+
+sub _initialise
+{
+ my ($self, $spec, $range) = @_;
+ return undef unless ref($self);
+
+ croak "Usage: ".__PACKAGE__."->new(\$spec, [\@range])"
+ unless defined $spec && ref($range) eq "ARRAY";
+
+ $self->{LIST} = $self->_expand($spec, $range);
+ $self->{HASH} = {map {$_ => 1} @{$self->{LIST}}};
+
+ return $self;
+};
+
+sub new
+{
+ my $class = shift;
+ my $self = bless {}, ref($class) || $class;
+ return $self->_initialise(@_);
+}
+
+sub contains
+{
+ my ($self, $num) = @_;
+
+ croak "Usage: \$set->contains(\$num)" unless ref($self) && defined $num;
+ return exists $self->{HASH}{$num};
+}
+
+sub list
+{
+ my $self = shift;
+
+ croak "Usage: \$set->list()" unless ref($self);
+ return @{$self->{LIST}};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Set::Crontab - Expand crontab(5)-style integer lists
+
+=head1 SYNOPSIS
+
+$s = Set::Crontab->new("1-9/3,>15,>30,!23", [0..30]);
+
+if ($s->contains(3)) { ... }
+
+=head1 DESCRIPTION
+
+Set::Crontab parses crontab-style lists of integers and defines some
+utility functions to make it easier to deal with them.
+
+=head2 Syntax
+
+Numbers, ranges, *, and step values all work exactly as described in
+L<crontab(5)>. A few extensions to the standard syntax are described
+below.
+
+=over 4
+
+=item < and >
+
+<N selects the elements smaller than N from the entire range, and adds
+them to the set. >N does likewise for elements larger than N.
+
+=item !
+
+!N excludes N from the set. It applies to the other specified
+range; otherwise it applies to the specified ranges (i.e. "!3" with a
+range of "1-10" corresponds to "1-2,4-10", but ">3,!7" in the same range
+means "4-6,8-10").
+
+=back
+
+=head2 Functions
+
+=over 4
+
+=item new($spec, [@range])
+
+Creates a new Set::Crontab object and returns a reference to it.
+
+=item contains($num)
+
+Returns true if C<$num> exists in the set.
+
+=item list()
+
+Returns the expanded list corresponding to the set. Elements are in
+ascending order.
+
+=back
+
+The functions described above croak if they are called with incorrect
+arguments.
+
+=head1 SEE ALSO
+
+L<crontab(5)>
+
+=head1 AUTHOR
+
+Abhijit Menon-Sen <ams@toroid.org>
+
+Copyright 2001 Abhijit Menon-Sen <ams@toroid.org>
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
--- /dev/null
+package Set::Infinite;
+
+# Copyright (c) 2001, 2002, 2003, 2004 Flavio Soibelmann Glock.
+# All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+use 5.005_03;
+
+# These methods are inherited from Set::Infinite::Basic "as-is":
+# type list fixtype numeric min max integer real new span copy
+# start_set end_set universal_set empty_set minus difference
+# symmetric_difference is_empty
+
+use strict;
+use base qw(Set::Infinite::Basic Exporter);
+use Carp;
+use Set::Infinite::Arithmetic;
+
+use overload
+ '<=>' => \&spaceship,
+ '""' => \&as_string;
+
+use vars qw(@EXPORT_OK $VERSION
+ $TRACE $DEBUG_BT $PRETTY_PRINT $inf $minus_inf $neg_inf
+ %_first %_last %_backtrack
+ $too_complex $backtrack_depth
+ $max_backtrack_depth $max_intersection_depth
+ $trace_level %level_title );
+
+@EXPORT_OK = qw(inf $inf trace_open trace_close);
+
+$inf = 100**100**100;
+$neg_inf = $minus_inf = -$inf;
+
+
+# obsolete methods - included for backward compatibility
+sub inf () { $inf }
+sub minus_inf () { $minus_inf }
+sub no_cleanup { $_[0] }
+*type = \&Set::Infinite::Basic::type;
+sub compact { @_ }
+
+
+BEGIN {
+ $VERSION = "0.65";
+ $TRACE = 0; # enable basic trace method execution
+ $DEBUG_BT = 0; # enable backtrack tracer
+ $PRETTY_PRINT = 0; # 0 = print 'Too Complex'; 1 = describe functions
+ $trace_level = 0; # indentation level when debugging
+
+ $too_complex = "Too complex";
+ $backtrack_depth = 0;
+ $max_backtrack_depth = 10; # _backtrack()
+ $max_intersection_depth = 5; # first()
+}
+
+sub trace { # title=>'aaa'
+ return $_[0] unless $TRACE;
+ my ($self, %parm) = @_;
+ my @caller = caller(1);
+ # print "self $self ". ref($self). "\n";
+ print "" . ( ' | ' x $trace_level ) .
+ "$parm{title} ". $self->copy .
+ ( exists $parm{arg} ? " -- " . $parm{arg}->copy : "" ).
+ " $caller[1]:$caller[2] ]\n" if $TRACE == 1;
+ return $self;
+}
+
+sub trace_open {
+ return $_[0] unless $TRACE;
+ my ($self, %parm) = @_;
+ my @caller = caller(1);
+ print "" . ( ' | ' x $trace_level ) .
+ "\\ $parm{title} ". $self->copy .
+ ( exists $parm{arg} ? " -- ". $parm{arg}->copy : "" ).
+ " $caller[1]:$caller[2] ]\n";
+ $trace_level++;
+ $level_title{$trace_level} = $parm{title};
+ return $self;
+}
+
+sub trace_close {
+ return $_[0] unless $TRACE;
+ my ($self, %parm) = @_;
+ my @caller = caller(0);
+ print "" . ( ' | ' x ($trace_level-1) ) .
+ "\/ $level_title{$trace_level} ".
+ ( exists $parm{arg} ?
+ (
+ defined $parm{arg} ?
+ "ret ". ( UNIVERSAL::isa($parm{arg}, __PACKAGE__ ) ?
+ $parm{arg}->copy :
+ "<$parm{arg}>" ) :
+ "undef"
+ ) :
+ "" # no arg
+ ).
+ " $caller[1]:$caller[2] ]\n";
+ $trace_level--;
+ return $self;
+}
+
+
+# creates a 'function' object that can be solved by _backtrack()
+sub _function {
+ my ($self, $method) = (shift, shift);
+ my $b = $self->empty_set();
+ $b->{too_complex} = 1;
+ $b->{parent} = $self;
+ $b->{method} = $method;
+ $b->{param} = [ @_ ];
+ return $b;
+}
+
+
+# same as _function, but with 2 arguments
+sub _function2 {
+ my ($self, $method, $arg) = (shift, shift, shift);
+ unless ( $self->{too_complex} || $arg->{too_complex} ) {
+ return $self->$method($arg, @_);
+ }
+ my $b = $self->empty_set();
+ $b->{too_complex} = 1;
+ $b->{parent} = [ $self, $arg ];
+ $b->{method} = $method;
+ $b->{param} = [ @_ ];
+ return $b;
+}
+
+
+sub quantize {
+ my $self = shift;
+ $self->trace_open(title=>"quantize") if $TRACE;
+ my @min = $self->min_a;
+ my @max = $self->max_a;
+ if (($self->{too_complex}) or
+ (defined $min[0] && $min[0] == $neg_inf) or
+ (defined $max[0] && $max[0] == $inf)) {
+
+ return $self->_function( 'quantize', @_ );
+ }
+
+ my @a;
+ my %rule = @_;
+ my $b = $self->empty_set();
+ my $parent = $self;
+
+ $rule{unit} = 'one' unless $rule{unit};
+ $rule{quant} = 1 unless $rule{quant};
+ $rule{parent} = $parent;
+ $rule{strict} = $parent unless exists $rule{strict};
+ $rule{type} = $parent->{type};
+
+ my ($min, $open_begin) = $parent->min_a;
+
+ unless (defined $min) {
+ $self->trace_close( arg => $b ) if $TRACE;
+ return $b;
+ }
+
+ $rule{fixtype} = 1 unless exists $rule{fixtype};
+ $Set::Infinite::Arithmetic::Init_quantizer{$rule{unit}}->(\%rule);
+
+ $rule{sub_unit} = $Set::Infinite::Arithmetic::Offset_to_value{$rule{unit}};
+ carp "Quantize unit '".$rule{unit}."' not implemented" unless ref( $rule{sub_unit} ) eq 'CODE';
+
+ my ($max, $open_end) = $parent->max_a;
+ $rule{offset} = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $min);
+ my $last_offset = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $max);
+ $rule{size} = $last_offset - $rule{offset} + 1;
+ my ($index, $tmp, $this, $next);
+ for $index (0 .. $rule{size} ) {
+ # ($this, $next) = $rule{sub_unit} (\%rule, $index);
+ ($this, $next) = $rule{sub_unit}->(\%rule, $index);
+ unless ( $rule{fixtype} ) {
+ $tmp = { a => $this , b => $next ,
+ open_begin => 0, open_end => 1 };
+ }
+ else {
+ $tmp = Set::Infinite::Basic::_simple_new($this,$next, $rule{type} );
+ $tmp->{open_end} = 1;
+ }
+ next if ( $rule{strict} and not $rule{strict}->intersects($tmp));
+ push @a, $tmp;
+ }
+
+ $b->{list} = \@a; # change data
+ $self->trace_close( arg => $b ) if $TRACE;
+ return $b;
+}
+
+
+sub _first_n {
+ my $self = shift;
+ my $n = shift;
+ my $tail = $self->copy;
+ my @result;
+ my $first;
+ for ( 1 .. $n )
+ {
+ ( $first, $tail ) = $tail->first if $tail;
+ push @result, $first;
+ }
+ return $tail, @result;
+}
+
+sub _last_n {
+ my $self = shift;
+ my $n = shift;
+ my $tail = $self->copy;
+ my @result;
+ my $last;
+ for ( 1 .. $n )
+ {
+ ( $last, $tail ) = $tail->last if $tail;
+ unshift @result, $last;
+ }
+ return $tail, @result;
+}
+
+
+sub select {
+ my $self = shift;
+ $self->trace_open(title=>"select") if $TRACE;
+
+ my %param = @_;
+ die "select() - parameter 'freq' is deprecated" if exists $param{freq};
+
+ my $res;
+ my $count;
+ my @by;
+ @by = @{ $param{by} } if exists $param{by};
+ $count = delete $param{count} || $inf;
+ # warn "select: count=$count by=[@by]";
+
+ if ($count <= 0) {
+ $self->trace_close( arg => $res ) if $TRACE;
+ return $self->empty_set();
+ }
+
+ my @set;
+ my $tail;
+ my $first;
+ my $last;
+ if ( @by )
+ {
+ my @res;
+ if ( ! $self->is_too_complex )
+ {
+ $res = $self->new;
+ @res = @{ $self->{list} }[ @by ] ;
+ }
+ else
+ {
+ my ( @pos_by, @neg_by );
+ for ( @by ) {
+ ( $_ < 0 ) ? push @neg_by, $_ :
+ push @pos_by, $_;
+ }
+ my @first;
+ if ( @pos_by ) {
+ @pos_by = sort { $a <=> $b } @pos_by;
+ ( $tail, @set ) = $self->_first_n( 1 + $pos_by[-1] );
+ @first = @set[ @pos_by ];
+ }
+ my @last;
+ if ( @neg_by ) {
+ @neg_by = sort { $a <=> $b } @neg_by;
+ ( $tail, @set ) = $self->_last_n( - $neg_by[0] );
+ @last = @set[ @neg_by ];
+ }
+ @res = map { $_->{list}[0] } ( @first , @last );
+ }
+
+ $res = $self->new;
+ @res = sort { $a->{a} <=> $b->{a} } grep { defined } @res;
+ my $last;
+ my @a;
+ for ( @res ) {
+ push @a, $_ if ! $last || $last->{a} != $_->{a};
+ $last = $_;
+ }
+ $res->{list} = \@a;
+ }
+ else
+ {
+ $res = $self;
+ }
+
+ return $res if $count == $inf;
+ my $count_set = $self->empty_set();
+ if ( ! $self->is_too_complex )
+ {
+ my @a;
+ @a = grep { defined } @{ $res->{list} }[ 0 .. $count - 1 ] ;
+ $count_set->{list} = \@a;
+ }
+ else
+ {
+ my $last;
+ while ( $res ) {
+ ( $first, $res ) = $res->first;
+ last unless $first;
+ last if $last && $last->{a} == $first->{list}[0]{a};
+ $last = $first->{list}[0];
+ push @{$count_set->{list}}, $first->{list}[0];
+ $count--;
+ last if $count <= 0;
+ }
+ }
+ return $count_set;
+}
+
+BEGIN {
+
+ # %_first and %_last hashes are used to backtrack the value
+ # of first() and last() of an infinite set
+
+ %_first = (
+ 'complement' =>
+ sub {
+ my $self = $_[0];
+ my @parent_min = $self->{parent}->first;
+ unless ( defined $parent_min[0] ) {
+ return (undef, 0);
+ }
+ my $parent_complement;
+ my $first;
+ my @next;
+ my $parent;
+ if ( $parent_min[0]->min == $neg_inf ) {
+ my @parent_second = $parent_min[1]->first;
+ # (-inf..min) (second..?)
+ # (min..second) = complement
+ $first = $self->new( $parent_min[0]->complement );
+ $first->{list}[0]{b} = $parent_second[0]->{list}[0]{a};
+ $first->{list}[0]{open_end} = ! $parent_second[0]->{list}[0]{open_begin};
+ @{ $first->{list} } = () if
+ ( $first->{list}[0]{a} == $first->{list}[0]{b}) &&
+ ( $first->{list}[0]{open_begin} ||
+ $first->{list}[0]{open_end} );
+ @next = $parent_second[0]->max_a;
+ $parent = $parent_second[1];
+ }
+ else {
+ # (min..?)
+ # (-inf..min) = complement
+ $parent_complement = $parent_min[0]->complement;
+ $first = $self->new( $parent_complement->{list}[0] );
+ @next = $parent_min[0]->max_a;
+ $parent = $parent_min[1];
+ }
+ my @no_tail = $self->new($neg_inf,$next[0]);
+ $no_tail[0]->{list}[0]{open_end} = $next[1];
+ my $tail = $parent->union($no_tail[0])->complement;
+ return ($first, $tail);
+ }, # end: first-complement
+ 'intersection' =>
+ sub {
+ my $self = $_[0];
+ my @parent = @{ $self->{parent} };
+ # warn "$method parents @parent";
+ my $retry_count = 0;
+ my (@first, @min, $which, $first1, $intersection);
+ SEARCH: while ($retry_count++ < $max_intersection_depth) {
+ return undef unless defined $parent[0];
+ return undef unless defined $parent[1];
+ @{$first[0]} = $parent[0]->first;
+ @{$first[1]} = $parent[1]->first;
+ unless ( defined $first[0][0] ) {
+ # warn "don't know first of $method";
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ unless ( defined $first[1][0] ) {
+ # warn "don't know first of $method";
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ @{$min[0]} = $first[0][0]->min_a;
+ @{$min[1]} = $first[1][0]->min_a;
+ unless ( defined $min[0][0] && defined $min[1][0] ) {
+ return undef;
+ }
+ # $which is the index to the bigger "first".
+ $which = ($min[0][0] < $min[1][0]) ? 1 : 0;
+ for my $which1 ( $which, 1 - $which ) {
+ my $tmp_parent = $parent[$which1];
+ ($first1, $parent[$which1]) = @{ $first[$which1] };
+ if ( $first1->is_empty ) {
+ # warn "first1 empty! count $retry_count";
+ # trace_close;
+ # return $first1, undef;
+ $intersection = $first1;
+ $which = $which1;
+ last SEARCH;
+ }
+ $intersection = $first1->intersection( $parent[1-$which1] );
+ # warn "intersection with $first1 is $intersection";
+ unless ( $intersection->is_null ) {
+ # $self->trace( title=>"got an intersection" );
+ if ( $intersection->is_too_complex ) {
+ $parent[$which1] = $tmp_parent;
+ }
+ else {
+ $which = $which1;
+ last SEARCH;
+ }
+ };
+ }
+ }
+ if ( $#{ $intersection->{list} } > 0 ) {
+ my $tail;
+ ($intersection, $tail) = $intersection->first;
+ $parent[$which] = $parent[$which]->union( $tail );
+ }
+ my $tmp;
+ if ( defined $parent[$which] and defined $parent[1-$which] ) {
+ $tmp = $parent[$which]->intersection ( $parent[1-$which] );
+ }
+ return ($intersection, $tmp);
+ }, # end: first-intersection
+ 'union' =>
+ sub {
+ my $self = $_[0];
+ my (@first, @min);
+ my @parent = @{ $self->{parent} };
+ @{$first[0]} = $parent[0]->first;
+ @{$first[1]} = $parent[1]->first;
+ unless ( defined $first[0][0] ) {
+ # looks like one set was empty
+ return @{$first[1]};
+ }
+ @{$min[0]} = $first[0][0]->min_a;
+ @{$min[1]} = $first[1][0]->min_a;
+
+ # check min1/min2 for undef
+ unless ( defined $min[0][0] ) {
+ $self->trace_close( arg => "@{$first[1]}" ) if $TRACE;
+ return @{$first[1]}
+ }
+ unless ( defined $min[1][0] ) {
+ $self->trace_close( arg => "@{$first[0]}" ) if $TRACE;
+ return @{$first[0]}
+ }
+
+ my $which = ($min[0][0] < $min[1][0]) ? 0 : 1;
+ my $first = $first[$which][0];
+
+ # find out the tail
+ my $parent1 = $first[$which][1];
+ # warn $self->{parent}[$which]." - $first = $parent1";
+ my $parent2 = ($min[0][0] == $min[1][0]) ?
+ $self->{parent}[1-$which]->complement($first) :
+ $self->{parent}[1-$which];
+ my $tail;
+ if (( ! defined $parent1 ) || $parent1->is_null) {
+ # warn "union parent1 tail is null";
+ $tail = $parent2;
+ }
+ else {
+ my $method = $self->{method};
+ $tail = $parent1->$method( $parent2 );
+ }
+
+ if ( $first->intersects( $tail ) ) {
+ my $first2;
+ ( $first2, $tail ) = $tail->first;
+ $first = $first->union( $first2 );
+ }
+
+ $self->trace_close( arg => "$first $tail" ) if $TRACE;
+ return ($first, $tail);
+ }, # end: first-union
+ 'iterate' =>
+ sub {
+ my $self = $_[0];
+ my $parent = $self->{parent};
+ my ($first, $tail) = $parent->first;
+ $first = $first->iterate( @{$self->{param}} ) if ref($first);
+ $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
+ my $more;
+ ($first, $more) = $first->first if ref($first);
+ $tail = $tail->_function2( 'union', $more ) if defined $more;
+ return ($first, $tail);
+ },
+ 'until' =>
+ sub {
+ my $self = $_[0];
+ my ($a1, $b1) = @{ $self->{parent} };
+ $a1->trace( title=>"computing first()" );
+ my @first1 = $a1->first;
+ my @first2 = $b1->first;
+ my ($first, $tail);
+ if ( $first2[0] <= $first1[0] ) {
+ # added ->first because it returns 2 spans if $a1 == $a2
+ $first = $a1->empty_set()->until( $first2[0] )->first;
+ $tail = $a1->_function2( "until", $first2[1] );
+ }
+ else {
+ $first = $a1->new( $first1[0] )->until( $first2[0] );
+ if ( defined $first1[1] ) {
+ $tail = $first1[1]->_function2( "until", $first2[1] );
+ }
+ else {
+ $tail = undef;
+ }
+ }
+ return ($first, $tail);
+ },
+ 'offset' =>
+ sub {
+ my $self = $_[0];
+ my ($first, $tail) = $self->{parent}->first;
+ $first = $first->offset( @{$self->{param}} );
+ $tail = $tail->_function( 'offset', @{$self->{param}} );
+ my $more;
+ ($first, $more) = $first->first;
+ $tail = $tail->_function2( 'union', $more ) if defined $more;
+ return ($first, $tail);
+ },
+ 'quantize' =>
+ sub {
+ my $self = $_[0];
+ my @min = $self->{parent}->min_a;
+ if ( $min[0] == $neg_inf || $min[0] == $inf ) {
+ return ( $self->new( $min[0] ) , $self->copy );
+ }
+ my $first = $self->new( $min[0] )->quantize( @{$self->{param}} );
+ return ( $first,
+ $self->{parent}->
+ _function2( 'intersection', $first->complement )->
+ _function( 'quantize', @{$self->{param}} ) );
+ },
+ 'tolerance' =>
+ sub {
+ my $self = $_[0];
+ my ($first, $tail) = $self->{parent}->first;
+ $first = $first->tolerance( @{$self->{param}} );
+ $tail = $tail->tolerance( @{$self->{param}} );
+ return ($first, $tail);
+ },
+ ); # %_first
+
+ %_last = (
+ 'complement' =>
+ sub {
+ my $self = $_[0];
+ my @parent_max = $self->{parent}->last;
+ unless ( defined $parent_max[0] ) {
+ return (undef, 0);
+ }
+ my $parent_complement;
+ my $last;
+ my @next;
+ my $parent;
+ if ( $parent_max[0]->max == $inf ) {
+ # (inf..min) (second..?) = parent
+ # (min..second) = complement
+ my @parent_second = $parent_max[1]->last;
+ $last = $self->new( $parent_max[0]->complement );
+ $last->{list}[0]{a} = $parent_second[0]->{list}[0]{b};
+ $last->{list}[0]{open_begin} = ! $parent_second[0]->{list}[0]{open_end};
+ @{ $last->{list} } = () if
+ ( $last->{list}[0]{a} == $last->{list}[0]{b}) &&
+ ( $last->{list}[0]{open_end} ||
+ $last->{list}[0]{open_begin} );
+ @next = $parent_second[0]->min_a;
+ $parent = $parent_second[1];
+ }
+ else {
+ # (min..?)
+ # (-inf..min) = complement
+ $parent_complement = $parent_max[0]->complement;
+ $last = $self->new( $parent_complement->{list}[-1] );
+ @next = $parent_max[0]->min_a;
+ $parent = $parent_max[1];
+ }
+ my @no_tail = $self->new($next[0], $inf);
+ $no_tail[0]->{list}[-1]{open_begin} = $next[1];
+ my $tail = $parent->union($no_tail[-1])->complement;
+ return ($last, $tail);
+ },
+ 'intersection' =>
+ sub {
+ my $self = $_[0];
+ my @parent = @{ $self->{parent} };
+ # TODO: check max1/max2 for undef
+
+ my $retry_count = 0;
+ my (@last, @max, $which, $last1, $intersection);
+
+ SEARCH: while ($retry_count++ < $max_intersection_depth) {
+ return undef unless defined $parent[0];
+ return undef unless defined $parent[1];
+
+ @{$last[0]} = $parent[0]->last;
+ @{$last[1]} = $parent[1]->last;
+ unless ( defined $last[0][0] ) {
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ unless ( defined $last[1][0] ) {
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ @{$max[0]} = $last[0][0]->max_a;
+ @{$max[1]} = $last[1][0]->max_a;
+ unless ( defined $max[0][0] && defined $max[1][0] ) {
+ $self->trace( title=>"can't find max()" ) if $TRACE;
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+
+ # $which is the index to the smaller "last".
+ $which = ($max[0][0] > $max[1][0]) ? 1 : 0;
+
+ for my $which1 ( $which, 1 - $which ) {
+ my $tmp_parent = $parent[$which1];
+ ($last1, $parent[$which1]) = @{ $last[$which1] };
+ if ( $last1->is_null ) {
+ $which = $which1;
+ $intersection = $last1;
+ last SEARCH;
+ }
+ $intersection = $last1->intersection( $parent[1-$which1] );
+
+ unless ( $intersection->is_null ) {
+ # $self->trace( title=>"got an intersection" );
+ if ( $intersection->is_too_complex ) {
+ $self->trace( title=>"got a too_complex intersection" ) if $TRACE;
+ # warn "too complex intersection";
+ $parent[$which1] = $tmp_parent;
+ }
+ else {
+ $self->trace( title=>"got an intersection" ) if $TRACE;
+ $which = $which1;
+ last SEARCH;
+ }
+ };
+ }
+ }
+ $self->trace( title=>"exit loop" ) if $TRACE;
+ if ( $#{ $intersection->{list} } > 0 ) {
+ my $tail;
+ ($intersection, $tail) = $intersection->last;
+ $parent[$which] = $parent[$which]->union( $tail );
+ }
+ my $tmp;
+ if ( defined $parent[$which] and defined $parent[1-$which] ) {
+ $tmp = $parent[$which]->intersection ( $parent[1-$which] );
+ }
+ return ($intersection, $tmp);
+ },
+ 'union' =>
+ sub {
+ my $self = $_[0];
+ my (@last, @max);
+ my @parent = @{ $self->{parent} };
+ @{$last[0]} = $parent[0]->last;
+ @{$last[1]} = $parent[1]->last;
+ @{$max[0]} = $last[0][0]->max_a;
+ @{$max[1]} = $last[1][0]->max_a;
+ unless ( defined $max[0][0] ) {
+ return @{$last[1]}
+ }
+ unless ( defined $max[1][0] ) {
+ return @{$last[0]}
+ }
+
+ my $which = ($max[0][0] > $max[1][0]) ? 0 : 1;
+ my $last = $last[$which][0];
+ # find out the tail
+ my $parent1 = $last[$which][1];
+ # warn $self->{parent}[$which]." - $last = $parent1";
+ my $parent2 = ($max[0][0] == $max[1][0]) ?
+ $self->{parent}[1-$which]->complement($last) :
+ $self->{parent}[1-$which];
+ my $tail;
+ if (( ! defined $parent1 ) || $parent1->is_null) {
+ $tail = $parent2;
+ }
+ else {
+ my $method = $self->{method};
+ $tail = $parent1->$method( $parent2 );
+ }
+
+ if ( $last->intersects( $tail ) ) {
+ my $last2;
+ ( $last2, $tail ) = $tail->last;
+ $last = $last->union( $last2 );
+ }
+
+ return ($last, $tail);
+ },
+ 'until' =>
+ sub {
+ my $self = $_[0];
+ my ($a1, $b1) = @{ $self->{parent} };
+ $a1->trace( title=>"computing last()" );
+ my @last1 = $a1->last;
+ my @last2 = $b1->last;
+ my ($last, $tail);
+ if ( $last2[0] <= $last1[0] ) {
+ # added ->last because it returns 2 spans if $a1 == $a2
+ $last = $last2[0]->until( $a1 )->last;
+ $tail = $a1->_function2( "until", $last2[1] );
+ }
+ else {
+ $last = $a1->new( $last1[0] )->until( $last2[0] );
+ if ( defined $last1[1] ) {
+ $tail = $last1[1]->_function2( "until", $last2[1] );
+ }
+ else {
+ $tail = undef;
+ }
+ }
+ return ($last, $tail);
+ },
+ 'iterate' =>
+ sub {
+ my $self = $_[0];
+ my $parent = $self->{parent};
+ my ($last, $tail) = $parent->last;
+ $last = $last->iterate( @{$self->{param}} ) if ref($last);
+ $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
+ my $more;
+ ($last, $more) = $last->last if ref($last);
+ $tail = $tail->_function2( 'union', $more ) if defined $more;
+ return ($last, $tail);
+ },
+ 'offset' =>
+ sub {
+ my $self = $_[0];
+ my ($last, $tail) = $self->{parent}->last;
+ $last = $last->offset( @{$self->{param}} );
+ $tail = $tail->_function( 'offset', @{$self->{param}} );
+ my $more;
+ ($last, $more) = $last->last;
+ $tail = $tail->_function2( 'union', $more ) if defined $more;
+ return ($last, $tail);
+ },
+ 'quantize' =>
+ sub {
+ my $self = $_[0];
+ my @max = $self->{parent}->max_a;
+ if (( $max[0] == $neg_inf ) || ( $max[0] == $inf )) {
+ return ( $self->new( $max[0] ) , $self->copy );
+ }
+ my $last = $self->new( $max[0] )->quantize( @{$self->{param}} );
+ if ($max[1]) { # open_end
+ if ( $last->min <= $max[0] ) {
+ $last = $self->new( $last->min - 1e-9 )->quantize( @{$self->{param}} );
+ }
+ }
+ return ( $last, $self->{parent}->
+ _function2( 'intersection', $last->complement )->
+ _function( 'quantize', @{$self->{param}} ) );
+ },
+ 'tolerance' =>
+ sub {
+ my $self = $_[0];
+ my ($last, $tail) = $self->{parent}->last;
+ $last = $last->tolerance( @{$self->{param}} );
+ $tail = $tail->tolerance( @{$self->{param}} );
+ return ($last, $tail);
+ },
+ ); # %_last
+} # BEGIN
+
+sub first {
+ my $self = $_[0];
+ unless ( exists $self->{first} ) {
+ $self->trace_open(title=>"first") if $TRACE;
+ if ( $self->{too_complex} ) {
+ my $method = $self->{method};
+ # warn "method $method ". ( exists $_first{$method} ? "exists" : "does not exist" );
+ if ( exists $_first{$method} ) {
+ @{$self->{first}} = $_first{$method}->($self);
+ }
+ else {
+ my $redo = $self->{parent}->$method ( @{ $self->{param} } );
+ @{$self->{first}} = $redo->first;
+ }
+ }
+ else {
+ return $self->SUPER::first;
+ }
+ }
+ return wantarray ? @{$self->{first}} : $self->{first}[0];
+}
+
+
+sub last {
+ my $self = $_[0];
+ unless ( exists $self->{last} ) {
+ $self->trace(title=>"last") if $TRACE;
+ if ( $self->{too_complex} ) {
+ my $method = $self->{method};
+ if ( exists $_last{$method} ) {
+ @{$self->{last}} = $_last{$method}->($self);
+ }
+ else {
+ my $redo = $self->{parent}->$method ( @{ $self->{param} } );
+ @{$self->{last}} = $redo->last;
+ }
+ }
+ else {
+ return $self->SUPER::last;
+ }
+ }
+ return wantarray ? @{$self->{last}} : $self->{last}[0];
+}
+
+
+# offset: offsets subsets
+sub offset {
+ my $self = shift;
+ if ($self->{too_complex}) {
+ return $self->_function( 'offset', @_ );
+ }
+ $self->trace_open(title=>"offset") if $TRACE;
+
+ my @a;
+ my %param = @_;
+ my $b1 = $self->empty_set();
+ my ($interval, $ia, $i);
+ $param{mode} = 'offset' unless $param{mode};
+
+ unless (ref($param{value}) eq 'ARRAY') {
+ $param{value} = [0 + $param{value}, 0 + $param{value}];
+ }
+ $param{unit} = 'one' unless $param{unit};
+ my $parts = ($#{$param{value}}) / 2;
+ my $sub_unit = $Set::Infinite::Arithmetic::subs_offset2{$param{unit}};
+ my $sub_mode = $Set::Infinite::Arithmetic::_MODE{$param{mode}};
+
+ carp "unknown unit $param{unit} for offset()" unless defined $sub_unit;
+ carp "unknown mode $param{mode} for offset()" unless defined $sub_mode;
+
+ my ($j);
+ my ($cmp, $this, $next, $ib, $part, $open_begin, $open_end, $tmp);
+
+ my @value;
+ foreach $j (0 .. $parts) {
+ push @value, [ $param{value}[$j+$j], $param{value}[$j+$j + 1] ];
+ }
+
+ foreach $interval ( @{ $self->{list} } ) {
+ $ia = $interval->{a};
+ $ib = $interval->{b};
+ $open_begin = $interval->{open_begin};
+ $open_end = $interval->{open_end};
+ foreach $j (0 .. $parts) {
+ # print " [ofs($ia,$ib)] ";
+ ($this, $next) = $sub_mode->( $sub_unit, $ia, $ib, @{$value[$j]} );
+ next if ($this > $next); # skip if a > b
+ if ($this == $next) {
+ # TODO: fix this
+ $open_end = $open_begin;
+ }
+ push @a, { a => $this , b => $next ,
+ open_begin => $open_begin , open_end => $open_end };
+ } # parts
+ } # self
+ @a = sort { $a->{a} <=> $b->{a} } @a;
+ $b1->{list} = \@a; # change data
+ $self->trace_close( arg => $b1 ) if $TRACE;
+ $b1 = $b1->fixtype if $self->{fixtype};
+ return $b1;
+}
+
+
+sub is_null {
+ $_[0]->{too_complex} ? 0 : $_[0]->SUPER::is_null;
+}
+
+
+sub is_too_complex {
+ $_[0]->{too_complex} ? 1 : 0;
+}
+
+
+# shows how a 'compacted' set looks like after quantize
+sub _quantize_span {
+ my $self = shift;
+ my %param = @_;
+ $self->trace_open(title=>"_quantize_span") if $TRACE;
+ my $res;
+ if ($self->{too_complex}) {
+ $res = $self->{parent};
+ if ($self->{method} ne 'quantize') {
+ $self->trace( title => "parent is a ". $self->{method} );
+ if ( $self->{method} eq 'union' ) {
+ my $arg0 = $self->{parent}[0]->_quantize_span(%param);
+ my $arg1 = $self->{parent}[1]->_quantize_span(%param);
+ $res = $arg0->union( $arg1 );
+ }
+ elsif ( $self->{method} eq 'intersection' ) {
+ my $arg0 = $self->{parent}[0]->_quantize_span(%param);
+ my $arg1 = $self->{parent}[1]->_quantize_span(%param);
+ $res = $arg0->intersection( $arg1 );
+ }
+
+ # TODO: other methods
+ else {
+ $res = $self; # ->_function( "_quantize_span", %param );
+ }
+ $self->trace_close( arg => $res ) if $TRACE;
+ return $res;
+ }
+
+ # $res = $self->{parent};
+ if ($res->{too_complex}) {
+ $res->trace( title => "parent is complex" );
+ $res = $res->_quantize_span( %param );
+ $res = $res->quantize( @{$self->{param}} )->_quantize_span( %param );
+ }
+ else {
+ $res = $res->iterate (
+ sub {
+ $_[0]->quantize( @{$self->{param}} )->span;
+ }
+ );
+ }
+ }
+ else {
+ $res = $self->iterate ( sub { $_[0] } );
+ }
+ $self->trace_close( arg => $res ) if $TRACE;
+ return $res;
+}
+
+
+
+BEGIN {
+
+ %_backtrack = (
+
+ until => sub {
+ my ($self, $arg) = @_;
+ my $before = $self->{parent}[0]->intersection( $neg_inf, $arg->min )->max;
+ $before = $arg->min unless $before;
+ my $after = $self->{parent}[1]->intersection( $arg->max, $inf )->min;
+ $after = $arg->max unless $after;
+ return $arg->new( $before, $after );
+ },
+
+ iterate => sub {
+ my ($self, $arg) = @_;
+
+ if ( defined $self->{backtrack_callback} )
+ {
+ return $arg = $self->new( $self->{backtrack_callback}->( $arg ) );
+ }
+
+ my $before = $self->{parent}->intersection( $neg_inf, $arg->min )->max;
+ $before = $arg->min unless $before;
+ my $after = $self->{parent}->intersection( $arg->max, $inf )->min;
+ $after = $arg->max unless $after;
+
+ return $arg->new( $before, $after );
+ },
+
+ quantize => sub {
+ my ($self, $arg) = @_;
+ if ($arg->{too_complex}) {
+ return $arg;
+ }
+ else {
+ return $arg->quantize( @{$self->{param}} )->_quantize_span;
+ }
+ },
+
+ offset => sub {
+ my ($self, $arg) = @_;
+ # offset - apply offset with negative values
+ my %tmp = @{$self->{param}};
+ my @values = sort @{$tmp{value}};
+
+ my $backtrack_arg2 = $arg->offset(
+ unit => $tmp{unit},
+ mode => $tmp{mode},
+ value => [ - $values[-1], - $values[0] ] );
+ return $arg->union( $backtrack_arg2 ); # fixes some problems with 'begin' mode
+ },
+
+ );
+}
+
+
+sub _backtrack {
+ my ($self, $method, $arg) = @_;
+ return $self->$method ($arg) unless $self->{too_complex};
+
+ $self->trace_open( title => 'backtrack '.$self->{method} ) if $TRACE;
+
+ $backtrack_depth++;
+ if ( $backtrack_depth > $max_backtrack_depth ) {
+ carp ( __PACKAGE__ . ": Backtrack too deep " .
+ "(more than $max_backtrack_depth levels)" );
+ }
+
+ if (exists $_backtrack{ $self->{method} } ) {
+ $arg = $_backtrack{ $self->{method} }->( $self, $arg );
+ }
+
+ my $result;
+ if ( ref($self->{parent}) eq 'ARRAY' ) {
+ # has 2 parents (intersection, union, until)
+
+ my ( $result1, $result2 ) = @{$self->{parent}};
+ $result1 = $result1->_backtrack( $method, $arg )
+ if $result1->{too_complex};
+ $result2 = $result2->_backtrack( $method, $arg )
+ if $result2->{too_complex};
+
+ $method = $self->{method};
+ if ( $result1->{too_complex} || $result2->{too_complex} ) {
+ $result = $result1->_function2( $method, $result2 );
+ }
+ else {
+ $result = $result1->$method ($result2);
+ }
+ }
+ else {
+ # has 1 parent and parameters (offset, select, quantize, iterate)
+
+ $result = $self->{parent}->_backtrack( $method, $arg );
+ $method = $self->{method};
+ $result = $result->$method ( @{$self->{param}} );
+ }
+
+ $backtrack_depth--;
+ $self->trace_close( arg => $result ) if $TRACE;
+ return $result;
+}
+
+
+sub intersects {
+ my $a1 = shift;
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ $a1->trace(title=>"intersects");
+ if ($a1->{too_complex}) {
+ $a1 = $a1->_backtrack('intersection', $b1 );
+ } # don't put 'else' here
+ if ($b1->{too_complex}) {
+ $b1 = $b1->_backtrack('intersection', $a1);
+ }
+ if (($a1->{too_complex}) or ($b1->{too_complex})) {
+ return undef; # we don't know the answer!
+ }
+ return $a1->SUPER::intersects( $b1 );
+}
+
+
+sub iterate {
+ my $self = shift;
+ my $callback = shift;
+ die "First argument to iterate() must be a subroutine reference"
+ unless ref( $callback ) eq 'CODE';
+ my $backtrack_callback;
+ if ( @_ && $_[0] eq 'backtrack_callback' )
+ {
+ ( undef, $backtrack_callback ) = ( shift, shift );
+ }
+ my $set;
+ if ($self->{too_complex}) {
+ $self->trace(title=>"iterate:backtrack") if $TRACE;
+ $set = $self->_function( 'iterate', $callback, @_ );
+ }
+ else
+ {
+ $self->trace(title=>"iterate") if $TRACE;
+ $set = $self->SUPER::iterate( $callback, @_ );
+ }
+ $set->{backtrack_callback} = $backtrack_callback;
+ # warn "set backtrack_callback" if defined $backtrack_callback;
+ return $set;
+}
+
+
+sub intersection {
+ my $a1 = shift;
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ $a1->trace_open(title=>"intersection", arg => $b1) if $TRACE;
+ if (($a1->{too_complex}) or ($b1->{too_complex})) {
+ my $arg0 = $a1->_quantize_span;
+ my $arg1 = $b1->_quantize_span;
+ unless (($arg0->{too_complex}) or ($arg1->{too_complex})) {
+ my $res = $arg0->intersection( $arg1 );
+ $a1->trace_close( arg => $res ) if $TRACE;
+ return $res;
+ }
+ }
+ if ($a1->{too_complex}) {
+ $a1 = $a1->_backtrack('intersection', $b1) unless $b1->{too_complex};
+ } # don't put 'else' here
+ if ($b1->{too_complex}) {
+ $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
+ }
+ if ( $a1->{too_complex} || $b1->{too_complex} ) {
+ $a1->trace_close( ) if $TRACE;
+ return $a1->_function2( 'intersection', $b1 );
+ }
+ return $a1->SUPER::intersection( $b1 );
+}
+
+
+sub intersected_spans {
+ my $a1 = shift;
+ my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
+
+ if ($a1->{too_complex}) {
+ $a1 = $a1->_backtrack('intersection', $b1 ) unless $b1->{too_complex};
+ } # don't put 'else' here
+ if ($b1->{too_complex}) {
+ $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
+ }
+
+ if ( ! $b1->{too_complex} && ! $a1->{too_complex} )
+ {
+ return $a1->SUPER::intersected_spans ( $b1 );
+ }
+
+ return $b1->iterate(
+ sub {
+ my $tmp = $a1->intersection( $_[0] );
+ return $tmp unless defined $tmp->max;
+
+ my $before = $a1->intersection( $neg_inf, $tmp->min )->last;
+ my $after = $a1->intersection( $tmp->max, $inf )->first;
+
+ $before = $tmp->union( $before )->first;
+ $after = $tmp->union( $after )->last;
+
+ $tmp = $tmp->union( $before )
+ if defined $before && $tmp->intersects( $before );
+ $tmp = $tmp->union( $after )
+ if defined $after && $tmp->intersects( $after );
+ return $tmp;
+ }
+ );
+
+}
+
+
+sub complement {
+ my $a1 = shift;
+ # do we have a parameter?
+ if (@_) {
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ $a1->trace_open(title=>"complement", arg => $b1) if $TRACE;
+ $b1 = $b1->complement;
+ my $tmp =$a1->intersection($b1);
+ $a1->trace_close( arg => $tmp ) if $TRACE;
+ return $tmp;
+ }
+ $a1->trace_open(title=>"complement") if $TRACE;
+ if ($a1->{too_complex}) {
+ $a1->trace_close( ) if $TRACE;
+ return $a1->_function( 'complement', @_ );
+ }
+ return $a1->SUPER::complement;
+}
+
+
+sub until {
+ my $a1 = shift;
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ if (($a1->{too_complex}) or ($b1->{too_complex})) {
+ return $a1->_function2( 'until', $b1 );
+ }
+ return $a1->SUPER::until( $b1 );
+}
+
+
+sub union {
+ my $a1 = shift;
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ $a1->trace_open(title=>"union", arg => $b1) if $TRACE;
+ if (($a1->{too_complex}) or ($b1->{too_complex})) {
+ $a1->trace_close( ) if $TRACE;
+ return $a1 if $b1->is_null;
+ return $b1 if $a1->is_null;
+ return $a1->_function2( 'union', $b1);
+ }
+ return $a1->SUPER::union( $b1 );
+}
+
+
+# there are some ways to process 'contains':
+# A CONTAINS B IF A == ( A UNION B )
+# - faster
+# A CONTAINS B IF B == ( A INTERSECTION B )
+# - can backtrack = works for unbounded sets
+sub contains {
+ my $a1 = shift;
+ $a1->trace_open(title=>"contains") if $TRACE;
+ if ( $a1->{too_complex} ) {
+ # we use intersection because it is better for backtracking
+ my $b0 = (ref $_[0] eq ref $a1) ? shift : $a1->new(@_);
+ my $b1 = $a1->intersection($b0);
+ if ( $b1->{too_complex} ) {
+ $b1->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ $a1->trace_close( arg => ($b1 == $b0 ? 1 : 0) ) if $TRACE;
+ return ($b1 == $b0) ? 1 : 0;
+ }
+ my $b1 = $a1->union(@_);
+ if ( $b1->{too_complex} ) {
+ $b1->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ $a1->trace_close( arg => ($b1 == $a1 ? 1 : 0) ) if $TRACE;
+ return ($b1 == $a1) ? 1 : 0;
+}
+
+
+sub min_a {
+ my $self = $_[0];
+ return @{$self->{min}} if exists $self->{min};
+ if ($self->{too_complex}) {
+ my @first = $self->first;
+ return @{$self->{min}} = $first[0]->min_a if defined $first[0];
+ return @{$self->{min}} = (undef, 0);
+ }
+ return $self->SUPER::min_a;
+};
+
+
+sub max_a {
+ my $self = $_[0];
+ return @{$self->{max}} if exists $self->{max};
+ if ($self->{too_complex}) {
+ my @last = $self->last;
+ return @{$self->{max}} = $last[0]->max_a if defined $last[0];
+ return @{$self->{max}} = (undef, 0);
+ }
+ return $self->SUPER::max_a;
+};
+
+
+sub count {
+ my $self = $_[0];
+ # NOTE: subclasses may return "undef" if necessary
+ return $inf if $self->{too_complex};
+ return $self->SUPER::count;
+}
+
+
+sub size {
+ my $self = $_[0];
+ if ($self->{too_complex}) {
+ my @min = $self->min_a;
+ my @max = $self->max_a;
+ return undef unless defined $max[0] && defined $min[0];
+ return $max[0] - $min[0];
+ }
+ return $self->SUPER::size;
+};
+
+
+sub spaceship {
+ my ($tmp1, $tmp2, $inverted) = @_;
+ carp "Can't compare unbounded sets"
+ if $tmp1->{too_complex} or $tmp2->{too_complex};
+ return $tmp1->SUPER::spaceship( $tmp2, $inverted );
+}
+
+
+sub _cleanup { @_ } # this subroutine is obsolete
+
+
+sub tolerance {
+ my $self = shift;
+ my $tmp = pop;
+ if (ref($self)) {
+ # local
+ return $self->{tolerance} unless defined $tmp;
+ if ($self->{too_complex}) {
+ my $b1 = $self->_function( 'tolerance', $tmp );
+ $b1->{tolerance} = $tmp; # for max/min processing
+ return $b1;
+ }
+ return $self->SUPER::tolerance( $tmp );
+ }
+ # class method
+ __PACKAGE__->SUPER::tolerance( $tmp ) if defined($tmp);
+ return __PACKAGE__->SUPER::tolerance;
+}
+
+
+sub _pretty_print {
+ my $self = shift;
+ return "$self" unless $self->{too_complex};
+ return $self->{method} . "( " .
+ ( ref($self->{parent}) eq 'ARRAY' ?
+ $self->{parent}[0] . ' ; ' . $self->{parent}[1] :
+ $self->{parent} ) .
+ " )";
+}
+
+
+sub as_string {
+ my $self = shift;
+ return ( $PRETTY_PRINT ? $self->_pretty_print : $too_complex )
+ if $self->{too_complex};
+ return $self->SUPER::as_string;
+}
+
+
+sub DESTROY {}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Set::Infinite - Sets of intervals
+
+
+=head1 SYNOPSIS
+
+ use Set::Infinite;
+
+ $set = Set::Infinite->new(1,2); # [1..2]
+ print $set->union(5,6); # [1..2],[5..6]
+
+
+=head1 DESCRIPTION
+
+Set::Infinite is a Set Theory module for infinite sets.
+
+A set is a collection of objects.
+The objects that belong to a set are called its members, or "elements".
+
+As objects we allow (almost) anything: reals, integers, and objects (such as dates).
+
+We allow sets to be infinite.
+
+There is no account for the order of elements. For example, {1,2} = {2,1}.
+
+There is no account for repetition of elements. For example, {1,2,2} = {1,1,1,2} = {1,2}.
+
+=head1 CONSTRUCTOR
+
+=head2 new
+
+Creates a new set object:
+
+ $set = Set::Infinite->new; # empty set
+ $set = Set::Infinite->new( 10 ); # single element
+ $set = Set::Infinite->new( 10, 20 ); # single range
+ $set = Set::Infinite->new(
+ [ 10, 20 ], [ 50, 70 ] ); # two ranges
+
+=over 4
+
+=item empty set
+
+ $set = Set::Infinite->new;
+
+=item set with a single element
+
+ $set = Set::Infinite->new( 10 );
+
+ $set = Set::Infinite->new( [ 10 ] );
+
+=item set with a single span
+
+ $set = Set::Infinite->new( 10, 20 );
+
+ $set = Set::Infinite->new( [ 10, 20 ] );
+ # 10 <= x <= 20
+
+=item set with a single, open span
+
+ $set = Set::Infinite->new(
+ {
+ a => 10, open_begin => 0,
+ b => 20, open_end => 1,
+ }
+ );
+ # 10 <= x < 20
+
+=item set with multiple spans
+
+ $set = Set::Infinite->new( 10, 20, 100, 200 );
+
+ $set = Set::Infinite->new( [ 10, 20 ], [ 100, 200 ] );
+
+ $set = Set::Infinite->new(
+ {
+ a => 10, open_begin => 0,
+ b => 20, open_end => 0,
+ },
+ {
+ a => 100, open_begin => 0,
+ b => 200, open_end => 0,
+ }
+ );
+
+=back
+
+The C<new()> method expects I<ordered> parameters.
+
+If you have unordered ranges, you can build the set using C<union>:
+
+ @ranges = ( [ 10, 20 ], [ -10, 1 ] );
+ $set = Set::Infinite->new;
+ $set = $set->union( @$_ ) for @ranges;
+
+The data structures passed to C<new> must be I<immutable>.
+So this is not good practice:
+
+ $set = Set::Infinite->new( $object_a, $object_b );
+ $object_a->set_value( 10 );
+
+This is the recommended way to do it:
+
+ $set = Set::Infinite->new( $object_a->clone, $object_b->clone );
+ $object_a->set_value( 10 );
+
+
+=head2 clone / copy
+
+Creates a new object, and copy the object data.
+
+=head2 empty_set
+
+Creates an empty set.
+
+If called from an existing set, the empty set inherits
+the "type" and "density" characteristics.
+
+=head2 universal_set
+
+Creates a set containing "all" possible elements.
+
+If called from an existing set, the universal set inherits
+the "type" and "density" characteristics.
+
+=head1 SET FUNCTIONS
+
+=head2 union
+
+ $set = $set->union($b);
+
+Returns the set of all elements from both sets.
+
+This function behaves like an "OR" operation.
+
+ $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
+ $set2 = new Set::Infinite( [ 7, 20 ] );
+ print $set1->union( $set2 );
+ # output: [1..4],[7..20]
+
+=head2 intersection
+
+ $set = $set->intersection($b);
+
+Returns the set of elements common to both sets.
+
+This function behaves like an "AND" operation.
+
+ $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
+ $set2 = new Set::Infinite( [ 7, 20 ] );
+ print $set1->intersection( $set2 );
+ # output: [8..12]
+
+=head2 complement
+
+=head2 minus
+
+=head2 difference
+
+ $set = $set->complement;
+
+Returns the set of all elements that don't belong to the set.
+
+ $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
+ print $set1->complement;
+ # output: (-inf..1),(4..8),(12..inf)
+
+The complement function might take a parameter:
+
+ $set = $set->minus($b);
+
+Returns the set-difference, that is, the elements that don't
+belong to the given set.
+
+ $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
+ $set2 = new Set::Infinite( [ 7, 20 ] );
+ print $set1->minus( $set2 );
+ # output: [1..4]
+
+=head2 symmetric_difference
+
+Returns a set containing elements that are in either set,
+but not in both. This is the "set" version of "XOR".
+
+=head1 DENSITY METHODS
+
+=head2 real
+
+ $set1 = $set->real;
+
+Returns a set with density "0".
+
+=head2 integer
+
+ $set1 = $set->integer;
+
+Returns a set with density "1".
+
+=head1 LOGIC FUNCTIONS
+
+=head2 intersects
+
+ $logic = $set->intersects($b);
+
+=head2 contains
+
+ $logic = $set->contains($b);
+
+=head2 is_empty
+
+=head2 is_null
+
+ $logic = $set->is_null;
+
+=head2 is_nonempty
+
+This set that has at least 1 element.
+
+=head2 is_span
+
+This set that has a single span or interval.
+
+=head2 is_singleton
+
+This set that has a single element.
+
+=head2 is_subset( $set )
+
+Every element of this set is a member of the given set.
+
+=head2 is_proper_subset( $set )
+
+Every element of this set is a member of the given set.
+Some members of the given set are not elements of this set.
+
+=head2 is_disjoint( $set )
+
+The given set has no elements in common with this set.
+
+=head2 is_too_complex
+
+Sometimes a set might be too complex to enumerate or print.
+
+This happens with sets that represent infinite recurrences, such as
+when you ask for a quantization on a
+set bounded by -inf or inf.
+
+See also: C<count> method.
+
+=head1 SCALAR FUNCTIONS
+
+=head2 min
+
+ $i = $set->min;
+
+=head2 max
+
+ $i = $set->max;
+
+=head2 size
+
+ $i = $set->size;
+
+=head2 count
+
+ $i = $set->count;
+
+=head1 OVERLOADED OPERATORS
+
+=head2 stringification
+
+ print $set;
+
+ $str = "$set";
+
+See also: C<as_string>.
+
+=head2 comparison
+
+ sort
+
+ > < == >= <= <=>
+
+See also: C<spaceship> method.
+
+=head1 CLASS METHODS
+
+ Set::Infinite->separators(@i)
+
+ chooses the interval separators for stringification.
+
+ default are [ ] ( ) '..' ','.
+
+ inf
+
+ returns an 'Infinity' number.
+
+ minus_inf
+
+ returns '-Infinity' number.
+
+=head2 type
+
+ type( "My::Class::Name" )
+
+Chooses a default object data type.
+
+Default is none (a normal Perl SCALAR).
+
+
+=head1 SPECIAL SET FUNCTIONS
+
+=head2 span
+
+ $set1 = $set->span;
+
+Returns the set span.
+
+=head2 until
+
+Extends a set until another:
+
+ 0,5,7 -> until 2,6,10
+
+gives
+
+ [0..2), [5..6), [7..10)
+
+=head2 start_set
+
+=head2 end_set
+
+These methods do the inverse of the "until" method.
+
+Given:
+
+ [0..2), [5..6), [7..10)
+
+start_set is:
+
+ 0,5,7
+
+end_set is:
+
+ 2,6,10
+
+=head2 intersected_spans
+
+ $set = $set1->intersected_spans( $set2 );
+
+The method returns a new set,
+containing all spans that are intersected by the given set.
+
+Unlike the C<intersection> method, the spans are not modified.
+See diagram below:
+
+ set1 [....] [....] [....] [....]
+ set2 [................]
+
+ intersection [.] [....] [.]
+
+ intersected_spans [....] [....] [....]
+
+
+=head2 quantize
+
+ quantize( parameters )
+
+ Makes equal-sized subsets.
+
+ Returns an ordered set of equal-sized subsets.
+
+ Example:
+
+ $set = Set::Infinite->new([1,3]);
+ print join (" ", $set->quantize( quant => 1 ) );
+
+ Gives:
+
+ [1..2) [2..3) [3..4)
+
+=head2 select
+
+ select( parameters )
+
+Selects set spans based on their ordered positions
+
+C<select> has a behaviour similar to an array C<slice>.
+
+ by - default=All
+ count - default=Infinity
+
+ 0 1 2 3 4 5 6 7 8 # original set
+ 0 1 2 # count => 3
+ 1 6 # by => [ -2, 1 ]
+
+=head2 offset
+
+ offset ( parameters )
+
+Offsets the subsets. Parameters:
+
+ value - default=[0,0]
+ mode - default='offset'. Possible values are: 'offset', 'begin', 'end'.
+ unit - type of value. Can be 'days', 'weeks', 'hours', 'minutes', 'seconds'.
+
+=head2 iterate
+
+ iterate ( sub { } , @args )
+
+Iterates on the set spans, over a callback subroutine.
+Returns the union of all partial results.
+
+The callback argument C<$_[0]> is a span. If there are additional arguments they are passed to the callback.
+
+The callback can return a span, a hashref (see C<Set::Infinite::Basic>), a scalar, an object, or C<undef>.
+
+[EXPERIMENTAL]
+C<iterate> accepts an optional C<backtrack_callback> argument.
+The purpose of the C<backtrack_callback> is to I<reverse> the
+iterate() function, overcoming the limitations of the internal
+backtracking algorithm.
+The syntax is:
+
+ iterate ( sub { } , backtrack_callback => sub { }, @args )
+
+The C<backtrack_callback> can return a span, a hashref, a scalar,
+an object, or C<undef>.
+
+For example, the following snippet adds a constant to each
+element of an unbounded set:
+
+ $set1 = $set->iterate(
+ sub { $_[0]->min + 54, $_[0]->max + 54 },
+ backtrack_callback =>
+ sub { $_[0]->min - 54, $_[0]->max - 54 },
+ );
+
+=head2 first / last
+
+ first / last
+
+In scalar context returns the first or last interval of a set.
+
+In list context returns the first or last interval of a set,
+and the remaining set (the 'tail').
+
+See also: C<min>, C<max>, C<min_a>, C<max_a> methods.
+
+=head2 type
+
+ type( "My::Class::Name" )
+
+Chooses a default object data type.
+
+default is none (a normal perl SCALAR).
+
+
+=head1 INTERNAL FUNCTIONS
+
+=head2 _backtrack
+
+ $set->_backtrack( 'intersection', $b );
+
+Internal function to evaluate recurrences.
+
+=head2 numeric
+
+ $set->numeric;
+
+Internal function to ignore the set "type".
+It is used in some internal optimizations, when it is
+possible to use scalar values instead of objects.
+
+=head2 fixtype
+
+ $set->fixtype;
+
+Internal function to fix the result of operations
+that use the numeric() function.
+
+=head2 tolerance
+
+ $set = $set->tolerance(0) # defaults to real sets (default)
+ $set = $set->tolerance(1) # defaults to integer sets
+
+Internal function for changing the set "density".
+
+=head2 min_a
+
+ ($min, $min_is_open) = $set->min_a;
+
+=head2 max_a
+
+ ($max, $max_is_open) = $set->max_a;
+
+
+=head2 as_string
+
+Implements the "stringification" operator.
+
+Stringification of unbounded recurrences is not implemented.
+
+Unbounded recurrences are stringified as "function descriptions",
+if the class variable $PRETTY_PRINT is set.
+
+=head2 spaceship
+
+Implements the "comparison" operator.
+
+Comparison of unbounded recurrences is not implemented.
+
+
+=head1 CAVEATS
+
+=over 4
+
+=item * constructor "span" notation
+
+ $set = Set::Infinite->new(10,1);
+
+Will be interpreted as [1..10]
+
+=item * constructor "multiple-span" notation
+
+ $set = Set::Infinite->new(1,2,3,4);
+
+Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
+You probably want ->new([1],[2],[3],[4]) instead,
+or maybe ->new(1,4)
+
+=item * "range operator"
+
+ $set = Set::Infinite->new(1..3);
+
+Will be interpreted as [1..2],3 instead of [1,2,3].
+You probably want ->new(1,3) instead.
+
+=back
+
+=head1 INTERNALS
+
+The base I<set> object, without recurrences, is a C<Set::Infinite::Basic>.
+
+A I<recurrence-set> is represented by a I<method name>,
+one or two I<parent objects>, and extra arguments.
+The C<list> key is set to an empty array, and the
+C<too_complex> key is set to C<1>.
+
+This is a structure that holds the union of two "complex sets":
+
+ {
+ too_complex => 1, # "this is a recurrence"
+ list => [ ], # not used
+ method => 'union', # function name
+ parent => [ $set1, $set2 ], # "leaves" in the syntax-tree
+ param => [ ] # optional arguments for the function
+ }
+
+This is a structure that holds the complement of a "complex set":
+
+ {
+ too_complex => 1, # "this is a recurrence"
+ list => [ ], # not used
+ method => 'complement', # function name
+ parent => $set, # "leaf" in the syntax-tree
+ param => [ ] # optional arguments for the function
+ }
+
+
+=head1 SEE ALSO
+
+See modules DateTime::Set, DateTime::Event::Recurrence,
+DateTime::Event::ICal, DateTime::Event::Cron
+for up-to-date information on date-sets.
+
+The perl-date-time project <http://datetime.perl.org>
+
+
+=head1 AUTHOR
+
+Flavio S. Glock <fglock@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file included
+with this module.
+
+=cut
+
--- /dev/null
+package Set::Infinite::Arithmetic;
+# Copyright (c) 2001 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+use strict;
+# use warnings;
+require Exporter;
+use Carp;
+use Time::Local;
+use POSIX qw(floor);
+
+use vars qw( @EXPORT @EXPORT_OK $inf );
+
+@EXPORT = qw();
+@EXPORT_OK = qw();
+# @EXPORT_OK = qw( %subs_offset2 %Offset_to_value %Value_to_offset %Init_quantizer );
+
+$inf = 100**100**100; # $Set::Infinite::inf; doesn't work! (why?)
+
+=head2 NAME
+
+Set::Infinite::Arithmetic - Scalar operations used by quantize() and offset()
+
+=head2 AUTHOR
+
+Flavio Soibelmann Glock - fglock@pucrs.br
+
+=cut
+
+use vars qw( $day_size $hour_size $minute_size $second_size );
+$day_size = timegm(0,0,0,2,3,2001) - timegm(0,0,0,1,3,2001);
+$hour_size = $day_size / 24;
+$minute_size = $hour_size / 60;
+$second_size = $minute_size / 60;
+
+use vars qw( %_MODE %subs_offset2 %Offset_to_value @week_start %Init_quantizer %Value_to_offset %Offset_to_value );
+
+=head2 %_MODE hash of subs
+
+ $a->offset ( value => [1,2], mode => 'offset', unit => 'days' );
+
+ $a->offset ( value => [1,2, -5,-4], mode => 'offset', unit => 'days' );
+
+note: if mode = circle, then "-5" counts from end (like a Perl negative array index).
+
+ $a->offset ( value => [1,2], mode => 'offset', unit => 'days', strict => $a );
+
+option 'strict' will return intersection($a,offset). Default: none.
+
+=cut
+
+# return value = ($this, $next, $cmp)
+%_MODE = (
+ circle => sub {
+ if ($_[3] >= 0) {
+ &{ $_[0] } ($_[1], $_[3], $_[4] )
+ }
+ else {
+ &{ $_[0] } ($_[2], $_[3], $_[4] )
+ }
+ },
+ begin => sub { &{ $_[0] } ($_[1], $_[3], $_[4] ) },
+ end => sub { &{ $_[0] } ($_[2], $_[3], $_[4] ) },
+ offset => sub {
+ my ($this, undef) = &{ $_[0] } ($_[1], $_[3], $_[4] );
+ my (undef, $next) = &{ $_[0] } ($_[2], $_[3], $_[4] );
+ ($this, $next);
+ }
+);
+
+
+=head2 %subs_offset2($object, $offset1, $offset2)
+
+ &{ $subs_offset2{$unit} } ($object, $offset1, $offset2);
+
+A hash of functions that return:
+
+ ($object+$offset1, $object+$offset2)
+
+in $unit context.
+
+Returned $object+$offset1, $object+$offset2 may be scalars or objects.
+
+=cut
+
+%subs_offset2 = (
+ weekdays => sub {
+ # offsets to week-day specified
+ # 0 = first sunday from today (or today if today is sunday)
+ # 1 = first monday from today (or today if today is monday)
+ # 6 = first friday from today (or today if today is friday)
+ # 13 = second friday from today
+ # -1 = last saturday from today (not today, even if today were saturday)
+ # -2 = last friday
+ my ($self, $index1, $index2) = @_;
+ return ($self, $self) if $self == $inf;
+ # my $class = ref($self);
+ my @date = gmtime( $self );
+ my $wday = $date[6];
+ my ($tmp1, $tmp2);
+
+ $tmp1 = $index1 - $wday;
+ if ($index1 >= 0) {
+ $tmp1 += 7 if $tmp1 < 0; # it will only happen next week
+ }
+ else {
+ $tmp1 += 7 if $tmp1 < -7; # if will happen this week
+ }
+
+ $tmp2 = $index2 - $wday;
+ if ($index2 >= 0) {
+ $tmp2 += 7 if $tmp2 < 0; # it will only happen next week
+ }
+ else {
+ $tmp2 += 7 if $tmp2 < -7; # if will happen this week
+ }
+
+ # print " [ OFS:weekday $self $tmp1 $tmp2 ] \n";
+ # $date[3] += $tmp1;
+ $tmp1 = $self + $tmp1 * $day_size;
+ # $date[3] += $tmp2 - $tmp1;
+ $tmp2 = $self + $tmp2 * $day_size;
+
+ ($tmp1, $tmp2);
+ },
+ years => sub {
+ my ($self, $index, $index2) = @_;
+ return ($self, $self) if $self == $inf;
+ # my $class = ref($self);
+ # print " [ofs:year:$self -- $index]\n";
+ my @date = gmtime( $self );
+ $date[5] += 1900 + $index;
+ my $tmp = timegm(@date);
+
+ $date[5] += $index2 - $index;
+ my $tmp2 = timegm(@date);
+
+ ($tmp, $tmp2);
+ },
+ months => sub {
+ my ($self, $index, $index2) = @_;
+ # carp " [ofs:month:$self -- $index -- $inf]";
+ return ($self, $self) if $self == $inf;
+ # my $class = ref($self);
+ my @date = gmtime( $self );
+
+ my $mon = $date[4] + $index;
+ my $year = $date[5] + 1900;
+ # print " [OFS: month: from $year$mon ]\n";
+ if (($mon > 11) or ($mon < 0)) {
+ my $addyear = floor($mon / 12);
+ $mon = $mon - 12 * $addyear;
+ $year += $addyear;
+ }
+
+ my $mon2 = $date[4] + $index2;
+ my $year2 = $date[5] + 1900;
+ if (($mon2 > 11) or ($mon2 < 0)) {
+ my $addyear2 = floor($mon2 / 12);
+ $mon2 = $mon2 - 12 * $addyear2;
+ $year2 += $addyear2;
+ }
+
+ # print " [OFS: month: to $year $mon ]\n";
+
+ $date[4] = $mon;
+ $date[5] = $year;
+ my $tmp = timegm(@date);
+
+ $date[4] = $mon2;
+ $date[5] = $year2;
+ my $tmp2 = timegm(@date);
+
+ ($tmp, $tmp2);
+ },
+ days => sub {
+ ( $_[0] + $_[1] * $day_size,
+ $_[0] + $_[2] * $day_size,
+ )
+ },
+ weeks => sub {
+ ( $_[0] + $_[1] * (7 * $day_size),
+ $_[0] + $_[2] * (7 * $day_size),
+ )
+ },
+ hours => sub {
+ # carp " [ $_[0]+$_[1] hour = ".( $_[0] + $_[1] * $hour_size )." mode=".($_[0]->{mode})." ]";
+ ( $_[0] + $_[1] * $hour_size,
+ $_[0] + $_[2] * $hour_size,
+ )
+ },
+ minutes => sub {
+ ( $_[0] + $_[1] * $minute_size,
+ $_[0] + $_[2] * $minute_size,
+ )
+ },
+ seconds => sub {
+ ( $_[0] + $_[1] * $second_size,
+ $_[0] + $_[2] * $second_size,
+ )
+ },
+ one => sub {
+ ( $_[0] + $_[1],
+ $_[0] + $_[2],
+ )
+ },
+);
+
+
+@week_start = ( 0, -1, -2, -3, 3, 2, 1, 0, -1, -2, -3, 3, 2, 1, 0 );
+
+=head2 %Offset_to_value($object, $offset)
+
+=head2 %Init_quantizer($object)
+
+ $Offset_to_value{$unit} ($object, $offset);
+
+ $Init_quantizer{$unit} ($object);
+
+Maps an 'offset value' to a 'value'
+
+A hash of functions that return ( int($object) + $offset ) in $unit context.
+
+Init_quantizer subroutines must be called before using subs_offset1 functions.
+
+int(object)+offset is a scalar.
+
+Offset_to_value is optimized for calling it multiple times on the same object,
+with different offsets. That's why there is a separate initialization
+subroutine.
+
+$self->{offset} is created on initialization. It is an index used
+by the memoization cache.
+
+=cut
+
+%Offset_to_value = (
+ weekyears => sub {
+ my ($self, $index) = @_;
+ my $epoch = timegm( 0,0,0,
+ 1,0,$self->{offset} + $self->{quant} * $index);
+ my @time = gmtime($epoch);
+ # print " [QT_D:weekyears:$self->{offset} + $self->{quant} * $index]\n";
+ # year modulo week
+ # print " [QT:weekyears: time = ",join(";", @time )," ]\n";
+ $epoch += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size;
+ # print " [QT:weekyears: week=",join(";", gmtime($epoch) )," wkst=$self->{wkst} tbl[",$time[6] + 7 - $self->{wkst},"]=",$week_start[$time[6] + 7 - $self->{wkst}]," ]\n\n";
+
+ my $epoch2 = timegm( 0,0,0,
+ 1,0,$self->{offset} + $self->{quant} * (1 + $index) );
+ @time = gmtime($epoch2);
+ $epoch2 += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size;
+ ( $epoch, $epoch2 );
+ },
+ years => sub {
+ my $index = $_[0]->{offset} + $_[0]->{quant} * $_[1];
+ ( timegm( 0,0,0, 1, 0, $index),
+ timegm( 0,0,0, 1, 0, $index + $_[0]->{quant}) )
+ },
+ months => sub {
+ my $mon = $_[0]->{offset} + $_[0]->{quant} * $_[1];
+ my $year = int($mon / 12);
+ $mon -= $year * 12;
+ my $tmp = timegm( 0,0,0, 1, $mon, $year);
+
+ $mon += $year * 12 + $_[0]->{quant};
+ $year = int($mon / 12);
+ $mon -= $year * 12;
+ ( $tmp, timegm( 0,0,0, 1, $mon, $year) );
+ },
+ weeks => sub {
+ my $tmp = 3 * $day_size + $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ days => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ hours => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ minutes => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ seconds => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ one => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+);
+
+
+# Maps an 'offset value' to a 'value'
+
+%Value_to_offset = (
+ one => sub { floor( $_[1] / $_[0]{quant} ) },
+ seconds => sub { floor( $_[1] / $_[0]{quant} ) },
+ minutes => sub { floor( $_[1] / $_[0]{quant} ) },
+ hours => sub { floor( $_[1] / $_[0]{quant} ) },
+ days => sub { floor( $_[1] / $_[0]{quant} ) },
+ weeks => sub { floor( ($_[1] - 3 * $day_size) / $_[0]{quant} ) },
+ months => sub {
+ my @date = gmtime( 0 + $_[1] );
+ my $tmp = $date[4] + 12 * (1900 + $date[5]);
+ floor( $tmp / $_[0]{quant} );
+ },
+ years => sub {
+ my @date = gmtime( 0 + $_[1] );
+ my $tmp = $date[5] + 1900;
+ floor( $tmp / $_[0]{quant} );
+ },
+ weekyears => sub {
+
+ my ($self, $value) = @_;
+ my @date;
+
+ # find out YEAR number
+ @date = gmtime( 0 + $value );
+ my $year = floor( $date[5] + 1900 / $self->{quant} );
+
+ # what is the EPOCH for this week-year's begin ?
+ my $begin_epoch = timegm( 0,0,0, 1,0,$year);
+ @date = gmtime($begin_epoch);
+ $begin_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size;
+
+ # what is the EPOCH for this week-year's end ?
+ my $end_epoch = timegm( 0,0,0, 1,0,$year+1);
+ @date = gmtime($end_epoch);
+ $end_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size;
+
+ $year-- if $value < $begin_epoch;
+ $year++ if $value >= $end_epoch;
+
+ # carp " value=$value offset=$year this_epoch=".$begin_epoch;
+ # carp " next_epoch=".$end_epoch;
+
+ $year;
+ },
+);
+
+# Initialize quantizer
+
+%Init_quantizer = (
+ one => sub {},
+ seconds => sub { $_[0]->{quant} *= $second_size },
+ minutes => sub { $_[0]->{quant} *= $minute_size },
+ hours => sub { $_[0]->{quant} *= $hour_size },
+ days => sub { $_[0]->{quant} *= $day_size },
+ weeks => sub { $_[0]->{quant} *= 7 * $day_size },
+ months => sub {},
+ years => sub {},
+ weekyears => sub {
+ $_[0]->{wkst} = 1 unless defined $_[0]->{wkst};
+ # select which 'cache' to use
+ # $_[0]->{memo} .= $_[0]->{wkst};
+ },
+);
+
+
+1;
+
--- /dev/null
+package Set::Infinite::Basic;
+
+# Copyright (c) 2001, 2002, 2003 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+require 5.005_03;
+use strict;
+
+require Exporter;
+use Carp;
+use Data::Dumper;
+use vars qw( @ISA @EXPORT_OK @EXPORT );
+use vars qw( $Type $tolerance $fixtype $inf $minus_inf @Separators $neg_inf );
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw( INFINITY NEG_INFINITY );
+@EXPORT = qw();
+
+use constant INFINITY => 100**100**100;
+use constant NEG_INFINITY => - INFINITY;
+
+$inf = INFINITY;
+$minus_inf = $neg_inf = NEG_INFINITY;
+
+use overload
+ '<=>' => \&spaceship,
+ qw("" as_string),
+;
+
+
+# TODO: make this an object _and_ class method
+# TODO: POD
+sub separators {
+ shift;
+ return $Separators[ $_[0] ] if $#_ == 0;
+ @Separators = @_ if @_;
+ return @Separators;
+}
+
+BEGIN {
+ __PACKAGE__->separators (
+ '[', ']', # a closed interval
+ '(', ')', # an open interval
+ '..', # number separator
+ ',', # list separator
+ '', '', # set delimiter '{' '}'
+ );
+ # global defaults for object private vars
+ $Type = undef;
+ $tolerance = 0;
+ $fixtype = 1;
+}
+
+# _simple_* set of internal methods: basic processing of "spans"
+
+sub _simple_intersects {
+ my $tmp1 = $_[0];
+ my $tmp2 = $_[1];
+ my ($i_beg, $i_end, $open_beg, $open_end);
+ my $cmp = $tmp1->{a} <=> $tmp2->{a};
+ if ($cmp < 0) {
+ $i_beg = $tmp2->{a};
+ $open_beg = $tmp2->{open_begin};
+ }
+ elsif ($cmp > 0) {
+ $i_beg = $tmp1->{a};
+ $open_beg = $tmp1->{open_begin};
+ }
+ else {
+ $i_beg = $tmp1->{a};
+ $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
+ }
+ $cmp = $tmp1->{b} <=> $tmp2->{b};
+ if ($cmp > 0) {
+ $i_end = $tmp2->{b};
+ $open_end = $tmp2->{open_end};
+ }
+ elsif ($cmp < 0) {
+ $i_end = $tmp1->{b};
+ $open_end = $tmp1->{open_end};
+ }
+ else {
+ $i_end = $tmp1->{b};
+ $open_end = ($tmp1->{open_end} || $tmp2->{open_end});
+ }
+ $cmp = $i_beg <=> $i_end;
+ return 0 if
+ ( $cmp > 0 ) ||
+ ( ($cmp == 0) && ($open_beg || $open_end) ) ;
+ return 1;
+}
+
+
+sub _simple_complement {
+ my $self = $_[0];
+ if ($self->{b} == $inf) {
+ return if $self->{a} == $neg_inf;
+ return { a => $neg_inf,
+ b => $self->{a},
+ open_begin => 1,
+ open_end => ! $self->{open_begin} };
+ }
+ if ($self->{a} == $neg_inf) {
+ return { a => $self->{b},
+ b => $inf,
+ open_begin => ! $self->{open_end},
+ open_end => 1 };
+ }
+ ( { a => $neg_inf,
+ b => $self->{a},
+ open_begin => 1,
+ open_end => ! $self->{open_begin}
+ },
+ { a => $self->{b},
+ b => $inf,
+ open_begin => ! $self->{open_end},
+ open_end => 1
+ }
+ );
+}
+
+sub _simple_union {
+ my ($tmp2, $tmp1, $tolerance) = @_;
+ my $cmp;
+ if ($tolerance) {
+ # "integer"
+ my $a1_open = $tmp1->{open_begin} ? -$tolerance : $tolerance ;
+ my $b1_open = $tmp1->{open_end} ? -$tolerance : $tolerance ;
+ my $a2_open = $tmp2->{open_begin} ? -$tolerance : $tolerance ;
+ my $b2_open = $tmp2->{open_end} ? -$tolerance : $tolerance ;
+ # open_end touching?
+ if ((($tmp1->{b}+$tmp1->{b}) + $b1_open ) <
+ (($tmp2->{a}+$tmp2->{a}) - $a2_open)) {
+ # self disjuncts b
+ return ( $tmp1, $tmp2 );
+ }
+ if ((($tmp1->{a}+$tmp1->{a}) - $a1_open ) >
+ (($tmp2->{b}+$tmp2->{b}) + $b2_open)) {
+ # self disjuncts b
+ return ( $tmp2, $tmp1 );
+ }
+ }
+ else {
+ # "real"
+ $cmp = $tmp1->{b} <=> $tmp2->{a};
+ if ( $cmp < 0 ||
+ ( $cmp == 0 && $tmp1->{open_end} && $tmp2->{open_begin} ) ) {
+ return ( $tmp1, $tmp2 );
+ }
+ $cmp = $tmp1->{a} <=> $tmp2->{b};
+ if ( $cmp > 0 ||
+ ( $cmp == 0 && $tmp2->{open_end} && $tmp1->{open_begin} ) ) {
+ return ( $tmp2, $tmp1 );
+ }
+ }
+
+ my $tmp;
+ $cmp = $tmp1->{a} <=> $tmp2->{a};
+ if ($cmp > 0) {
+ $tmp->{a} = $tmp2->{a};
+ $tmp->{open_begin} = $tmp2->{open_begin};
+ }
+ elsif ($cmp == 0) {
+ $tmp->{a} = $tmp1->{a};
+ $tmp->{open_begin} = $tmp1->{open_begin} ? $tmp2->{open_begin} : 0;
+ }
+ else {
+ $tmp->{a} = $tmp1->{a};
+ $tmp->{open_begin} = $tmp1->{open_begin};
+ }
+
+ $cmp = $tmp1->{b} <=> $tmp2->{b};
+ if ($cmp < 0) {
+ $tmp->{b} = $tmp2->{b};
+ $tmp->{open_end} = $tmp2->{open_end};
+ }
+ elsif ($cmp == 0) {
+ $tmp->{b} = $tmp1->{b};
+ $tmp->{open_end} = $tmp1->{open_end} ? $tmp2->{open_end} : 0;
+ }
+ else {
+ $tmp->{b} = $tmp1->{b};
+ $tmp->{open_end} = $tmp1->{open_end};
+ }
+ return $tmp;
+}
+
+
+sub _simple_spaceship {
+ my ($tmp1, $tmp2, $inverted) = @_;
+ my $cmp;
+ if ($inverted) {
+ $cmp = $tmp2->{a} <=> $tmp1->{a};
+ return $cmp if $cmp;
+ $cmp = $tmp1->{open_begin} <=> $tmp2->{open_begin};
+ return $cmp if $cmp;
+ $cmp = $tmp2->{b} <=> $tmp1->{b};
+ return $cmp if $cmp;
+ return $tmp1->{open_end} <=> $tmp2->{open_end};
+ }
+ $cmp = $tmp1->{a} <=> $tmp2->{a};
+ return $cmp if $cmp;
+ $cmp = $tmp2->{open_begin} <=> $tmp1->{open_begin};
+ return $cmp if $cmp;
+ $cmp = $tmp1->{b} <=> $tmp2->{b};
+ return $cmp if $cmp;
+ return $tmp2->{open_end} <=> $tmp1->{open_end};
+}
+
+
+sub _simple_new {
+ my ($tmp, $tmp2, $type) = @_;
+ if ($type) {
+ if ( ref($tmp) ne $type ) {
+ $tmp = new $type $tmp;
+ }
+ if ( ref($tmp2) ne $type ) {
+ $tmp2 = new $type $tmp2;
+ }
+ }
+ if ($tmp > $tmp2) {
+ carp "Invalid interval specification: start value is after end";
+ # ($tmp, $tmp2) = ($tmp2, $tmp);
+ }
+ return { a => $tmp , b => $tmp2 , open_begin => 0 , open_end => 0 };
+}
+
+
+sub _simple_as_string {
+ my $set = shift;
+ my $self = $_[0];
+ my $s;
+ return "" unless defined $self;
+ $self->{open_begin} = 1 if ($self->{a} == -$inf );
+ $self->{open_end} = 1 if ($self->{b} == $inf );
+ my $tmp1 = $self->{a};
+ $tmp1 = $tmp1->datetime if UNIVERSAL::can( $tmp1, 'datetime' );
+ $tmp1 = "$tmp1";
+ my $tmp2 = $self->{b};
+ $tmp2 = $tmp2->datetime if UNIVERSAL::can( $tmp2, 'datetime' );
+ $tmp2 = "$tmp2";
+ return $tmp1 if $tmp1 eq $tmp2;
+ $s = $self->{open_begin} ? $set->separators(2) : $set->separators(0);
+ $s .= $tmp1 . $set->separators(4) . $tmp2;
+ $s .= $self->{open_end} ? $set->separators(3) : $set->separators(1);
+ return $s;
+}
+
+# end of "_simple_" methods
+
+
+sub type {
+ my $self = shift;
+ unless (@_) {
+ return ref($self) ? $self->{type} : $Type;
+ }
+ my $tmp_type = shift;
+ eval "use " . $tmp_type;
+ carp "Warning: can't start $tmp_type : $@" if $@;
+ if (ref($self)) {
+ $self->{type} = $tmp_type;
+ return $self;
+ }
+ else {
+ $Type = $tmp_type;
+ return $Type;
+ }
+}
+
+sub list {
+ my $self = shift;
+ my @b = ();
+ foreach (@{$self->{list}}) {
+ push @b, $self->new($_);
+ }
+ return @b;
+}
+
+sub fixtype {
+ my $self = shift;
+ $self = $self->copy;
+ $self->{fixtype} = 1;
+ my $type = $self->type;
+ return $self unless $type;
+ foreach (@{$self->{list}}) {
+ $_->{a} = $type->new($_->{a}) unless ref($_->{a}) eq $type;
+ $_->{b} = $type->new($_->{b}) unless ref($_->{b}) eq $type;
+ }
+ return $self;
+}
+
+sub numeric {
+ my $self = shift;
+ return $self unless $self->{fixtype};
+ $self = $self->copy;
+ $self->{fixtype} = 0;
+ foreach (@{$self->{list}}) {
+ $_->{a} = 0 + $_->{a};
+ $_->{b} = 0 + $_->{b};
+ }
+ return $self;
+}
+
+sub _no_cleanup { $_[0] } # obsolete
+
+sub first {
+ my $self = $_[0];
+ if (exists $self->{first} ) {
+ return wantarray ? @{$self->{first}} : $self->{first}[0];
+ }
+ unless ( @{$self->{list}} ) {
+ return wantarray ? (undef, 0) : undef;
+ }
+ my $first = $self->new( $self->{list}[0] );
+ return $first unless wantarray;
+ my $res = $self->new;
+ push @{$res->{list}}, @{$self->{list}}[1 .. $#{$self->{list}}];
+ return @{$self->{first}} = ($first) if $res->is_null;
+ return @{$self->{first}} = ($first, $res);
+}
+
+sub last {
+ my $self = $_[0];
+ if (exists $self->{last} ) {
+ return wantarray ? @{$self->{last}} : $self->{last}[0];
+ }
+ unless ( @{$self->{list}} ) {
+ return wantarray ? (undef, 0) : undef;
+ }
+ my $last = $self->new( $self->{list}[-1] );
+ return $last unless wantarray;
+ my $res = $self->new;
+ push @{$res->{list}}, @{$self->{list}}[0 .. $#{$self->{list}}-1];
+ return @{$self->{last}} = ($last) if $res->is_null;
+ return @{$self->{last}} = ($last, $res);
+}
+
+sub is_null {
+ @{$_[0]->{list}} ? 0 : 1;
+}
+
+sub is_empty {
+ $_[0]->is_null;
+}
+
+sub is_nonempty {
+ ! $_[0]->is_null;
+}
+
+sub is_span {
+ ( $#{$_[0]->{list}} == 0 ) ? 1 : 0;
+}
+
+sub is_singleton {
+ ( $#{$_[0]->{list}} == 0 &&
+ $_[0]->{list}[0]{a} == $_[0]->{list}[0]{b} ) ? 1 : 0;
+}
+
+sub is_subset {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+ return $b1->contains( $a1 );
+}
+
+sub is_proper_subset {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+
+ my $contains = $b1->contains( $a1 );
+ return $contains unless $contains;
+
+ my $equal = ( $a1 == $b1 );
+ return $equal if !defined $equal || $equal;
+
+ return 1;
+}
+
+sub is_disjoint {
+ my $intersects = shift->intersects( @_ );
+ return ! $intersects if defined $intersects;
+ return $intersects;
+}
+
+sub iterate {
+ # TODO: options 'no-sort', 'no-merge', 'keep-null' ...
+ my $a1 = shift;
+ my $iterate = $a1->empty_set();
+ my (@tmp, $ia);
+ my $subroutine = shift;
+ foreach $ia (0 .. $#{$a1->{list}}) {
+ @tmp = $subroutine->( $a1->new($a1->{list}[$ia]), @_ );
+ $iterate = $iterate->union(@tmp) if @tmp;
+ }
+ return $iterate;
+}
+
+
+sub intersection {
+ my $a1 = shift;
+ my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
+ return _intersection ( 'intersection', $a1, $b1 );
+}
+
+sub intersects {
+ my $a1 = shift;
+ my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
+ return _intersection ( 'intersects', $a1, $b1 );
+}
+
+sub intersected_spans {
+ my $a1 = shift;
+ my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
+ return _intersection ( 'intersected_spans', $a1, $b1 );
+}
+
+
+sub _intersection {
+ my ( $op, $a1, $b1 ) = @_;
+
+ my $ia;
+ my ( $a0, $na ) = ( 0, $#{$a1->{list}} );
+ my ( $tmp1, $tmp1a, $tmp2a, $tmp1b, $tmp2b, $i_beg, $i_end, $open_beg, $open_end );
+ my ( $cmp1, $cmp2 );
+ my @a;
+
+ # for-loop optimization (makes little difference)
+ # This was kept for backward compatibility with Date::Set tests
+ my $self = $a1;
+ if ($na < $#{ $b1->{list} })
+ {
+ $na = $#{ $b1->{list} };
+ ($a1, $b1) = ($b1, $a1);
+ }
+ # ---
+
+ B: foreach my $tmp2 ( @{ $b1->{list} } ) {
+ $tmp2a = $tmp2->{a};
+ $tmp2b = $tmp2->{b};
+ A: foreach $ia ($a0 .. $na) {
+ $tmp1 = $a1->{list}[$ia];
+ $tmp1b = $tmp1->{b};
+
+ if ($tmp1b < $tmp2a) {
+ $a0++;
+ next A;
+ }
+ $tmp1a = $tmp1->{a};
+ if ($tmp1a > $tmp2b) {
+ next B;
+ }
+
+ $cmp1 = $tmp1a <=> $tmp2a;
+ if ( $cmp1 < 0 ) {
+ $tmp1a = $tmp2a;
+ $open_beg = $tmp2->{open_begin};
+ }
+ elsif ( $cmp1 ) {
+ $open_beg = $tmp1->{open_begin};
+ }
+ else {
+ $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
+ }
+
+ $cmp2 = $tmp1b <=> $tmp2b;
+ if ( $cmp2 > 0 ) {
+ $tmp1b = $tmp2b;
+ $open_end = $tmp2->{open_end};
+ }
+ elsif ( $cmp2 ) {
+ $open_end = $tmp1->{open_end};
+ }
+ else {
+ $open_end = $tmp1->{open_end} || $tmp2->{open_end};
+ }
+
+ if ( ( $tmp1a <= $tmp1b ) &&
+ ( ($tmp1a != $tmp1b) ||
+ (!$open_beg and !$open_end) ||
+ ($tmp1a == $inf) || # XXX
+ ($tmp1a == $neg_inf)
+ )
+ )
+ {
+ if ( $op eq 'intersection' )
+ {
+ push @a, {
+ a => $tmp1a, b => $tmp1b,
+ open_begin => $open_beg, open_end => $open_end } ;
+ }
+ if ( $op eq 'intersects' )
+ {
+ return 1;
+ }
+ if ( $op eq 'intersected_spans' )
+ {
+ push @a, $tmp1;
+ $a0++;
+ next A;
+ }
+ }
+ }
+ }
+
+ return 0 if $op eq 'intersects';
+
+ my $intersection = $self->new();
+ $intersection->{list} = \@a;
+ return $intersection;
+}
+
+
+sub complement {
+ my $self = shift;
+ if (@_) {
+ my $a1;
+ if (ref ($_[0]) eq ref($self) ) {
+ $a1 = shift;
+ }
+ else {
+ $a1 = $self->new(@_);
+ }
+ return $self->intersection( $a1->complement );
+ }
+
+ unless ( @{$self->{list}} ) {
+ return $self->universal_set;
+ }
+ my $complement = $self->empty_set();
+ @{$complement->{list}} = _simple_complement($self->{list}[0]);
+
+ my $tmp = $self->empty_set();
+ foreach my $ia (1 .. $#{$self->{list}}) {
+ @{$tmp->{list}} = _simple_complement($self->{list}[$ia]);
+ $complement = $complement->intersection($tmp);
+ }
+ return $complement;
+}
+
+
+sub until {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+ my @b1_min = $b1->min_a;
+ my @a1_max = $a1->max_a;
+
+ unless (defined $b1_min[0]) {
+ return $a1->until($inf);
+ }
+ unless (defined $a1_max[0]) {
+ return $a1->new(-$inf)->until($b1);
+ }
+
+ my ($ia, $ib, $begin, $end);
+ $ia = 0;
+ $ib = 0;
+
+ my $u = $a1->new;
+ my $last = -$inf;
+ while ( ($ia <= $#{$a1->{list}}) && ($ib <= $#{$b1->{list}})) {
+ $begin = $a1->{list}[$ia]{a};
+ $end = $b1->{list}[$ib]{b};
+ if ( $end <= $begin ) {
+ push @{$u->{list}}, {
+ a => $last ,
+ b => $end ,
+ open_begin => 0 ,
+ open_end => 1 };
+ $ib++;
+ $last = $end;
+ next;
+ }
+ push @{$u->{list}}, {
+ a => $begin ,
+ b => $end ,
+ open_begin => 0 ,
+ open_end => 1 };
+ $ib++;
+ $ia++;
+ $last = $end;
+ }
+ if ($ia <= $#{$a1->{list}} &&
+ $a1->{list}[$ia]{a} >= $last )
+ {
+ push @{$u->{list}}, {
+ a => $a1->{list}[$ia]{a} ,
+ b => $inf ,
+ open_begin => 0 ,
+ open_end => 1 };
+ }
+ return $u;
+}
+
+sub start_set {
+ return $_[0]->iterate(
+ sub { $_[0]->min }
+ );
+}
+
+
+sub end_set {
+ return $_[0]->iterate(
+ sub { $_[0]->max }
+ );
+}
+
+sub union {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+ # test for union with empty set
+ if ( $#{ $a1->{list} } < 0 ) {
+ return $b1;
+ }
+ if ( $#{ $b1->{list} } < 0 ) {
+ return $a1;
+ }
+ my @b1_min = $b1->min_a;
+ my @a1_max = $a1->max_a;
+ unless (defined $b1_min[0]) {
+ return $a1;
+ }
+ unless (defined $a1_max[0]) {
+ return $b1;
+ }
+ my ($ia, $ib);
+ $ia = 0;
+ $ib = 0;
+
+ # size+order matters on speed
+ $a1 = $a1->new($a1); # don't modify ourselves
+ my $b_list = $b1->{list};
+ # -- frequent case - $b1 is after $a1
+ if ($b1_min[0] > $a1_max[0]) {
+ push @{$a1->{list}}, @$b_list;
+ return $a1;
+ }
+
+ my @tmp;
+ my $is_real = !$a1->tolerance && !$b1->tolerance;
+ B: foreach $ib ($ib .. $#{$b_list}) {
+ foreach $ia ($ia .. $#{$a1->{list}}) {
+ @tmp = _simple_union($a1->{list}[$ia], $b_list->[$ib], $a1->{tolerance});
+ if ($#tmp == 0) {
+ $a1->{list}[$ia] = $tmp[0];
+
+ while (1) {
+ last if $ia >= $#{$a1->{list}};
+ last unless _simple_intersects ( $a1->{list}[$ia], $a1->{list}[$ia + 1] )
+ || $is_real
+ && $a1->{list}[$ia]{b} == $a1->{list}[$ia + 1]{a};
+ @tmp = _simple_union($a1->{list}[$ia], $a1->{list}[$ia + 1], $a1->{tolerance});
+ last unless @tmp == 1;
+ $a1->{list}[$ia] = $tmp[0];
+ splice( @{$a1->{list}}, $ia + 1, 1 );
+ }
+
+ next B;
+ }
+ if ($a1->{list}[$ia]{a} >= $b_list->[$ib]{a}) {
+ splice (@{$a1->{list}}, $ia, 0, $b_list->[$ib]);
+ next B;
+ }
+ }
+ push @{$a1->{list}}, $b_list->[$ib];
+ }
+ return $a1;
+}
+
+
+# there are some ways to process 'contains':
+# A CONTAINS B IF A == ( A UNION B )
+# - faster
+# A CONTAINS B IF B == ( A INTERSECTION B )
+# - can backtrack = works for unbounded sets
+sub contains {
+ my $a1 = shift;
+ my $b1 = $a1->union(@_);
+ return ($b1 == $a1) ? 1 : 0;
+}
+
+
+sub copy {
+ my $self = shift;
+ my $copy = $self->empty_set();
+ ## return $copy unless ref($self); # constructor!
+ foreach my $key (keys %{$self}) {
+ if ( ref( $self->{$key} ) eq 'ARRAY' ) {
+ @{ $copy->{$key} } = @{ $self->{$key} };
+ }
+ else {
+ $copy->{$key} = $self->{$key};
+ }
+ }
+ return $copy;
+}
+
+*clone = \©
+
+
+sub new {
+ my $class = shift;
+ my $self;
+ if ( ref $class ) {
+ $self = bless {
+ list => [],
+ tolerance => $class->{tolerance},
+ type => $class->{type},
+ fixtype => $class->{fixtype},
+ }, ref($class);
+ }
+ else {
+ $self = bless {
+ list => [],
+ tolerance => $tolerance ? $tolerance : 0,
+ type => $class->type,
+ fixtype => $fixtype ? $fixtype : 0,
+ }, $class;
+ }
+ my ($tmp, $tmp2, $ref);
+ while (@_) {
+ $tmp = shift;
+ $ref = ref($tmp);
+ if ($ref) {
+ if ($ref eq 'ARRAY') {
+ # allows arrays of arrays
+ $tmp = $class->new(@$tmp); # call new() recursively
+ push @{ $self->{list} }, @{$tmp->{list}};
+ next;
+ }
+ if ($ref eq 'HASH') {
+ push @{ $self->{list} }, $tmp;
+ next;
+ }
+ if ($tmp->isa(__PACKAGE__)) {
+ push @{ $self->{list} }, @{$tmp->{list}};
+ next;
+ }
+ }
+ if ( @_ ) {
+ $tmp2 = shift
+ }
+ else {
+ $tmp2 = $tmp
+ }
+ push @{ $self->{list} }, _simple_new($tmp,$tmp2, $self->{type} )
+ }
+ $self;
+}
+
+sub empty_set {
+ $_[0]->new;
+}
+
+sub universal_set {
+ $_[0]->new( NEG_INFINITY, INFINITY );
+}
+
+*minus = \∁
+
+*difference = \∁
+
+sub symmetric_difference {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+
+ return $a1->complement( $b1 )->union(
+ $b1->complement( $a1 ) );
+}
+
+*simmetric_difference = \&symmetric_difference; # bugfix
+
+sub min {
+ ($_[0]->min_a)[0];
+}
+
+sub min_a {
+ my $self = $_[0];
+ return @{$self->{min}} if exists $self->{min};
+ return @{$self->{min}} = (undef, 0) unless @{$self->{list}};
+ my $tmp = $self->{list}[0]{a};
+ my $tmp2 = $self->{list}[0]{open_begin} || 0;
+ if ($tmp2 && $self->{tolerance}) {
+ $tmp2 = 0;
+ $tmp += $self->{tolerance};
+ }
+ return @{$self->{min}} = ($tmp, $tmp2);
+};
+
+sub max {
+ ($_[0]->max_a)[0];
+}
+
+sub max_a {
+ my $self = $_[0];
+ return @{$self->{max}} if exists $self->{max};
+ return @{$self->{max}} = (undef, 0) unless @{$self->{list}};
+ my $tmp = $self->{list}[-1]{b};
+ my $tmp2 = $self->{list}[-1]{open_end} || 0;
+ if ($tmp2 && $self->{tolerance}) {
+ $tmp2 = 0;
+ $tmp -= $self->{tolerance};
+ }
+ return @{$self->{max}} = ($tmp, $tmp2);
+};
+
+sub count {
+ 1 + $#{$_[0]->{list}};
+}
+
+sub size {
+ my $self = $_[0];
+ my $size;
+ foreach( @{$self->{list}} ) {
+ if ( $size ) {
+ $size += $_->{b} - $_->{a};
+ }
+ else {
+ $size = $_->{b} - $_->{a};
+ }
+ if ( $self->{tolerance} ) {
+ $size += $self->{tolerance} unless $_->{open_end};
+ $size -= $self->{tolerance} if $_->{open_begin};
+ $size -= $self->{tolerance} if $_->{open_end};
+ }
+ }
+ return $size;
+};
+
+sub span {
+ my $self = $_[0];
+ my @max = $self->max_a;
+ my @min = $self->min_a;
+ return undef unless defined $min[0] && defined $max[0];
+ my $a1 = $self->new($min[0], $max[0]);
+ $a1->{list}[0]{open_end} = $max[1];
+ $a1->{list}[0]{open_begin} = $min[1];
+ return $a1;
+};
+
+sub spaceship {
+ my ($tmp1, $tmp2, $inverted) = @_;
+ if ($inverted) {
+ ($tmp2, $tmp1) = ($tmp1, $tmp2);
+ }
+ foreach(0 .. $#{$tmp1->{list}}) {
+ my $this = $tmp1->{list}[$_];
+ if ($_ > $#{ $tmp2->{list} } ) {
+ return 1;
+ }
+ my $other = $tmp2->{list}[$_];
+ my $cmp = _simple_spaceship($this, $other);
+ return $cmp if $cmp; # this != $other;
+ }
+ return $#{ $tmp1->{list} } == $#{ $tmp2->{list} } ? 0 : -1;
+}
+
+sub tolerance {
+ my $self = shift;
+ my $tmp = pop;
+ if (ref($self)) {
+ # local
+ return $self->{tolerance} unless defined $tmp;
+ $self = $self->copy;
+ $self->{tolerance} = $tmp;
+ delete $self->{max}; # tolerance may change "max"
+
+ $_ = 1;
+ my @tmp;
+ while ( $_ <= $#{$self->{list}} ) {
+ @tmp = Set::Infinite::Basic::_simple_union($self->{list}->[$_],
+ $self->{list}->[$_ - 1],
+ $self->{tolerance});
+ if ($#tmp == 0) {
+ $self->{list}->[$_ - 1] = $tmp[0];
+ splice (@{$self->{list}}, $_, 1);
+ }
+ else {
+ $_ ++;
+ }
+ }
+
+ return $self;
+ }
+ # global
+ $tolerance = $tmp if defined($tmp);
+ return $tolerance;
+}
+
+sub integer {
+ $_[0]->tolerance (1);
+}
+
+sub real {
+ $_[0]->tolerance (0);
+}
+
+sub as_string {
+ my $self = shift;
+ return $self->separators(6) .
+ join( $self->separators(5),
+ map { $self->_simple_as_string($_) } @{$self->{list}} ) .
+ $self->separators(7),;
+}
+
+
+sub DESTROY {}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Set::Infinite::Basic - Sets of intervals
+6
+=head1 SYNOPSIS
+
+ use Set::Infinite::Basic;
+
+ $set = Set::Infinite::Basic->new(1,2); # [1..2]
+ print $set->union(5,6); # [1..2],[5..6]
+
+=head1 DESCRIPTION
+
+Set::Infinite::Basic is a Set Theory module for infinite sets.
+
+It works on reals, integers, and objects.
+
+This module does not support recurrences. Recurrences are implemented in Set::Infinite.
+
+=head1 METHODS
+
+=head2 empty_set
+
+Creates an empty_set.
+
+If called from an existing set, the empty set inherits
+the "type" and "density" characteristics.
+
+=head2 universal_set
+
+Creates a set containing "all" possible elements.
+
+If called from an existing set, the universal set inherits
+the "type" and "density" characteristics.
+
+=head2 until
+
+Extends a set until another:
+
+ 0,5,7 -> until 2,6,10
+
+gives
+
+ [0..2), [5..6), [7..10)
+
+Note: this function is still experimental.
+
+=head2 copy
+
+=head2 clone
+
+Makes a new object from the object's data.
+
+=head2 Mode functions:
+
+ $set = $set->real;
+
+ $set = $set->integer;
+
+=head2 Logic functions:
+
+ $logic = $set->intersects($b);
+
+ $logic = $set->contains($b);
+
+ $logic = $set->is_null; # also called "is_empty"
+
+=head2 Set functions:
+
+ $set = $set->union($b);
+
+ $set = $set->intersection($b);
+
+ $set = $set->complement;
+ $set = $set->complement($b); # can also be called "minus" or "difference"
+
+ $set = $set->symmetric_difference( $b );
+
+ $set = $set->span;
+
+ result is (min .. max)
+
+=head2 Scalar functions:
+
+ $i = $set->min;
+
+ $i = $set->max;
+
+ $i = $set->size;
+
+ $i = $set->count; # number of spans
+
+=head2 Overloaded Perl functions:
+
+ print
+
+ sort, <=>
+
+=head2 Global functions:
+
+ separators(@i)
+
+ chooses the interval separators.
+
+ default are [ ] ( ) '..' ','.
+
+ INFINITY
+
+ returns an 'Infinity' number.
+
+ NEG_INFINITY
+
+ returns a '-Infinity' number.
+
+ iterate ( sub { } )
+
+ Iterates over a subroutine.
+ Returns the union of partial results.
+
+ first
+
+ In scalar context returns the first interval of a set.
+
+ In list context returns the first interval of a set, and the
+ 'tail'.
+
+ Works in unbounded sets
+
+ type($i)
+
+ chooses an object data type.
+
+ default is none (a normal perl SCALAR).
+
+ examples:
+
+ type('Math::BigFloat');
+ type('Math::BigInt');
+ type('Set::Infinite::Date');
+ See notes on Set::Infinite::Date below.
+
+ tolerance(0) defaults to real sets (default)
+ tolerance(1) defaults to integer sets
+
+ real defaults to real sets (default)
+
+ integer defaults to integer sets
+
+=head2 Internal functions:
+
+ $set->fixtype;
+
+ $set->numeric;
+
+=head1 CAVEATS
+
+ $set = Set::Infinite->new(10,1);
+ Will be interpreted as [1..10]
+
+ $set = Set::Infinite->new(1,2,3,4);
+ Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
+ You probably want ->new([1],[2],[3],[4]) instead,
+ or maybe ->new(1,4)
+
+ $set = Set::Infinite->new(1..3);
+ Will be interpreted as [1..2],3 instead of [1,2,3].
+ You probably want ->new(1,3) instead.
+
+=head1 INTERNALS
+
+The internal representation of a I<span> is a hash:
+
+ { a => start of span,
+ b => end of span,
+ open_begin => '0' the span starts in 'a'
+ '1' the span starts after 'a'
+ open_end => '0' the span ends in 'b'
+ '1' the span ends before 'b'
+ }
+
+For example, this set:
+
+ [100..200),300,(400..infinity)
+
+is represented by the array of hashes:
+
+ list => [
+ { a => 100, b => 200, open_begin => 0, open_end => 1 },
+ { a => 300, b => 300, open_begin => 0, open_end => 0 },
+ { a => 400, b => infinity, open_begin => 0, open_end => 1 },
+ ]
+
+The I<density> of a set is stored in the C<tolerance> variable:
+
+ tolerance => 0; # the set is made of real numbers.
+
+ tolerance => 1; # the set is made of integers.
+
+The C<type> variable stores the I<class> of objects that will be stored in the set.
+
+ type => 'DateTime'; # this is a set of DateTime objects
+
+The I<infinity> value is generated by Perl, when it finds a numerical overflow:
+
+ $inf = 100**100**100;
+
+=head1 SEE ALSO
+
+ Set::Infinite
+
+=head1 AUTHOR
+
+ Flavio S. Glock <fglock@gmail.com>
+
+=cut
+
--- /dev/null
+# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Set::Infinite::_recurrence;
+
+use strict;
+
+use constant INFINITY => 100 ** 100 ** 100 ;
+use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
+
+use vars qw( @ISA $PRETTY_PRINT $max_iterate );
+
+@ISA = qw( Set::Infinite );
+use Set::Infinite 0.5502;
+
+BEGIN {
+ $PRETTY_PRINT = 1; # enable Set::Infinite debug
+ $max_iterate = 20;
+
+ # TODO: inherit %Set::Infinite::_first / _last
+ # in a more "object oriented" way
+
+ $Set::Infinite::_first{_recurrence} =
+ sub {
+ my $self = $_[0];
+ my ($callback_next, $callback_previous) = @{ $self->{param} };
+ my ($min, $min_open) = $self->{parent}->min_a;
+
+ my ( $min1, $min2 );
+ $min1 = $callback_next->( $min );
+ if ( ! $min_open )
+ {
+ $min2 = $callback_previous->( $min1 );
+ $min1 = $min2 if defined $min2 && $min == $min2;
+ }
+
+ my $start = $callback_next->( $min1 );
+ my $end = $self->{parent}->max;
+
+ #print STDERR "set ";
+ #print STDERR $start->datetime
+ # unless $start == INFINITY;
+ #print STDERR " - " ;
+ #print STDERR $end->datetime
+ # unless $end == INFINITY;
+ #print STDERR "\n";
+
+ return ( $self->new( $min1 ), undef )
+ if $start > $end;
+
+ return ( $self->new( $min1 ),
+ $self->new( $start, $end )->
+ _function( '_recurrence', @{ $self->{param} } ) );
+ };
+ $Set::Infinite::_last{_recurrence} =
+ sub {
+ my $self = $_[0];
+ my ($callback_next, $callback_previous) = @{ $self->{param} };
+ my ($max, $max_open) = $self->{parent}->max_a;
+
+ my ( $max1, $max2 );
+ $max1 = $callback_previous->( $max );
+ if ( ! $max_open )
+ {
+ $max2 = $callback_next->( $max1 );
+ $max1 = $max2 if $max == $max2;
+ }
+
+ return ( $self->new( $max1 ),
+ $self->new( $self->{parent}->min,
+ $callback_previous->( $max1 ) )->
+ _function( '_recurrence', @{ $self->{param} } ) );
+ };
+}
+
+# $si->_recurrence(
+# \&callback_next, \&callback_previous )
+#
+# Generates "recurrences" from a callback.
+# These recurrences are simple lists of dates.
+#
+# The recurrence generation is based on an idea from Dave Rolsky.
+#
+
+# use Data::Dumper;
+# use Carp qw(cluck);
+
+sub _recurrence {
+ my $set = shift;
+ my ( $callback_next, $callback_previous, $delta ) = @_;
+
+ $delta->{count} = 0 unless defined $delta->{delta};
+
+ # warn "reusing delta: ". $delta->{count} if defined $delta->{delta};
+ # warn Dumper( $delta );
+
+ if ( $#{ $set->{list} } != 0 || $set->is_too_complex )
+ {
+ return $set->iterate(
+ sub {
+ $_[0]->_recurrence(
+ $callback_next, $callback_previous, $delta )
+ } );
+ }
+ # $set is a span
+ my $result;
+ if ($set->min != NEG_INFINITY && $set->max != INFINITY)
+ {
+ # print STDERR " finite set\n";
+ my ($min, $min_open) = $set->min_a;
+ my ($max, $max_open) = $set->max_a;
+
+ my ( $min1, $min2 );
+ $min1 = $callback_next->( $min );
+ if ( ! $min_open )
+ {
+ $min2 = $callback_previous->( $min1 );
+ $min1 = $min2 if defined $min2 && $min == $min2;
+ }
+
+ $result = $set->new();
+
+ # get "delta" - abort if this will take too much time.
+
+ unless ( defined $delta->{max_delta} )
+ {
+ for ( $delta->{count} .. 10 )
+ {
+ if ( $max_open )
+ {
+ return $result if $min1 >= $max;
+ }
+ else
+ {
+ return $result if $min1 > $max;
+ }
+ push @{ $result->{list} },
+ { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
+ $min2 = $callback_next->( $min1 );
+
+ if ( $delta->{delta} )
+ {
+ $delta->{delta} += $min2 - $min1;
+ }
+ else
+ {
+ $delta->{delta} = $min2 - $min1;
+ }
+ $delta->{count}++;
+ $min1 = $min2;
+ }
+
+ $delta->{max_delta} = $delta->{delta} * 40;
+ }
+
+ if ( $max < $min + $delta->{max_delta} )
+ {
+ for ( 1 .. 200 )
+ {
+ if ( $max_open )
+ {
+ return $result if $min1 >= $max;
+ }
+ else
+ {
+ return $result if $min1 > $max;
+ }
+ push @{ $result->{list} },
+ { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
+ $min1 = $callback_next->( $min1 );
+ }
+ }
+
+ # cluck "give up";
+ }
+
+ # return a "_function", such that we can backtrack later.
+ my $func = $set->_function( '_recurrence', $callback_next, $callback_previous, $delta );
+
+ # removed - returning $result doesn't help on speed
+ ## return $func->_function2( 'union', $result ) if $result;
+
+ return $func;
+}
+
+sub is_forever
+{
+ $#{ $_[0]->{list} } == 0 &&
+ $_[0]->max == INFINITY &&
+ $_[0]->min == NEG_INFINITY
+}
+
+sub _is_recurrence
+{
+ exists $_[0]->{method} &&
+ $_[0]->{method} eq '_recurrence' &&
+ $_[0]->{parent}->is_forever
+}
+
+sub intersection
+{
+ my ($s1, $s2) = (shift,shift);
+
+ if ( exists $s1->{method} && $s1->{method} eq '_recurrence' )
+ {
+ # optimize: recurrence && span
+ return $s1->{parent}->
+ intersection( $s2, @_ )->
+ _recurrence( @{ $s1->{param} } )
+ unless ref($s2) && exists $s2->{method};
+
+ # optimize: recurrence && recurrence
+ if ( $s1->{parent}->is_forever &&
+ ref($s2) && _is_recurrence( $s2 ) )
+ {
+ my ( $next1, $previous1 ) = @{ $s1->{param} };
+ my ( $next2, $previous2 ) = @{ $s2->{param} };
+ return $s1->{parent}->_function( '_recurrence',
+ sub {
+ # intersection of parent 'next' callbacks
+ my ($n1, $n2);
+ my $iterate = 0;
+ $n2 = $next2->( $_[0] );
+ while(1) {
+ $n1 = $next1->( $previous1->( $n2 ) );
+ return $n1 if $n1 == $n2;
+ $n2 = $next2->( $previous2->( $n1 ) );
+ return if $iterate++ == $max_iterate;
+ }
+ },
+ sub {
+ # intersection of parent 'previous' callbacks
+ my ($p1, $p2);
+ my $iterate = 0;
+ $p2 = $previous2->( $_[0] );
+ while(1) {
+ $p1 = $previous1->( $next1->( $p2 ) );
+ return $p1 if $p1 == $p2;
+ $p2 = $previous2->( $next2->( $p1 ) );
+ return if $iterate++ == $max_iterate;
+ }
+ },
+ );
+ }
+ }
+ return $s1->SUPER::intersection( $s2, @_ );
+}
+
+sub union
+{
+ my ($s1, $s2) = (shift,shift);
+ if ( $s1->_is_recurrence &&
+ ref($s2) && _is_recurrence( $s2 ) )
+ {
+ # optimize: recurrence || recurrence
+ my ( $next1, $previous1 ) = @{ $s1->{param} };
+ my ( $next2, $previous2 ) = @{ $s2->{param} };
+ return $s1->{parent}->_function( '_recurrence',
+ sub { # next
+ my $n1 = $next1->( $_[0] );
+ my $n2 = $next2->( $_[0] );
+ return $n1 < $n2 ? $n1 : $n2;
+ },
+ sub { # previous
+ my $p1 = $previous1->( $_[0] );
+ my $p2 = $previous2->( $_[0] );
+ return $p1 > $p2 ? $p1 : $p2;
+ },
+ );
+ }
+ return $s1->SUPER::union( $s2, @_ );
+}
+
+=head1 NAME
+
+Set::Infinite::_recurrence - Extends Set::Infinite with recurrence functions
+
+=head1 SYNOPSIS
+
+ $recurrence = $base_set->_recurrence ( \&next, \&previous );
+
+=head1 DESCRIPTION
+
+This is an internal class used by the DateTime::Set module.
+The API is subject to change.
+
+It provides all functionality provided by Set::Infinite, plus the ability
+to define recurrences with arbitrary objects, such as dates.
+
+=head1 METHODS
+
+=over 4
+
+=item * _recurrence ( \&next, \&previous )
+
+Creates a recurrence set. The set is defined inside a 'base set'.
+
+ $recurrence = $base_set->_recurrence ( \&next, \&previous );
+
+The recurrence functions take one argument, and return the 'next' or
+the 'previous' occurence.
+
+Example: defines the set of all 'integer numbers':
+
+ use strict;
+
+ use Set::Infinite::_recurrence;
+ use POSIX qw(floor);
+
+ # define the recurrence span
+ my $forever = Set::Infinite::_recurrence->new(
+ Set::Infinite::_recurrence::NEG_INFINITY,
+ Set::Infinite::_recurrence::INFINITY
+ );
+
+ my $recurrence = $forever->_recurrence(
+ sub { # next
+ floor( $_[0] + 1 )
+ },
+ sub { # previous
+ my $tmp = floor( $_[0] );
+ $tmp < $_[0] ? $tmp : $_[0] - 1
+ },
+ );
+
+ print "sample recurrence ",
+ $recurrence->intersection( -5, 5 ), "\n";
+ # sample recurrence -5,-4,-3,-2,-1,0,1,2,3,4,5
+
+ {
+ my $x = 234.567;
+ print "next occurence after $x = ",
+ $recurrence->{param}[0]->( $x ), "\n"; # 235
+ print "previous occurence before $x = ",
+ $recurrence->{param}[2]->( $x ), "\n"; # 234
+ }
+
+ {
+ my $x = 234;
+ print "next occurence after $x = ",
+ $recurrence->{param}[0]->( $x ), "\n"; # 235
+ print "previous occurence before $x = ",
+ $recurrence->{param}[2]->( $x ), "\n"; # 233
+ }
+
+=item * is_forever
+
+Returns true if the set is a single span,
+ranging from -Infinity to Infinity.
+
+=item * _is_recurrence
+
+Returns true if the set is an unbounded recurrence,
+ranging from -Infinity to Infinity.
+
+=back
+
+=head1 CONSTANTS
+
+=over 4
+
+=item * INFINITY
+
+The C<Infinity> value.
+
+=item * NEG_INFINITY
+
+The C<-Infinity> value.
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+The recurrence generation algorithm is based on an idea from Dave Rolsky.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can distribute it and/or
+modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file
+included with this module.
+
+=head1 SEE ALSO
+
+Set::Infinite
+
+DateTime::Set
+
+For details on the Perl DateTime Suite project please see
+L<http://datetime.perl.org>.
+
+=cut
+
projects / kivitendo-erp.git / commitdiff