From 03fc848dccbb1c0100b1f72a899b7087234b7029 Mon Sep 17 00:00:00 2001 From: Moritz Bunkus Date: Fri, 29 Oct 2010 14:14:18 +0200 Subject: [PATCH] =?utf8?q?Perl-Module=20zum=20Parsen=20von=20Cron-Eintr?= =?utf8?q?=C3=A4gen?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- modules/fallback/DateTime/Event/Cron.pm | 885 ++++++++ modules/fallback/DateTime/Set.pm | 1149 +++++++++++ modules/fallback/DateTime/Span.pm | 501 +++++ modules/fallback/DateTime/SpanSet.pm | 945 +++++++++ modules/fallback/Set/Crontab.pm | 160 ++ modules/fallback/Set/Infinite.pm | 1921 ++++++++++++++++++ modules/fallback/Set/Infinite/Arithmetic.pm | 367 ++++ modules/fallback/Set/Infinite/Basic.pm | 1157 +++++++++++ modules/fallback/Set/Infinite/_recurrence.pm | 404 ++++ 9 files changed, 7489 insertions(+) create mode 100644 modules/fallback/DateTime/Event/Cron.pm create mode 100644 modules/fallback/DateTime/Set.pm create mode 100644 modules/fallback/DateTime/Span.pm create mode 100644 modules/fallback/DateTime/SpanSet.pm create mode 100644 modules/fallback/Set/Crontab.pm create mode 100644 modules/fallback/Set/Infinite.pm create mode 100644 modules/fallback/Set/Infinite/Arithmetic.pm create mode 100644 modules/fallback/Set/Infinite/Basic.pm create mode 100644 modules/fallback/Set/Infinite/_recurrence.pm diff --git a/modules/fallback/DateTime/Event/Cron.pm b/modules/fallback/DateTime/Event/Cron.pm new file mode 100644 index 000000000..a835aa7c9 --- /dev/null +++ b/modules/fallback/DateTime/Event/Cron.pm @@ -0,0 +1,885 @@ +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 and extensions described in L. 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 for methods provided by Set objects, such as +C and C. + +=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 and C 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 Esisk@mojotoad.comE + +=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 diff --git a/modules/fallback/DateTime/Set.pm b/modules/fallback/DateTime/Set.pm new file mode 100644 index 000000000..05fac96e9 --- /dev/null +++ b/modules/fallback/DateTime/Set.pm @@ -0,0 +1,1149 @@ + +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, which handles a continuous +range as opposed to individual datetime points. There is also a module +C 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, or from a +C class. + +C 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 parameter is optional. It must be a C object. + +The span can also be specified using C / C and C +/ C parameters, as in the C constructor. In this +case, if there is a C 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, or from +one of the C classes. The parameter can also +be a C or a C +object. + +The recurrence must return the I 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. + +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 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 and +C objects, in order to define I. 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 parameters. See above. + +See also C and the other +C 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 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 method. + + $meetings_2004 = $meetings_2003->clone->add( years => 1 ); + +=item * subtract_duration( $duration_object ) + +When given a C object, this method simply calls +C on that object and passes that new duration to the +C method. + +=item * subtract( DateTime::Duration->new parameters ) + +Like C, this is syntactic sugar for the C +method. + +=item * set_time_zone( $tz ) + +This method will attempt to apply the C method to every +datetime in the set. + +=item * set( locale => .. ) + +This method can be used to change the C of a datetime set. + +=item * min + +=item * max + +The first and last C in the set. These methods may return +C if the set is empty. It is also possible that these methods +may return a C or +C object. + +These methods return just a I 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 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 +parameter. This should be a C 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 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 or C method will return C when there +are no more datetimes in the iterator. + +=item * as_list + +Returns the set elements as a list of C objects. Just as +with the C method, the C method can be limited +by a span. + + my @dt = $set->as_list( span => $span ); + +Applying C to a large recurrence set is a very expensive +operation, both in CPU time and in the memory used. If you I +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 sets, C will return C. 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 objects in the set. Just as with the +C method, the C 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 to a large recurrence set is a very expensive +operation, both in CPU time and in the memory used. If you I +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 sets, C will return C. 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 list, a +C, a C, or a C +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 of a C with a C or a +C object returns a C object. + +If C is called without any arguments, then the result is a +C object representing the spans between each of the +set's elements. If complement is given an argument, then the return +value is a C object representing the I +between the sets. + +All other operations will always return a C. + +=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 list, a C, a +C, or a C 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 method returns C<$dt> if $dt is an event, otherwise +it returns the previous event. + +The C 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 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 inside the subroutine may happen later than you +expect. + +The callback return value is expected to be within the span of the +C and the C element in the original set. This is a +limitation of the backtracking algorithm used in the C +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 inside the subroutine may happen later than you +expect. + +=item * iterate ( sub { ... } ) + +I + +=back + +=head1 SUPPORT + +Support is offered through the C mailing list. + +Please report bugs using rt.cpan.org + +=head1 AUTHOR + +Flavio Soibelmann Glock + +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. + +=cut + diff --git a/modules/fallback/DateTime/Span.pm b/modules/fallback/DateTime/Span.pm new file mode 100644 index 000000000..5917a8a19 --- /dev/null +++ b/modules/fallback/DateTime/Span.pm @@ -0,0 +1,501 @@ +# 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 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, which is made of individual +datetime points as opposed to a range. There is also a module +C 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 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 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 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 time is adjusted in order +to leave the local time untouched. + +=item * duration + +The total size of the set, as a C object, or as a +scalar containing infinity. + +Also available as C. + +=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 or a Cxs object. + +If the set ends C 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 +objects, but also with C and C +objects. These set operations always return a C +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, C, +C, or C object as an argument. + +=back + +=head1 SUPPORT + +Support is offered through the C mailing list. + +Please report bugs using rt.cpan.org + +=head1 AUTHOR + +Flavio Soibelmann Glock + +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. + +=cut + diff --git a/modules/fallback/DateTime/SpanSet.pm b/modules/fallback/DateTime/SpanSet.pm new file mode 100644 index 000000000..8a258f1fb --- /dev/null +++ b/modules/fallback/DateTime/SpanSet.pm @@ -0,0 +1,945 @@ +# 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 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, 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 objects. + + $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span ] ); + +=item * from_set_and_duration + +Creates a new span set from one or more C objects and a +duration. + +The duration can be a C object, or the parameters +to create a new C 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 objects. + +One set defines the I, and the other defines the I. + + $spanset = + DateTime::SpanSet->from_sets + ( start_set => $dt_set1, end_set => $dt_set2 ); + +The spans have the starting date C, and the end date C, +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 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 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 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 object. + +The duration may be infinite. + +Also available as C. + +=item * span + +The total span of the set, as a C 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, or C 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, or C 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, or C 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 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, or C 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 objects. + + my @dt_span = $set->as_list( span => $span ); + +Just as with the C method, the C method can be +limited by a span. + +Applying C to a large recurring spanset is a very expensive +operation, both in CPU time and in the memory used. + +For this reason, when C operates on large recurrence sets, +it will return at most approximately 200 spans. For larger sets, and +for I sets, C will return C. + +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 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 +objects, but also with C, C and +C objects. These set operations always return a +C 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 list, a C, a +C, or a C object as an argument. + + $set = $set1->intersected_spans( $set2 ); + +The method always returns a C object, containing +all spans that are intersected by the given set. + +Unlike the C 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, C, +C, or C 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 +parameter. This should be a C 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 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 or C methods will return C when there +are no more spans in the iterator. + +=item * start_set + +=item * end_set + +These methods do the inverse of the C method: + +C retrieves a DateTime::Set with the start datetime of each +span. + +C 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 inside the subroutine +may happen later than you expect. + +The callback return value is expected to be within the span of the +C and the C 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 inside the subroutine +may happen later than you expect. + +=item * iterate + +I + +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 object. + +If the callback returns C, 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 and the C 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 inside the subroutine +may happen later than you expect. + +=back + +=head1 SUPPORT + +Support is offered through the C mailing list. + +Please report bugs using rt.cpan.org + +=head1 AUTHOR + +Flavio Soibelmann Glock + +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. + +=cut + diff --git a/modules/fallback/Set/Crontab.pm b/modules/fallback/Set/Crontab.pm new file mode 100644 index 000000000..033d20d2d --- /dev/null +++ b/modules/fallback/Set/Crontab.pm @@ -0,0 +1,160 @@ +# Copyright 2001 Abhijit Menon-Sen + +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. A few extensions to the standard syntax are described +below. + +=over 4 + +=item < and > + +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 + +=head1 AUTHOR + +Abhijit Menon-Sen + +Copyright 2001 Abhijit Menon-Sen + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. diff --git a/modules/fallback/Set/Infinite.pm b/modules/fallback/Set/Infinite.pm new file mode 100644 index 000000000..72bda52a8 --- /dev/null +++ b/modules/fallback/Set/Infinite.pm @@ -0,0 +1,1921 @@ +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 method expects I parameters. + +If you have unordered ranges, you can build the set using C: + + @ranges = ( [ 10, 20 ], [ -10, 1 ] ); + $set = Set::Infinite->new; + $set = $set->union( @$_ ) for @ranges; + +The data structures passed to C must be I. +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 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. + +=head2 comparison + + sort + + > < == >= <= <=> + +See also: C 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 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