crm
/users/datev-export*
/users/templates-cache/
+/users/pid/
+/config/task_server.conf
+/config/periodic_invoices.conf
--- /dev/null
+package SL::BackgroundJob::ALL;
+
+use strict;
+
+use SL::BackgroundJob::Base;
+use SL::BackgroundJob::CleanBackgroundJobHistory;
+use SL::BackgroundJob::CreatePeriodicInvoices;
+
+1;
+
--- /dev/null
+package SL::BackgroundJob::Base;
+
+use strict;
+
+use parent qw(Rose::Object);
+
+use SL::DB::BackgroundJob;
+
+sub create_standard_job {
+ my $self_or_class = shift;
+ my $cron_spec = shift;
+
+ my $package = ref($self_or_class) || $self_or_class;
+ $package =~ s/SL::BackgroundJob:://;
+
+ my %params = (cron_spec => $cron_spec || '* * * * *',
+ type => 'interval',
+ active => 1,
+ package_name => $package);
+
+ my $job = SL::DB::Manager::BackgroundJob->find_by(package_name => $params{package_name});
+ if (!$job) {
+ $job = SL::DB::BackgroundJob->new(%params)->update_next_run_at;
+ } else {
+ $job->assign_attributes(%params)->update_next_run_at;
+ }
+
+ return $job;
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+SL::BackgroundJob::Base - Base class for all background jobs
+
+=head1 SYNOPSIS
+
+All background jobs are derived from this class. Each job gets its own
+class which must implement the C<run> method.
+
+There are two types of background jobs: periodic jobs and jobs that
+are run once. Periodic jobs have a CRON spec associated with them that
+determines the points in time when the job is supposed to be run.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<create_standard_job $cron_spec>
+
+Creates or updates an entry in the database for the current job. If
+the C<background_jobs> table contains an entry for the current class
+(as determined by C<ref($self)>) then that entry is updated and
+re-activated if it was disabled. Otherwise a new entry is created.
+
+This function can be called both as a member or as a class function.
+
+=back
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
--- /dev/null
+package SL::BackgroundJob::CleanBackgroundJobHistory;
+
+use strict;
+
+use parent qw(SL::BackgroundJob::Base);
+
+use SL::DB::BackgroundJobHistory;
+
+sub create_job {
+ $_[0]->create_standard_job('0 3 * * *'); # daily at 3:00 am
+}
+
+sub run {
+ my $self = shift;
+ my $db_obj = shift;
+
+ my $options = $db_obj->data_as_hash;
+ $options->{retention_success} ||= 14;
+ $options->{retention_failure} ||= 3 * 30;
+
+ my $today = DateTime->today_local;
+
+ for my $status (qw(success failure)) {
+ SL::DB::Manager::BackgroundJobHistory->delete_all(where => [ status => $status,
+ run_at => { lt => $today->clone->subtract(days => $options->{"retention_${status}"}) } ]);
+ }
+
+ return 1;
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+SL::BackgroundJob::CleanBackgroundJobHistory - Background job for
+cleaning the history table of all executed jobs
+
+=head1 SYNOPSIS
+
+This background job deletes old entries from the table
+C<background_job_histories>. Each time a job is run an entry is
+created in that table.
+
+The associated C<SL::DB::BackgroundJob> instance's C<data> may be a
+hash containing the retention periods for successful and failed
+jobs. Both are the number of days a history entry is to be kept. C<<
+$data->{retention_success} >> defaults to 14. C<<
+$data->{retention_failure} >> defaults to 90.
+
+The job is supposed to run once a day.
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
--- /dev/null
+package SL::BackgroundJob::CreatePeriodicInvoices;
+
+use strict;
+
+use parent qw(SL::BackgroundJob::Base);
+
+use Config::Std;
+use English qw(-no_match_vars);
+
+use SL::DB::AuthUser;
+use SL::DB::Order;
+use SL::DB::Invoice;
+use SL::DB::PeriodicInvoice;
+use SL::DB::PeriodicInvoicesConfig;
+use SL::Mailer;
+
+sub create_job {
+ $_[0]->create_standard_job('0 3 1 * *'); # first day of month at 3:00 am
+}
+
+sub run {
+ my $self = shift;
+ $self->{db_obj} = shift;
+
+ my $configs = SL::DB::Manager::PeriodicInvoicesConfig->get_all(where => [ active => 1 ]);
+
+ foreach my $config (@{ $configs }) {
+ my $new_end_date = $config->handle_automatic_extension;
+ _log_msg("Periodic invoice configuration ID " . $config->id . " extended through " . $new_end_date->strftime('%d.%m.%Y') . "\n") if $new_end_date;
+ }
+
+ my (@new_invoices, @invoices_to_print);
+
+ _log_msg("Number of configs: " . scalar(@{ $configs}));
+
+ foreach my $config (@{ $configs }) {
+ # A configuration can be set to inactive by
+ # $config->handle_automatic_extension. Therefore the check in
+ # ...->get_all() does not suffice.
+ _log_msg("Config " . $config->id . " active " . $config->active);
+ next unless $config->active;
+
+ my @dates = _calculate_dates($config);
+
+ _log_msg("Dates: " . join(' ', map { $_->to_lxoffice } @dates));
+
+ foreach my $date (@dates) {
+ my $invoice = $self->_create_periodic_invoice($config, $date);
+ next unless $invoice;
+
+ _log_msg("Invoice " . $invoice->invnumber . " posted for config ID " . $config->id . ", period start date " . $::locale->format_date(\%::myconfig, $date) . "\n");
+ push @new_invoices, $invoice;
+ push @invoices_to_print, [ $invoice, $config ] if $config->print;
+
+ # last;
+ }
+ }
+
+ map { _print_invoice(@{ $_ }) } @invoices_to_print;
+
+ _send_email(\@new_invoices, [ map { $_->[0] } @invoices_to_print ]) if @new_invoices;
+
+ return 1;
+}
+
+sub _log_msg {
+ # my $message = join('', @_);
+ # $message .= "\n" unless $message =~ m/\n$/;
+ # $::lxdebug->message(0, $message);
+}
+
+sub _generate_time_period_variables {
+ my $config = shift;
+ my $period_start_date = shift;
+ my $period_end_date = $period_start_date->clone->truncate(to => 'month')->add(months => $config->get_period_length)->subtract(days => 1);
+
+ my @month_names = ('',
+ 'Januar', 'Februar', 'März', 'April', 'Mai', 'Juni',
+ 'Juli', 'August', 'September', 'Oktober', 'November', 'Dezember');
+
+ my $vars = { current_quarter => $period_start_date->quarter,
+ previous_quarter => $period_start_date->clone->subtract(months => 3)->quarter,
+ next_quarter => $period_start_date->clone->add( months => 3)->quarter,
+
+ current_month => $period_start_date->month,
+ previous_month => $period_start_date->clone->subtract(months => 1)->month,
+ next_month => $period_start_date->clone->add( months => 1)->month,
+
+ current_year => $period_start_date->year,
+ previous_year => $period_start_date->year - 1,
+ next_year => $period_start_date->year + 1,
+
+ period_start_date => $::locale->format_date(\%::myconfig, $period_start_date),
+ period_end_date => $::locale->format_date(\%::myconfig, $period_end_date),
+ };
+
+ map { $vars->{"${_}_month_long"} = $month_names[ $vars->{"${_}_month"} ] } qw(current previous next);
+
+ return $vars;
+}
+
+sub _replace_vars {
+ my $object = shift;
+ my $vars = shift;
+ my $sub = shift;
+ my $str = $object->$sub;
+
+ my ($key, $value);
+ $str =~ s|<\%${key}\%>|$value|g while ($key, $value) = each %{ $vars };
+ $object->$sub($str);
+}
+
+sub _create_periodic_invoice {
+ my $self = shift;
+ my $config = shift;
+ my $period_start_date = shift;
+
+ my $time_period_vars = _generate_time_period_variables($config, $period_start_date);
+
+ my $invdate = DateTime->today_local;
+
+ my $order = $config->order;
+ my $invoice;
+ if (!$self->{db_obj}->db->do_transaction(sub {
+ 1; # make Emacs happy
+
+ $invoice = SL::DB::Invoice->new_from($order);
+
+ my $intnotes = $invoice->intnotes ? $invoice->intnotes . "\n\n" : '';
+ $intnotes .= "Automatisch am " . $invdate->to_lxoffice . " erzeugte Rechnung";
+
+ $invoice->assign_attributes(deliverydate => $period_start_date,
+ intnotes => $intnotes,
+ );
+
+ map { _replace_vars($invoice, $time_period_vars, $_) } qw(notes intnotes transaction_description);
+
+ foreach my $item (@{ $invoice->items }) {
+ map { _replace_vars($item, $time_period_vars, $_) } qw(description longdescription);
+ }
+
+ $invoice->post(ar_id => $config->ar_chart_id) || die;
+
+ $order->link_to_record($invoice);
+
+ SL::DB::PeriodicInvoice->new(config_id => $config->id,
+ ar_id => $invoice->id,
+ period_start_date => $period_start_date)
+ ->save;
+
+ # die $invoice->transaction_description;
+ })) {
+ $::lxdebug->message(LXDebug->WARN(), "_create_invoice failed: " . join("\n", (split(/\n/, $self->{db_obj}->db->error))[0..2]));
+ return undef;
+ }
+
+ return $invoice;
+}
+
+sub _calculate_dates {
+ my $config = shift;
+
+ my $cur_date = $config->start_date;
+ my $start_date = $config->get_previous_invoice_date || DateTime->new(year => 1970, month => 1, day => 1);
+ my $end_date = $config->end_date || DateTime->new(year => 2100, month => 1, day => 1);
+ my $tomorrow = DateTime->today_local->add(days => 1);
+ my $period_len = $config->get_period_length;
+
+ $end_date = $tomorrow if $end_date > $tomorrow;
+
+ my @dates;
+
+ while (1) {
+ last if $cur_date >= $end_date;
+
+ push @dates, $cur_date->clone if $cur_date > $start_date;
+
+ $cur_date->add(months => $period_len);
+ }
+
+ return @dates;
+}
+
+sub _send_email {
+ my ($posted_invoices, $printed_invoices) = @_;
+
+ read_config 'config/periodic_invoices.conf' => my %config;
+
+ return if !$config{periodic_invoices} || !$config{periodic_invoices}->{send_email_to} || !scalar @{ $posted_invoices };
+
+ my $user = SL::DB::Manager::AuthUser->find_by(login => $config{periodic_invoices}->{send_email_to});
+ my $email = $user ? $user->get_config_value('email') : undef;
+
+ return unless $email;
+
+ my $template = Template->new({ 'INTERPOLATE' => 0,
+ 'EVAL_PERL' => 0,
+ 'ABSOLUTE' => 1,
+ 'CACHE_SIZE' => 0,
+ });
+
+ return unless $template;
+
+ my $email_template = $config{periodic_invoices}->{email_template};
+ my $filename = $email_template || ( ($user->get_config_value('templates') || "templates/webpages") . "/periodic_invoices_email.txt" );
+ my %params = ( POSTED_INVOICES => $posted_invoices,
+ PRINTED_INVOICES => $printed_invoices );
+
+ my $output;
+ $template->process($filename, \%params, \$output);
+
+ my $mail = Mailer->new;
+ $mail->{from} = $config{periodic_invoices}->{email_from};
+ $mail->{to} = $email;
+ $mail->{subject} = $config{periodic_invoices}->{email_subject};
+ $mail->{content_type} = $filename =~ m/.html$/ ? 'text/html' : 'text/plain';
+ $mail->{message} = $output;
+
+ $mail->send;
+}
+
+sub _print_invoice {
+ my ($invoice, $config) = @_;
+
+ return unless $config->print && $config->printer_id && $config->printer->printer_command;
+
+ my $form = Form->new;
+ $invoice->flatten_to_form($form, format_amounts => 1);
+
+ $form->{printer_code} = $config->printer->template_code;
+ $form->{copies} = $config->copies;
+ $form->{formname} = $form->{type};
+ $form->{format} = 'pdf';
+ $form->{media} = 'printer';
+ $form->{OUT} = "| " . $config->printer->printer_command;
+
+ $form->prepare_for_printing;
+
+ $form->throw_on_error(sub {
+ eval {
+ $form->parse_template(\%::myconfig, $::userspath);
+ 1;
+ } || die $EVAL_ERROR->{error};
+ });
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::BackgroundJob::CleanBackgroundJobHistory - Create periodic
+invoices for orders
+
+=head1 SYNOPSIS
+
+Iterate over all periodic invoice configurations, extend them if
+applicable, calculate the dates for which invoices have to be posted
+and post those invoices by converting the order into an invoice for
+each date.
+
+=head1 TOTO
+
+=over 4
+
+=item *
+
+Strings like month names are hardcoded to German in this file.
+
+=back
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
--- /dev/null
+package SL::BackgroundJob::Test;
+
+use strict;
+
+use parent qw(SL::BackgroundJob::Base);
+
+sub run {
+ my $self = shift;
+ my $db_obj = shift;
+
+ $::lxdebug->message(0, "Test job is being executed.");
+}
+
+1;
my $db = __PACKAGE__->new_or_cached(domain => $domain, type => $type);
+ _execute_initial_sql($db);
+
return $db;
}
+my %_dateformats = ( 'yy-mm-dd' => 'ISO',
+ 'yyyy-mm-dd' => 'ISO',
+ 'mm/dd/yy' => 'SQL, US',
+ 'mm-dd-yy' => 'POSTGRES, US',
+ 'dd/mm/yy' => 'SQL, EUROPEAN',
+ 'dd-mm-yy' => 'POSTGRES, EUROPEAN',
+ 'dd.mm.yy' => 'GERMAN'
+ );
+
sub _register_db {
my $domain = shift;
my $type = shift;
my %connect_settings;
+ my $initial_sql;
if (!%::myconfig) {
$type = 'LXOFFICE_EMPTY';
connect_options => { pg_enable_utf8 => $::locale && $::locale->is_utf8,
});
} else {
+ my $european_dates = 0;
+ if ($::myconfig{dateformat}) {
+ $european_dates = 1 if $_dateformats{ $::myconfig{dateformat} } =~ m/european/i;
+ }
+
%connect_settings = ( driver => $::myconfig{dbdriver} || 'Pg',
database => $::myconfig{dbname},
host => $::myconfig{dbhost},
username => $::myconfig{dbuser},
password => $::myconfig{dbpasswd},
connect_options => { pg_enable_utf8 => $::locale && $::locale->is_utf8,
- });
+ },
+ european_dates => $european_dates);
}
+ my %flattened_settings = _flatten_settings(%connect_settings);
+
$domain = 'LXOFFICE' if $type =~ m/^LXOFFICE/;
- $type .= join($SUBSCRIPT_SEPARATOR, map { $::connect_setings{$_} } sort keys %connect_settings);
+ $type .= join($SUBSCRIPT_SEPARATOR, map { ($_, $flattened_settings{$_}) } sort keys %flattened_settings);
my $idx = "${domain}::${type}";
if (!$_db_registered{$idx}) {
return ($domain, $type);
}
+sub _execute_initial_sql {
+ my ($db) = @_;
+
+ return if $_initial_sql_executed{$db} || !%::myconfig || !$::myconfig{dateformat};
+
+ $_initial_sql_executed{$db} = 1;
+
+ # Don't rely on dboptions being set properly. Chose them from
+ # dateformat instead.
+ my $pg_dateformat = $_dateformats{ $::myconfig{dateformat} };
+ $db->dbh->do("set DateStyle to '${pg_dateformat}'") if $pg_dateformat;
+}
+
+sub _flatten_settings {
+ my %settings = @_;
+ my %flattened = ();
+
+ while (my ($key, $value) = each %settings) {
+ if ('HASH' eq ref $value) {
+ %flattened = ( %flattened, _flatten_settings(%{ $value }) );
+ } else {
+ $flattened{$key} = $value;
+ }
+ }
+
+ return %flattened;
+}
+
1;
+++ /dev/null
-# This file has been auto-generated only because it didn't exist.
-# Feel free to modify it at will; it will not be overwritten automatically.
-
-package SL::DB::AccTrans;
-
-use strict;
-
-use SL::DB::MetaSetup::AccTrans;
-
-# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
-__PACKAGE__->meta->make_manager_class;
-
-1;
--- /dev/null
+# This file has been auto-generated only because it didn't exist.
+# Feel free to modify it at will; it will not be overwritten automatically.
+
+package SL::DB::AuthGroup;
+
+use strict;
+
+use SL::DB::MetaSetup::AuthGroup;
+use SL::DB::AuthGroupRight;
+
+# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
+__PACKAGE__->meta->make_manager_class;
+
+__PACKAGE__->meta->schema('auth');
+
+__PACKAGE__->meta->add_relationship(
+ users => {
+ type => 'many to many',
+ map_class => 'SL::DB::AuthUserGroup',
+ map_from => 'group',
+ map_to => 'user',
+ },
+ rights => {
+ type => 'one to many',
+ class => 'SL::DB::AuthGroupRight',
+ column_map => { id => 'group_id' },
+ },
+);
+
+__PACKAGE__->meta->initialize;
+
+sub get_employees {
+ my @logins = map { $_->login } $_[0]->users;
+ return @logins ? @{ SL::DB::Manager::Employee->get_all(query => [ login => \@logins ]) } : ();
+}
+
+1;
--- /dev/null
+# This file has been auto-generated only because it didn't exist.
+# Feel free to modify it at will; it will not be overwritten automatically.
+
+package SL::DB::AuthGroupRight;
+
+use strict;
+
+use SL::DB::MetaSetup::AuthGroupRight;
+
+# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
+__PACKAGE__->meta->make_manager_class;
+
+__PACKAGE__->meta->schema('auth');
+__PACKAGE__->meta->initialize;
+
+1;
--- /dev/null
+# This file has been auto-generated only because it didn't exist.
+# Feel free to modify it at will; it will not be overwritten automatically.
+
+package SL::DB::AuthUser;
+
+use strict;
+
+use List::Util qw(first);
+
+use SL::DB::MetaSetup::AuthUser;
+use SL::DB::AuthUserGroup;
+
+# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
+__PACKAGE__->meta->make_manager_class;
+
+__PACKAGE__->meta->schema('auth');
+
+__PACKAGE__->meta->add_relationship(
+ groups => {
+ type => 'many to many',
+ map_class => 'SL::DB::AuthUserGroup',
+ map_from => 'user',
+ map_to => 'group',
+ },
+ configs => {
+ type => 'one to many',
+ class => 'SL::DB::AuthUserConfig',
+ column_map => { id => 'user_id' },
+ },
+);
+
+__PACKAGE__->meta->initialize;
+
+sub get_config_value {
+ my ($self, $key) = @_;
+
+ my $cfg = first { $_->cfg_key eq $key } @{ $self->configs };
+ return $cfg ? $cfg->cfg_value : undef;
+}
+
+1;
--- /dev/null
+# This file has been auto-generated only because it didn't exist.
+# Feel free to modify it at will; it will not be overwritten automatically.
+
+package SL::DB::AuthUserConfig;
+
+use strict;
+
+use SL::DB::MetaSetup::AuthUserConfig;
+
+# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
+__PACKAGE__->meta->make_manager_class;
+
+__PACKAGE__->meta->schema('auth');
+__PACKAGE__->meta->initialize;
+
+1;
--- /dev/null
+# This file has been auto-generated only because it didn't exist.
+# Feel free to modify it at will; it will not be overwritten automatically.
+
+package SL::DB::AuthUserGroup;
+
+use strict;
+
+use SL::DB::MetaSetup::AuthUserGroup;
+
+# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
+__PACKAGE__->meta->make_manager_class;
+
+__PACKAGE__->meta->schema('auth');
+
+__PACKAGE__->meta->add_foreign_keys(
+ user => {
+ class => 'SL::DB::AuthUser',
+ key_columns => { user_id => 'id' },
+ },
+
+ group => {
+ class => 'SL::DB::AuthGroup',
+ key_columns => { group_id => 'id' },
+ },
+);
+
+__PACKAGE__->meta->initialize;
+
+1;
--- /dev/null
+package SL::DB::BackgroundJob;
+
+use strict;
+
+use DateTime::Event::Cron;
+use English qw(-no_match_vars);
+
+use SL::DB::MetaSetup::BackgroundJob;
+use SL::DB::Manager::BackgroundJob;
+
+use SL::DB::BackgroundJobHistory;
+
+use SL::BackgroundJob::Test;
+
+sub update_next_run_at {
+ my $self = shift;
+
+ my $cron = DateTime::Event::Cron->new_from_cron($self->cron_spec || '* * * * *');
+ $self->update_attributes(next_run_at => $cron->next(DateTime->now_local));
+ return $self;
+}
+
+sub run {
+ my $self = shift;
+
+ my $package = "SL::BackgroundJob::" . $self->package_name;
+ my $run_at = DateTime->now_local;
+ my $history;
+
+ my $ok = eval {
+ my $result = $package->new->run($self);
+
+ $history = SL::DB::BackgroundJobHistory
+ ->new(package_name => $self->package_name,
+ run_at => $run_at,
+ status => 'success',
+ result => $result,
+ data => $self->data);
+ $history->save;
+
+ 1;
+ };
+
+ if (!$ok) {
+ my $error = $EVAL_ERROR;
+ $history = SL::DB::BackgroundJobHistory
+ ->new(package_name => $self->package_name,
+ run_at => $run_at,
+ status => 'failure',
+ error_col => $error,
+ data => $self->data);
+ $history->save;
+
+ $::lxdebug->message(LXDebug->WARN(), "BackgroundJob ID " . $self->id . " execution error (first three lines): " . join("\n", (split(m/\n/, $error))[0..2]));
+ }
+
+ $self->assign_attributes(last_run_at => $run_at)->update_next_run_at;
+
+ return $history;
+}
+
+sub data_as_hash {
+ my $self = shift;
+ return {} if !$self->data;
+ return $self->data if ref($self->{data}) eq 'HASH';
+ return YAML::Load($self->{data}) if !ref($self->{data});
+ return {};
+}
+
+1;
--- /dev/null
+# This file has been auto-generated only because it didn't exist.
+# Feel free to modify it at will; it will not be overwritten automatically.
+
+package SL::DB::BackgroundJobHistory;
+
+use strict;
+
+use SL::DB::MetaSetup::BackgroundJobHistory;
+
+# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
+__PACKAGE__->meta->make_manager_class;
+
+1;
use strict;
use SL::DB::MetaSetup::Chart;
+use SL::DB::Manager::Chart;
+use SL::DB::TaxKey;
-__PACKAGE__->meta->make_manager_class;
+__PACKAGE__->meta->add_relationships(taxkeys => { type => 'one to many',
+ class => 'SL::DB::TaxKey',
+ column_map => { id => 'chart_id' },
+ },
+ );
+
+__PACKAGE__->meta->initialize;
+
+sub get_active_taxkey {
+ my ($self, $date) = @_;
+ $date ||= DateTime->today_local;
+ return SL::DB::Manager::TaxKey->get_all(where => [ and => [ chart_id => $self->id,
+ startdate => { le => $date } ] ],
+ sort_by => "startdate DESC")->[0];
+}
1;
+
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::DB::Chart - Rose database model for the "chart" table
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<get_active_taxkey $date>
+
+Returns the active tax key object for a given date. C<$date> defaults
+to the current date if undefined.
+
+=back
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
-# This file has been auto-generated only because it didn't exist.
-# Feel free to modify it at will; it will not be overwritten automatically.
-
package SL::DB::Default;
use strict;
# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
__PACKAGE__->meta->make_manager_class;
+sub get_default_currency {
+ my $self = shift->get;
+ my @currencies = grep { $_ } split(/:/, $self->curr || '');
+ return $currencies[0] || '';
+}
+
+sub get {
+ my ($class_or_self) = @_;
+ return $class_or_self if ref($class_or_self);
+ return SL::DB::Manager::Default->get_all(limit => 1)->[0];
+}
+
1;
use SL::DB::MetaSetup::DeliveryOrder;
use SL::DB::Manager::DeliveryOrder;
+use SL::DB::Helper::LinkedRecords;
+use SL::DB::Helper::TransNumberGenerator;
use SL::DB::Order;
use List::Util qw(first);
column_map => { id => 'trans_id' },
manager_args => { with_objects => [ 'part' ] }
},
+ shipto => { type => 'one to one',
+ class => 'SL::DB::Shipto',
+ column_map => { shipto_id => 'shipto_id' },
+ },
+ department => { type => 'one to one',
+ class => 'SL::DB::Department',
+ column_map => { department_id => 'id' },
+ },
);
__PACKAGE__->meta->initialize;
# methods
+sub items { goto &orderitems; }
+
sub sales_order {
my $self = shift;
my %params = @_;
use SL::DB::MetaSetup::Employee;
use SL::DB::Manager::Employee;
+sub has_right {
+ my $self = shift;
+ my $right = shift;
+
+ return $::auth->check_right($self->login, $right);
+}
1;
use strict;
-use SL::DB::AccTrans;
use SL::DB::AccTransaction;
use SL::DB::Assembly;
use SL::DB::AuditTrail;
+use SL::DB::BackgroundJob;
+use SL::DB::BackgroundJobHistory;
use SL::DB::BankAccount;
use SL::DB::Bin;
use SL::DB::Buchungsgruppe;
use SL::DB::PartsGroup;
use SL::DB::PartsTax;
use SL::DB::PaymentTerm;
+use SL::DB::PeriodicInvoice;
+use SL::DB::PeriodicInvoicesConfig;
use SL::DB::PriceFactor;
use SL::DB::Pricegroup;
use SL::DB::Prices;
--- /dev/null
+package SL::DB::Helper::FlattenToForm;
+
+use strict;
+
+use parent qw(Exporter);
+our @EXPORT = qw(flatten_to_form);
+
+use List::MoreUtils qw(any);
+
+use SL::CVar;
+
+sub flatten_to_form {
+ my ($self, $form, %params) = @_;
+
+ my $vc = $self->can('customer_id') && $self->customer_id ? 'customer' : 'vendor';
+
+ _copy($self, $form, '', '', 0, qw(id type taxzone_id ordnumber quonumber invnumber donumber cusordnumber taxincluded shippingpoint shipvia notes intnotes curr cp_id
+ employee_id salesman_id closed department_id language_id payment_id delivery_customer_id delivery_vendor_id shipto_id proforma
+ globalproject_id delivered transaction_description container_type accepted_by_customer invoice terms storno storno_id dunning_config_id
+ orddate quodate reqdate gldate duedate deliverydate datepaid transdate));
+
+ if (_has($self, 'transdate')) {
+ my $transdate_idx = ref($self) eq 'SL::DB::Order' ? ($self->quotation ? 'quodate' : 'orddate')
+ : ref($self) eq 'SL::DB::Invoice' ? 'invdate'
+ : 'transdate';
+ $form->{$transdate_idx} = $self->transdate->to_lxoffice;
+ }
+
+ $form->{vc} = $vc if ref($self) =~ /^SL::DB::.*Invoice/;
+
+ my @vc_fields = (qw(account_number bank bank_code bic business city contact country creditlimit discount
+ email fax homepage iban language name payment_terms phone street taxnumber zipcode),
+ "${vc}number");
+ my @vc_prefixed_fields = qw(email fax notes number phone);
+
+ _copy($self, $form, '', '', 1, qw(amount netamount marge_total marge_percent container_remaining_weight container_remaining_volume paid));
+ _copy($self->$vc, $form, '', '', 0, @vc_fields);
+ _copy($self->$vc, $form, $vc, '', 0, @vc_prefixed_fields);
+ _copy($self->contact, $form, '', '', 0, grep { /^cp_/ } map { $_->name } SL::DB::Contact->meta->columns) if _has($self, 'cp_id');
+ _copy($self->shipto, $form, '', '', 0, grep { /^shipto/ } map { $_->name } SL::DB::Shipto->meta->columns) if _has($self, 'shipto_id');
+ _copy($self->globalproject, $form, 'globalproject', '', 0, qw(number description)) if _has($self, 'globalproject_id');
+ _copy($self->employee, $form, 'employee', '', 0, map { $_->name } SL::DB::Employee->meta->columns) if _has($self, 'employee_id');
+ _copy($self->salesman, $form, 'salesman', '', 0, map { $_->name } SL::DB::Employee->meta->columns) if _has($self, 'salesman_id');
+ _copy($self->acceptance_confirmed_by, $form, 'acceptance_confirmed_by_', '', 0, map { $_->name } SL::DB::Employee->meta->columns) if _has($self, 'acceptance_confirmed_by_id');
+
+ $form->{employee} = $self->employee->name if _has($self, 'employee_id');
+ $form->{language} = $self->language->template_code if _has($self, 'language_id');
+ $form->{department} = $self->department->description if _has($self, 'department_id');
+ $form->{rowcount} = scalar(@{ $self->items });
+
+ my $idx = 0;
+ my $format_amounts = $params{format_amounts};
+ foreach my $item (@{ $self->items }) {
+ next if _has($item, 'assemblyitem');
+
+ $idx++;
+
+ $form->{"id_${idx}"} = $item->parts_id;
+ $form->{"number_${idx}"} = $item->part->partnumber;
+ _copy($item, $form, '', "_${idx}", 0, qw(description project_id ship serialnumber pricegroup_id ordnumber cusordnumber unit
+ subtotal longdescription price_factor_id marge_price_factor approved_sellprice reqdate transdate));
+ _copy($item, $form, '', "_${idx}", $format_amounts, qw(qty sellprice discount marge_total marge_percent lastcost));
+ _copy($item->project, $form, 'project', "_${idx}", 0, qw(number description)) if _has($item, 'project_id');
+
+ _copy_custom_variables($item, $form, 'ic_cvar_', "_${idx}");
+ }
+
+ _copy_custom_variables($self, $form, 'vc_cvar_', '');
+
+ return $self;
+}
+
+sub _has {
+ my ($obj, $column) = @_;
+ return $obj->can($column) && $obj->$column;
+}
+
+sub _copy {
+ my ($src, $form, $prefix, $postfix, $format_amounts, @columns) = @_;
+
+ map { $form->{"${prefix}${_}${postfix}"} = ref($src->$_) eq 'DateTime' ? $src->$_->to_lxoffice : $src->$_ if $src->can($_) } @columns if !$format_amounts;
+ map { $form->{"${prefix}${_}${postfix}"} = $::form->format_amount(\%::myconfig, $src->$_ * 1, 2) if $src->can($_) } @columns if $format_amounts;
+
+ return $src;
+}
+
+sub _copy_custom_variables {
+ my ($src, $form, $prefix, $postfix) = @_;
+
+ my ($module, $sub_module, $trans_id) = ref($src) eq 'SL::DB::OrderItem' ? ('IC', 'orderitems', $src->id)
+ : ref($src) eq 'SL::DB::DeliveryOrderItem' ? ('IC', 'delivery_order_items', $src->id)
+ : ref($src) eq 'SL::DB::InvoiceItem' ? ('IC', 'invoice', $src->id)
+ : ('CT', undef, _has($src, 'customer_id') ? $src->customer_id : $src->vendor_id);
+
+ return unless $trans_id;
+
+ my $cvars = CVar->get_custom_variables(dbh => $src->db->dbh,
+ module => $module,
+ sub_module => $sub_module,
+ trans_id => $trans_id,
+ );
+ map { $form->{ $prefix . $_->{name} . $postfix } = $_->{value} } @{ $cvars };
+
+ return $src;
+}
+
+1;
--- /dev/null
+package SL::DB::Helper::LinkedRecords;
+
+use strict;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(linked_records link_to_record);
+
+use Carp;
+use Sort::Naturally;
+
+use SL::DB::Helper::Mappings;
+use SL::DB::RecordLink;
+
+sub linked_records {
+ my ($self, %params) = @_;
+
+ my %sort_spec = ( by => delete($params{sort_by}),
+ dir => delete($params{sort_dir}) );
+ my $filter = delete $params{filter};
+
+ my $records = linked_records_implementation($self, %params);
+ $records = filter_linked_records($self, $filter, @{ $records }) if $filter;
+ $records = sort_linked_records($self, $sort_spec{by}, $sort_spec{dir}, @{ $records }) if $sort_spec{by};
+
+ return $records;
+}
+
+sub linked_records_implementation {
+ my $self = shift;
+ my %params = @_;
+
+ my $wanted = $params{direction} || croak("Missing parameter `direction'");
+
+ if ($wanted eq 'both') {
+ my $both = delete($params{both});
+ my %from_to = ( from => delete($params{from}) || $both,
+ to => delete($params{to}) || $both);
+
+ my @records = (@{ linked_records_implementation($self, %params, direction => 'from', from => $from_to{from}) },
+ @{ linked_records_implementation($self, %params, direction => 'to', to => $from_to{to} ) });
+
+ my %record_map = map { ( ref($_) . $_->id => $_ ) } @records;
+
+ return [ values %record_map ];
+ }
+
+ my $myself = $wanted eq 'from' ? 'to' : $wanted eq 'to' ? 'from' : croak("Invalid parameter `direction'");
+
+ my $my_table = SL::DB::Helper::Mappings::get_table_for_package(ref($self));
+
+ my @query = ( "${myself}_table" => $my_table,
+ "${myself}_id" => $self->id );
+
+ if ($params{$wanted}) {
+ my $wanted_classes = ref($params{$wanted}) eq 'ARRAY' ? $params{$wanted} : [ $params{$wanted} ];
+ my $wanted_tables = [ map { SL::DB::Helper::Mappings::get_table_for_package($_) || croak("Invalid parameter `${wanted}'") } @{ $wanted_classes } ];
+ push @query, ("${wanted}_table" => $wanted_tables);
+ }
+
+ my $links = SL::DB::Manager::RecordLink->get_all(query => [ and => \@query ]);
+
+ my $sub_wanted_table = "${wanted}_table";
+ my $sub_wanted_id = "${wanted}_id";
+
+ my $records = [];
+ @query = ref($params{query}) eq 'ARRAY' ? @{ $params{query} } : ();
+
+ foreach my $link (@{ $links }) {
+ my $manager_class = SL::DB::Helper::Mappings::get_manager_package_for_table($link->$sub_wanted_table);
+ my $object_class = SL::DB::Helper::Mappings::get_package_for_table($link->$sub_wanted_table);
+ eval "require " . $object_class . "; 1;";
+ push @{ $records }, @{ $manager_class->get_all(query => [ id => $link->$sub_wanted_id, @query ]) };
+ }
+
+ return $records;
+}
+
+sub link_to_record {
+ my $self = shift;
+ my $other = shift;
+ my %params = @_;
+
+ croak "self has no id" unless $self->id;
+ croak "other has no id" unless $other->id;
+
+ my @directions = ([ 'from', 'to' ]);
+ push @directions, [ 'to', 'from' ] if $params{bidirectional};
+ my @links;
+
+ foreach my $direction (@directions) {
+ my %data = ( $direction->[0] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($self)),
+ $direction->[0] . "_id" => $self->id,
+ $direction->[1] . "_table" => SL::DB::Helper::Mappings::get_table_for_package(ref($other)),
+ $direction->[1] . "_id" => $other->id,
+ );
+
+ my $link = SL::DB::Manager::RecordLink->find_by(and => [ %data ]);
+ push @links, $link ? $link : SL::DB::RecordLink->new(%data)->save unless $link;
+ }
+
+ return wantarray ? @links : $links[0];
+}
+
+sub sort_linked_records {
+ my ($self_or_class, $sort_by, $sort_dir, @records) = @_;
+
+ @records = @{ $records[0] } if (1 == scalar(@records)) && (ref($records[0]) eq 'ARRAY');
+ $sort_dir = $sort_dir * 1 ? 1 : -1;
+
+ my %numbers = ( 'SL::DB::SalesProcess' => sub { $_[0]->id },
+ 'SL::DB::Order' => sub { $_[0]->quotation ? $_[0]->quonumber : $_[0]->ordnumber },
+ 'SL::DB::DeliveryOrder' => sub { $_[0]->donumber },
+ 'SL::DB::Invoice' => sub { $_[0]->invnumber },
+ 'SL::DB::PurchaseInvoice' => sub { $_[0]->invnumber },
+ UNKNOWN => '9999999999999999',
+ );
+ my $number_xtor = sub {
+ my $number = $numbers{ ref($_[0]) };
+ $number = $number->($_[0]) if ref($number) eq 'CODE';
+ return $number || $numbers{UNKNOWN};
+ };
+ my $number_comparator = sub {
+ my $number_a = $number_xtor->($a);
+ my $number_b = $number_xtor->($b);
+
+ ncmp($number_a, $number_b) * $sort_dir;
+ };
+
+ my %scores;
+ %scores = ( 'SL::DB::SalesProcess' => 10,
+ 'SL::DB::Order' => sub { $scores{ $_[0]->type } },
+ sales_quotation => 20,
+ sales_order => 30,
+ sales_delivery_order => 40,
+ 'SL::DB::DeliveryOrder' => sub { $scores{ $_[0]->type } },
+ 'SL::DB::Invoice' => 50,
+ request_quotation => 120,
+ purchase_order => 130,
+ purchase_delivery_order => 140,
+ 'SL::DB::PurchaseInvoice' => 150,
+ UNKNOWN => 999,
+ );
+ my $score_xtor = sub {
+ my $score = $scores{ ref($_[0]) };
+ $score = $score->($_[0]) if ref($score) eq 'CODE';
+ return $score || $scores{UNKNOWN};
+ };
+ my $type_comparator = sub {
+ my $score_a = $score_xtor->($a);
+ my $score_b = $score_xtor->($b);
+
+ $score_a == $score_b ? $number_comparator->() : ($score_a <=> $score_b) * $sort_dir;
+ };
+
+ my $today = DateTime->today_local;
+ my $date_xtor = sub {
+ $_[0]->can('transdate_as_date') ? $_[0]->transdate_as_date
+ : $_[0]->can('itime_as_date') ? $_[0]->itime_as_date
+ : $today;
+ };
+ my $date_comparator = sub {
+ my $date_a = $date_xtor->($a);
+ my $date_b = $date_xtor->($b);
+
+ ($date_a <=> $date_b) * $sort_dir;
+ };
+
+ my $comparator = $sort_by eq 'number' ? $number_comparator
+ : $sort_by eq 'date' ? $date_comparator
+ : $type_comparator;
+
+ return [ sort($comparator @records) ];
+}
+
+sub filter_linked_records {
+ my ($self_or_class, $filter, @records) = @_;
+
+ if ($filter eq 'accessible') {
+ my $employee = SL::DB::Manager::Employee->current;
+ @records = grep { !$_->can('may_be_accessed') || $_->may_be_accessed($employee) } @records;
+ } else {
+ croak "Unsupported filter parameter '${filter}'";
+ }
+
+ return \@records;
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+SL::DB::Helper::LinkedRecords - Mixin for retrieving linked records via the table C<record_links>
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<linked_records %params>
+
+Retrieves records linked from or to C<$self> via the table
+C<record_links>. The mandatory parameter C<direction> (either C<from>,
+C<to> or C<both>) determines whether the function retrieves records
+that link to C<$self> (for C<direction> = C<to>) or that are linked
+from C<$self> (for C<direction> = C<from>). For C<direction = both>
+all records linked from or to C<$self> are returned.
+
+The optional parameter C<from> or C<to> (same as C<direction>)
+contains the package names of Rose models for table limitation. It can
+be a single model name as a single scalar or multiple model names in
+an array reference in which case all links matching any of the model
+names will be returned.
+
+If you only need invoices created from an order C<$order> then the
+call could look like this:
+
+ my $invoices = $order->linked_records(direction => 'to',
+ to => 'SL::DB::Invoice');
+
+The optional parameter C<query> can be used to limit the records
+returned. The following call limits the earlier example to invoices
+created today:
+
+ my $invoices = $order->linked_records(direction => 'to',
+ to => 'SL::DB::Invoice',
+ query => [ transdate => DateTime->today_local ]);
+
+The optional parameters C<$params{sort_by}> and C<$params{sort_dir}>
+can be used in order to sort the result. If C<$params{sort_by}> is
+trueish then the result is sorted by calling L</sort_linked_records>.
+
+The optional parameter C<$params{filter}> controls whether or not the
+result is filtered. Supported values are:
+
+=over 2
+
+=item C<accessible>
+
+Removes all objects for which the function C<may_be_accessed> from the
+mixin L<SL::DB::Helper::MayBeAccessed> exists and returns falsish for
+the current employee.
+
+=back
+
+Returns an array reference.
+
+=item C<link_to_record $record, %params>
+
+Will create an entry in the table C<record_links> with the C<from>
+side being C<$self> and the C<to> side being C<$record>. Will only
+insert a new entry if such a link does not already exist.
+
+If C<$params{bidirectional}> is trueish then another link will be
+created with the roles of C<from> and C<to> reversed. This link will
+also only be created if it doesn't exist already.
+
+In scalar contenxt returns either the existing link or the newly
+created one as an instance of C<SL::DB::RecordLink>. In array context
+it returns an array of links (one entry if C<$params{bidirectional}>
+is falsish and two entries if it is trueish).
+
+=item C<sort_linked_records $sort_by, $sort_dir, @records>
+
+Sorts linked records by C<$sort_by> in the direction given by
+C<$sort_dir> (trueish = ascending, falsish = descending). C<@records>
+can be either a single array reference or or normal array.
+
+C<$sort_by> can be one of the following strings:
+
+=over 2
+
+=item * C<type>
+
+Sort by type first and by record number second. The type order
+reflects the order in which records are usually processed by the
+employees: sales processes, sales quotations, sales orders, sales
+delivery orders, invoices; requests for quotation, purchase orders,
+purchase delivery orders, purchase invoices.
+
+=item * C<number>
+
+Sort by the record's running number.
+
+=item * C<date>
+
+Sort by the date the record was created or applies to.
+
+=back
+
+Returns a hash reference.
+
+Can be called both as a class or as an instance function.
+
+This function is not exported.
+
+=back
+
+=head1 EXPORTS
+
+This mixin exports the functions L</linked_records> and
+L</link_to_record>.
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
-package SL::DB::Helpers::Mappings;
+package SL::DB::Helper::Mappings;
use utf8;
use strict;
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(get_table_for_package get_package_for_table get_package_names);
+
# these will not be managed as Rose::DB models, because they are not normalized,
# significant changes are needed to get them done, or they were done by CRM.
my @lxoffice_blacklist_permanent = qw(
my %lxoffice_package_names = (
acc_trans => 'acc_transaction',
audittrail => 'audit_trail',
+ auth_group => 'auth_groups',
+ auth_group_right => 'auth_group_rights',
+ auth_user => 'auth_users',
+ auth_user_config => 'auth_user_configs',
+ auth_user_group => 'auth_user_groups',
ar => 'invoice',
ap => 'purchase_invoice',
+ background_jobs => 'background_job',
+ background_job_histories => 'background_job_history',
+ ap => 'purchase_invoice',
bank_accounts => 'bank_account',
buchungsgruppen => 'buchungsgruppe',
contacts => 'contact',
partsgroup => 'parts_group',
partstax => 'parts_tax',
payment_terms => 'payment_term',
+ periodic_invoices => 'periodic_invoice',
+ periodic_invoices_configs => 'periodic_invoices_config',
prices => 'prices',
price_factors => 'price_factor',
pricegroup => 'pricegroup',
vendortax => 'vendor_tax',
);
+my (%lxoffice_tables_to_packages, %lxoffice_tables_to_manager_packages, %lxoffice_packages_to_tables);
+
sub get_blacklist {
return LXOFFICE => \@lxoffice_blacklist;
}
return LXOFFICE => \%lxoffice_package_names;
}
+sub get_package_for_table {
+ %lxoffice_tables_to_packages = map { ($_ => "SL::DB::" . camelify($lxoffice_package_names{$_})) } keys %lxoffice_package_names
+ unless %lxoffice_tables_to_packages;
+
+ return $lxoffice_tables_to_packages{ $_[0] };
+}
+
+sub get_manager_package_for_table {
+ %lxoffice_tables_to_manager_packages = map { ($_ => "SL::DB::Manager::" . camelify($lxoffice_package_names{$_})) } keys %lxoffice_package_names
+ unless %lxoffice_tables_to_manager_packages;
+
+ return $lxoffice_tables_to_manager_packages{ $_[0] };
+}
+
+sub get_table_for_package {
+ get_package_for_table('dummy') if !%lxoffice_tables_to_packages;
+ %lxoffice_packages_to_tables = reverse %lxoffice_tables_to_packages unless %lxoffice_packages_to_tables;
+
+ my $package = $_[0] =~ m/^SL::DB::/ ? $_[0] : "SL::DB::" . $_[0];
+ return $lxoffice_packages_to_tables{ $package };
+}
+
sub db {
my $string = $_[0];
my $lookup = $lxoffice_package_names{$_[0]} ||
__END__
+=encoding utf8
+
=head1 NAME
-SL::DB::Helpers::Mappings - Rose Table <-> Model mapping information
+SL::DB::Helper::Mappings - Rose Table <-> Model mapping information
=head1 SYNOPSIS
- use SL::DB::Helpers::Mappings qw(@blacklist %table2model);
+ use SL::DB::Helper::Mappings qw(@blacklist %table2model);
=head1 DESCRIPTION
L<scripts/rose_auto_create_model.pl> script. If you add a new table that has
custom mappings, add it here.
-=head2 db
+=head1 FUNCTIONS
-A special function provided here is E<db>. Without it you'd have to write:
+=over 4
+
+=item C<db $name>
+
+A special function provided here is C<db>. Without it you'd have to write:
my $part = SL::DB::Part->new(id => 1234);
my @all_parts = SL::DB::Manager::Part->get_all;
db is written to try to make sense of what you give it, but if all fails, it
will die with an error.
+=item C<get_package_for_table $table_name>
+
+Returns the package name for a table name:
+
+ SL::DB::Helpers::Mappings::get_package_for_table('oe')
+ # SL::DB::Order
+
+=item C<get_manager_package_for_table $table_name>
+
+Returns the manager package name for a table name:
+
+ SL::DB::Helpers::Mappings::get_manager_package_for_table('oe')
+ # SL::DB::Manager::Order
+
+=item C<get_table_for_package $package_name>
+
+Returns the table name for a package name:
+
+ SL::DB::Helpers::Mappings::get_table_for_package('SL::DB::Order')
+ # oe
+ SL::DB::Helpers::Mappings::get_table_for_package('Order')
+ # oe
+
+=back
+
=head1 BUGS
nothing yet
=head1 AUTHOR
-Sven Schöling <s.schoeling@linet-services.de>
+Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>,
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
=cut
--- /dev/null
+package SL::DB::Helper::PriceTaxCalculator;
+
+use strict;
+
+use parent qw(Exporter);
+our @EXPORT = qw(calculate_prices_and_taxes);
+
+use Carp;
+use List::Util qw(sum min);
+use SL::DB::Default;
+use SL::DB::PriceFactor;
+use SL::DB::Unit;
+
+sub calculate_prices_and_taxes {
+ my ($self, %params) = @_;
+
+ my %units_by_name = map { ( $_->name => $_ ) } @{ SL::DB::Manager::Unit->get_all };
+ my %price_factors_by_id = map { ( $_->id => $_ ) } @{ SL::DB::Manager::PriceFactor->get_all };
+
+ my %data = ( lastcost_total => 0,
+ invoicediff => 0,
+ last_incex_chart_id => undef,
+ units_by_name => \%units_by_name,
+ price_factors_by_id => \%price_factors_by_id,
+ taxes => { },
+ amounts => { },
+ amounts_cogs => { },
+ allocated => { },
+ assembly_items => [ ],
+ exchangerate => undef,
+ is_sales => $self->can('customer') && $self->customer,
+ is_invoice => (ref($self) =~ /Invoice/) || $params{invoice},
+ );
+
+ _get_exchangerate($self, \%data, %params);
+
+ $self->netamount( 0);
+ $self->marge_total(0);
+
+ my $idx = 0;
+ foreach my $item ($self->items) {
+ $idx++;
+ _calculate_item($self, $item, $idx, \%data, %params);
+ }
+
+ _calculate_amounts($self, \%data, %params);
+
+ return $self unless wantarray;
+
+ return map { ($_ => $data{$_}) } qw(taxes amounts amounts_cogs allocated exchangerate assembly_items);
+}
+
+sub _get_exchangerate {
+ my ($self, $data, %params) = @_;
+
+ if (($self->curr || '') ne SL::DB::Default->get_default_currency) {
+ $data->{exchangerate} = $::form->check_exchangerate(\%::myconfig, $self->curr, $self->transdate, $data->{is_sales} ? 'buy' : 'sell');
+ $data->{exchangerate} ||= $params{exchangerate};
+ }
+ $data->{exchangerate} ||= 1;
+}
+
+sub _calculate_item {
+ my ($self, $item, $idx, $data, %params) = @_;
+
+ my $part_unit = $data->{units_by_name}->{ $item->part->unit };
+ my $item_unit = $data->{units_by_name}->{ $item->unit };
+
+ croak("Undefined unit " . $item->part->unit) if !$part_unit;
+ croak("Undefined unit " . $item->unit) if !$item_unit;
+
+ $item->base_qty($item_unit->convert_to($item->qty, $part_unit));
+ $item->fxsellprice($item->sellprice);
+
+ my $num_dec = _num_decimal_places($item->sellprice);
+ my $discount = _round($item->sellprice * ($item->discount || 0), $num_dec);
+ my $sellprice = _round($item->sellprice - $discount, $num_dec);
+
+ $item->price_factor( ! $item->price_factor_obj ? 1 : ($item->price_factor_obj->factor || 1));
+ $item->marge_price_factor(! $item->part->price_factor ? 1 : ($item->part->price_factor->factor || 1));
+ my $linetotal = _round($sellprice * $item->qty / $item->price_factor, 2) * $data->{exchangerate};
+ $linetotal = _round($linetotal, 2);
+
+ $data->{invoicediff} += $sellprice * $item->qty * $data->{exchangerate} / $item->price_factor - $linetotal if $self->taxincluded;
+
+ if (!$linetotal) {
+ $item->marge_total( 0);
+ $item->marge_percent(0);
+
+ } else {
+ my $lastcost = ! ($item->lastcost * 1) ? ($item->part->lastcost || 0) : $item->lastcost;
+
+ $item->marge_total( $linetotal - $lastcost / $item->marge_price_factor);
+ $item->marge_percent($item->marge_total * 100 / $linetotal);
+
+ $self->marge_total( $self->marge_total + $item->marge_total);
+ $data->{lastcost_total} += $lastcost;
+ }
+
+ my $taxkey = $item->part->get_taxkey(date => $self->transdate, is_sales => $data->{is_sales}, taxzone => $self->taxzone_id);
+ my $tax_rate = $taxkey->tax->rate;
+ my $tax_amount = undef;
+
+ if ($self->taxincluded) {
+ $tax_amount = $linetotal * $tax_rate / ($tax_rate + 1);
+ $sellprice = $sellprice / ($tax_rate + 1);
+
+ } else {
+ $tax_amount = $linetotal * $tax_rate;
+ }
+
+ $data->{taxes}->{ $taxkey->tax->chart_id } ||= 0;
+ $data->{taxes}->{ $taxkey->tax->chart_id } += $tax_amount;
+
+ $self->netamount($self->netamount + $sellprice * $item->qty / $item->price_factor);
+
+ my $chart = $item->part->get_chart(type => $data->{is_sales} ? 'income' : 'expense', taxzone => $self->taxzone_id);
+ $data->{amounts}->{ $chart->id } ||= { taxkey => $taxkey->taxkey_id, amount => 0 };
+ $data->{amounts}->{ $chart->id }->{amount} += $linetotal;
+
+ push @{ $data->{assembly_items} }, [];
+ if ($item->part->is_assembly) {
+ _calculate_assembly_item($self, $data, $item->part, $item->base_qty, $item->unit_obj->convert_to(1, $item->part->unit_obj));
+ } elsif ($item->part->is_part) {
+ $item->allocated(_calculate_part_item($self, $data, $item->part, $item->base_qty, $item->unit_obj->convert_to(1, $item->part->unit_obj)));
+ }
+
+ $data->{last_incex_chart_id} = $chart->id if $data->{is_sales};
+
+ _dbg("CALCULATE! ${idx} i.qty " . $item->qty . " i.sellprice " . $item->sellprice . " sellprice $sellprice num_dec $num_dec taxamount $tax_amount " .
+ "i.linetotal $linetotal netamount " . $self->netamount . " marge_total " . $item->marge_total . " marge_percent " . $item->marge_percent);
+}
+
+sub _calculate_amounts {
+ my ($self, $data, %params) = @_;
+
+ my $tax_diff = 0;
+ foreach my $chart_id (keys %{ $data->{taxes} }) {
+ my $rounded = _round($data->{taxes}->{$chart_id} * $data->{exchangerate}, 2);
+ $tax_diff += $data->{taxes}->{$chart_id} * $data->{exchangerate} - $rounded if $self->taxincluded;
+ $data->{taxes}->{$chart_id} = $rounded;
+ }
+
+ my $amount = _round(($self->netamount + $tax_diff) * $data->{exchangerate}, 2);
+ my $diff = $amount - ($self->netamount + $tax_diff) * $data->{exchangerate};
+ my $netamount = $amount;
+
+ if ($self->taxincluded) {
+ $data->{invoicediff} += $diff;
+ $data->{amounts}->{ $data->{last_incex_chart_id} }->{amount} += $data->{invoicediff} if $data->{last_incex_chart_id};
+ }
+
+ _dbg("Sna " . $self->netamount . " idiff " . $data->{invoicediff} . " tdiff ${tax_diff}");
+
+ my $tax = sum values %{ $data->{taxes} };
+ $data->{arap_amount} = $netamount + $tax;
+
+ $self->netamount( $netamount);
+ $self->amount( $netamount + $tax);
+ $self->marge_percent($self->netamount ? ($self->netamount - $data->{lastcost_total}) * 100 / $self->netamount : 0);
+}
+
+sub _calculate_assembly_item {
+ my ($self, $data, $part, $total_qty, $base_factor) = @_;
+
+ return 0 if $::eur || !$data->{is_invoice};
+
+ foreach my $assembly_entry (@{ $part->assemblies }) {
+ push @{ $data->{assembly_items}->[-1] }, { part => $assembly_entry->part,
+ qty => $total_qty * $assembly_entry->qty,
+ allocated => 0 };
+
+ if ($assembly_entry->part->is_assembly) {
+ _calculate_assembly_item($self, $data, $assembly_entry->part, $total_qty * $assembly_entry->qty);
+ } elsif ($assembly_entry->part->is_part) {
+ my $allocated = _calculate_part_item($self, $data, $assembly_entry->part, $total_qty * $assembly_entry->qty);
+ $data->{assembly_items}->[-1]->[-1]->{allocated} = $allocated;
+ }
+ }
+}
+
+sub _calculate_part_item {
+ my ($self, $data, $part, $total_qty, $base_factor) = @_;
+
+ _dbg("cpsi tq " . $total_qty);
+
+ return 0 if $::eur || !$data->{is_invoice} || !$total_qty;
+
+ my ($entry);
+ $base_factor ||= 1;
+ my $remaining_qty = $total_qty;
+ my $expense_income_chart = $part->get_chart(type => $data->{is_sales} ? 'expense' : 'income', taxzone => $self->taxzone_id);
+ my $inventory_chart = $part->get_chart(type => 'inventory', taxzone => $self->taxzone_id);
+
+ my $iterator = SL::DB::Manager::InvoiceItem->get_all_iterator(query => [ and => [ parts_id => $part->id,
+ \'(base_qty + allocated) < 0' ] ]);
+
+ while (($remaining_qty > 0) && ($entry = $iterator->next)) {
+ my $qty = min($remaining_qty, $entry->base_qty * -1 - $entry->allocated - $data->{allocated}->{ $entry->id });
+ _dbg("qty $qty");
+
+ next unless $qty;
+
+ my $linetotal = _round(($entry->sellprice * $qty) / $base_factor, 2);
+
+ $data->{amounts_cogs}->{ $expense_income_chart->id } -= $linetotal;
+ $data->{amounts_cogs}->{ $inventory_chart->id } += $linetotal;
+
+ $data->{allocated}->{ $entry->id } ||= 0;
+ $data->{allocated}->{ $entry->id } += $qty;
+ $remaining_qty -= $qty;
+ }
+
+ $iterator->finish;
+
+ return $remaining_qty - $total_qty;
+}
+
+sub _round {
+ return $::form->round_amount(@_);
+}
+
+sub _num_decimal_places {
+ return length( (split(/\./, '' . ($_[0] * 1), 2))[1] || '' );
+}
+
+sub _dbg {
+ $::lxdebug->message(0, join(' ', @_));
+}
+
+1;
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::DB::Helper::PriceTaxCalculator - Mixin for calculating the prices,
+amounts and taxes of orders, quotations, invoices
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<calculate_prices_and_taxes %params>
+
+Calculates the prices, amounts and taxes for an order, a quotation or
+an invoice.
+
+The function assumes that the mixing package has a certain layout and
+provides certain functions:
+
+=over 2
+
+=item C<transdate>
+
+The record's date.
+
+=item C<customer> or C<vendor>
+
+Determines if the record is a sales or purchase record.
+
+=item C<items>
+
+Accessor returning all line items for this record. The line items
+themselves must again have a certain layout. Instances of
+L<SL::DB::OrderItem> and L<SL::DB::InvoiceItem> are supported.
+
+=back
+
+The following values are calculated and set for C<$self>: C<amount>,
+C<netamount>, C<marge_percent>, C<marge_total>.
+
+The following values are calculated and set for each line item:
+C<base_qty>, C<price_factor>, C<marge_price_factor>, C<marge_total>,
+C<marge_percent>.
+
+The objects are not saved.
+
+Returns C<$self> in scalar context.
+
+In array context a hash with the following keys is returned:
+
+=over 2
+
+=item C<taxes>
+
+A hash reference with the calculated taxes. The keys are chart IDs,
+the values the calculated taxes.
+
+=item C<amounts>
+
+A hash reference with the calculated amounts. The keys are chart IDs,
+the values are hash references containing the two keys C<amount> and
+C<taxkey>.
+
+=item C<amounts_cogs>
+
+A hash reference with the calculated amounts for costs of goods
+sold. The keys are chart IDs, the values the calculated amounts.
+
+=item C<assembly_items>
+
+An array reference with as many entries as there are items in the
+record. Each entry is again an array reference of hash references with
+the keys C<part> (an instance of L<SL::DB::Part>), C<qty> and
+C<allocated>. Is only valid for invoices and can be used to populate
+the C<invoice> table with entries for assemblies.
+
+=item C<allocated>
+
+A hash reference. The keys are IDs of entries in the C<invoice>
+table. The values are the new values for the entry's C<allocated>
+column. Only valid for invoices.
+
+=item C<exchangerate>
+
+The exchangerate used for the calculation.
+
+=back
+
+=back
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
--- /dev/null
+package SL::DB::Helper::PriceUpdater;
+
+use strict;
+
+use parent qw(Exporter);
+our @EXPORT = qw(update_prices);
+
+use Carp;
+
+sub update_prices {
+ my $self = shift;
+ my %params = @_;
+
+ croak('Missing parameters amount/percent') unless $params{amount} || $params{percent};
+
+ my @prices = ref $params{prices} eq 'ARRAY' ? @{ $params{prices} } : ( $params{prices} || 'sellprice' );
+
+ foreach my $field (@prices) {
+ my $rounding_error = 0;
+
+ foreach my $item (@{ $self->items }) {
+ my $new_price;
+ if ($params{amount}) {
+ $new_price = $item->$field + $params{amount} + $rounding_error;
+ } else {
+ $new_price = $item->$field * $params{percent} / 100 + $rounding_error;
+ }
+
+ $item->$field($::form->round_amount($new_price, 2));
+ $rounding_error += $new_price - $item->$field;
+
+ _dbg("new_price $new_price new_price_no_err " . ($new_price - $rounding_error) . " rounded " . $item->$field .
+ " error_old " . ($rounding_error - $new_price + $item->$field) . " error_new $rounding_error");
+ }
+ }
+
+ return $self->calculate_prices_and_taxes if $params{calculate};
+ return $self;
+}
+
+sub _dbg {
+ # $::lxdebug->message(0, __PACKAGE__ . ': ' . join(' ', @_));
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+SL::DB::Helper::PriceUpdater - Mixin for updating all prices by a fixed amount or by a percentage
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<update_prices %params>
+
+Updates the prices of all items as returned by the function C<items>
+provided by the mixing class.
+
+Supported arguments via C<%params> are:
+
+=over 2
+
+=item C<amount>
+
+Absolute amount to add or subtract. Either C<amount> or C<percent>
+must be given. Resulting prices are rounded to two significant places.
+
+=item C<percent>
+
+Percentage to set the prices to (with 100 meaning "no
+change"). Resulting prices are rounded to two significant
+places. Rounding errors are carried over to the next item.
+
+Either C<amount> or C<percent> must be given.
+
+=item C<prices>
+
+A string or an array of strings naming the prices to update. If
+missing only the C<sellprice> field will be updated.
+
+=item C<calculate>
+
+If trueish the all prices, taxes and amounts are re-calculated by
+calling
+L<SL::DB::Helper::PriceTaxCalculator::calculate_prices_and_taxes>.
+Returns that function's result.
+
+=back
+
+Returns C<$self> unless C<$params{calculate}> is trueish.
+
+=back
+
+=head1 EXPORTS
+
+This mixin exports the function L</update_prices>.
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
--- /dev/null
+package SL::DB::Helper::TransNumberGenerator;
+
+use strict;
+
+use parent qw(Exporter);
+our @EXPORT = qw(get_next_trans_number create_trans_number);
+
+use Carp;
+use List::Util qw(max);
+
+use SL::DB::Default;
+
+my $oe_scoping = sub {
+ SL::DB::Manager::Order->type_filter($_[0]);
+};
+
+my $do_scoping = sub {
+ SL::DB::Manager::DeliveryOrder->type_filter($_[0]);
+};
+
+my %specs = ( ar => { number_column => 'invnumber', fill_holes_in_range => 1 },
+ sales_quotation => { number_column => 'quonumber', number_range_column => 'sqnumber', scoping => $oe_scoping, },
+ sales_order => { number_column => 'ordnumber', number_range_column => 'sonumber', scoping => $oe_scoping, },
+ request_quotation => { number_column => 'quonumber', number_range_column => 'rfqnumber', scoping => $oe_scoping, },
+ purchase_order => { number_column => 'ordnumber', number_range_column => 'ponumber', scoping => $oe_scoping, },
+ sales_delivery_order => { number_column => 'donumber', number_range_column => 'sdonumber', scoping => $do_scoping, fill_holes_in_range => 1 },
+ purchase_delivery_order => { number_column => 'donumber', number_range_column => 'pdonumber', scoping => $do_scoping, fill_holes_in_range => 1 },
+ );
+
+sub get_next_trans_number {
+ my ($self, %params) = @_;
+
+ my $spec_type = $specs{ $self->meta->table } ? $self->meta->table : $self->type;
+ my $spec = $specs{ $spec_type } || croak("Unsupported class " . ref($self));
+
+ my $number_column = $spec->{number_column};
+ my $number = $self->$number_column;
+ my $number_range_column = $spec->{number_range_column} || $number_column;
+ my $scoping_conditions = $spec->{scoping};
+ my $fill_holes_in_range = $spec->{fill_holes_in_range};
+
+ return $number if $self->id && $number;
+
+ my $re = '^(.*?)(\d+)$';
+ my %conditions = $scoping_conditions ? ( query => [ $scoping_conditions->($spec_type) ] ) : ();
+ my @numbers = map { $_->$number_column } @{ $self->_get_manager_class->get_all(%conditions) };
+ my %numbers_in_use = map { ( $_ => 1 ) } @numbers;
+ @numbers = grep { $_ } map { my @matches = m/$re/; @matches ? $matches[-1] * 1 : undef } @numbers;
+
+ my $defaults = SL::DB::Default->get;
+ my $number_range = $defaults->$number_range_column;
+ my @matches = $number_range =~ m/$re/;
+ my $prefix = (2 != scalar(@matches)) ? '' : $matches[ 0];
+ my $ref_number = !@matches ? '1' : $matches[-1];
+ my $min_places = length($ref_number);
+
+ my $new_number = $fill_holes_in_range ? $ref_number : max($ref_number, @numbers);
+ my $new_number_full = undef;
+
+ while (1) {
+ $new_number = $new_number + 1;
+ my $new_number_s = $new_number;
+ $new_number_s =~ s/\.\d+//g;
+ $new_number_full = $prefix . ('0' x max($min_places - length($new_number_s), 0)) . $new_number_s;
+ last if !$numbers_in_use{$new_number_full};
+ }
+
+ $defaults->update_attributes($number_range_column => $new_number_full) if $params{update_defaults};
+ $self->$number_column($new_number_full) if $params{update_record};
+
+ return $new_number_full;
+}
+
+sub create_trans_number {
+ my ($self, %params) = @_;
+
+ return $self->get_next_trans_number(update_defaults => 1, update_record => 1, %params);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::DB::Helper::TransNumberGenerator - A mixin for creating unique record numbers
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<get_mext_trams_number %params>
+
+Generates a new unique record number for the mixing class. Each record
+type (invoices, sales quotations, purchase orders etc) has its own
+number range. Within these ranges all numbers should be unique. The
+table C<defaults> contains the last record number assigned for all of
+the number ranges.
+
+This function contains hard-coded knowledge about the modules it can
+be mixed into. This way the models themselves don't have to contain
+boilerplate code for the details like the the number range column's
+name in the C<defaults> table.
+
+The process of creating a unique number involves the following steps:
+
+At first all existing record numbers for the current type are
+retrieved from the database as well as the last number assigned from
+the table C<defaults>.
+
+The next step is separating the number range from C<defaults> into two
+parts: an optional non-numeric prefix and its numeric suffix. The
+prefix, if present, will be kept intact.
+
+Now the number itself is increased as often as neccessary to create a
+unique one by comparing the generated numbers with the existing ones
+retrieved in the first step. In this step gaps in the assigned numbers
+are filled for some tables (e.g. invoices) but not for others
+(e.g. sales orders).
+
+After creating the unique record number this function can update
+C<$self> and the C<defaults> table if requested. This is controlled
+with the following parameters:
+
+=over 2
+
+=item * C<update_record>
+
+Determines whether or not C<$self>'s record number field is set to the
+newly generated number. C<$self> will not be saved even if this
+parameter is trueish. Defaults to false.
+
+=item * C<update_defaults>
+
+Determines whether or not the number range value in the C<defaults>
+table should be updated. Unlike C<$self> the C<defaults> table will be
+saved. Defaults to false.
+
+=back
+
+Always returns the newly generated number. This function cannot fail
+and return a value. If it fails then it is due to exceptions.
+
+=item C<create_trans_number %params>
+
+Calls and returns L</get_next_trans_number> with the parameters
+C<update_defaults = 1> and C<update_record = 1>. C<%params> is passed
+to it as well.
+
+=back
+
+=head1 EXPORTS
+
+This mixin exports all of its functions: L</get_next_trans_number> and
+L</create_trans_number>. There are no optional exports.
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
--- /dev/null
+package SL::DB::Helpers::ALLAuth;
+
+use strict;
+
+use SL::DB::AuthGroup;
+use SL::DB::AuthGroupRight;
+use SL::DB::AuthUserConfig;
+use SL::DB::AuthUser;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+SL::DB::Helpers::ALLAuth: Dependency-only package for all SL::DB::Auth* modules
+
+=head1 SYNOPSIS
+
+ use SL::DB::Helpers::ALLAuth;
+
+=head1 DESCRIPTION
+
+This module depends on all modules in SL/DB/Auth*.pm for the
+convenience of being able to write a simple \C<use
+SL::DB::Helpers::ALLAuth> and having everything loaded. This is
+supposed to be used only in the Lx-Office console. Normal modules
+should C<use> only the modules they actually need.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
use strict;
+use Carp;
use List::Util qw(first);
use SL::DB::MetaSetup::Invoice;
use SL::DB::Manager::Invoice;
+use SL::DB::Helper::FlattenToForm;
+use SL::DB::Helper::LinkedRecords;
+use SL::DB::Helper::PriceTaxCalculator;
+use SL::DB::Helper::PriceUpdater;
+use SL::DB::Helper::TransNumberGenerator;
+use SL::DB::AccTransaction;
+use SL::DB::Chart;
+use SL::DB::Employee;
__PACKAGE__->meta->add_relationship(
invoiceitems => {
with_objects => [ 'part' ]
}
},
+ payment_term => {
+ type => 'one to one',
+ class => 'SL::DB::PaymentTerm',
+ column_map => { payment_id => 'id' },
+ },
+ contact => {
+ type => 'one to one',
+ class => 'SL::DB::Contact',
+ column_map => { cp_id => 'cp_id' },
+ },
+ shipto => {
+ type => 'one to one',
+ class => 'SL::DB::Shipto',
+ column_map => { shipto_id => 'shipto_id' },
+ },
+ department => {
+ type => 'one to one',
+ class => 'SL::DB::Department',
+ column_map => { department_id => 'id' },
+ },
+ language => {
+ type => 'one to one',
+ class => 'SL::DB::Language',
+ column_map => { language_id => 'id' },
+ },
+ employee => {
+ type => 'one to one',
+ class => 'SL::DB::Employee',
+ column_map => { employee_id => 'id' },
+ },
);
__PACKAGE__->meta->initialize;
# methods
+sub items { goto &invoiceitems; }
+
# it is assumed, that ordnumbers are unique here.
sub first_order_by_ordnumber {
my $self = shift;
__PACKAGE__->meta->make_attr_helpers(taxamount => 'numeric(15,5)');
+sub closed {
+ my ($self) = @_;
+ return $self->paid >= $self->amount;
+}
+
+sub new_from {
+ my ($class, $source, %params) = @_;
+
+ croak("Unsupported source object type '" . ref($source) . "'") unless ref($source) =~ m/^ SL::DB:: (?: Order | DeliveryOrder ) $/x;
+ croak("Cannot create invoices for purchase records") unless $source->customer_id;
+
+ my $terms = $source->can('payment_id') && $source->payment_id ? $source->payment_term->terms_netto : 0;
+
+ my %args = ( map({ ( $_ => $source->$_ ) } qw(customer_id taxincluded shippingpoint shipvia notes intnotes curr salesman_id cusordnumber ordnumber quonumber
+ department_id cp_id language_id payment_id delivery_customer_id delivery_vendor_id taxzone_id shipto_id
+ globalproject_id transaction_description)),
+ transdate => DateTime->today_local,
+ gldate => DateTime->today_local,
+ duedate => DateTime->today_local->add(days => $terms * 1),
+ invoice => 1,
+ type => 'invoice',
+ storno => 0,
+ paid => 0,
+ employee_id => (SL::DB::Manager::Employee->current || SL::DB::Employee->new(id => $source->employee_id))->id,
+ );
+
+ if ($source->type =~ /_order$/) {
+ $args{deliverydate} = $source->reqdate;
+ $args{orddate} = $source->transdate;
+ } else {
+ $args{quodate} = $source->transdate;
+ }
+
+ my $invoice = $class->new(%args, %params);
+
+ my @items = map {
+ my $source_item = $_;
+ SL::DB::InvoiceItem->new(map({ ( $_ => $source_item->$_ ) }
+ qw(parts_id description qty sellprice discount project_id
+ serialnumber pricegroup_id ordnumber transdate cusordnumber unit
+ base_qty subtotal longdescription lastcost price_factor_id)),
+ deliverydate => $source_item->reqdate,
+ fxsellprice => $source_item->sellprice,);
+ } @{ $source->items };
+
+ $invoice->invoiceitems(\@items);
+
+ return $invoice;
+}
+
+sub post {
+ my ($self, %params) = @_;
+
+ if (!$params{ar_id}) {
+ my $chart = SL::DB::Manager::Chart->get_all(query => [ SL::DB::Manager::Chart->link_filter('AR') ],
+ sort_by => 'id ASC',
+ limit => 1)->[0];
+ croak("No AR chart found and no parameter `ar_id' given") unless $chart;
+ $params{ar_id} = $chart->id;
+ }
+
+ my $worker = sub {
+ my %data = $self->calculate_prices_and_taxes;
+
+ $self->_post_create_assemblyitem_entries($data{assembly_items});
+ $self->create_trans_number;
+ $self->save;
+
+ $self->_post_add_acctrans($data{amounts_cogs});
+ $self->_post_add_acctrans($data{amounts});
+ $self->_post_add_acctrans($data{taxes});
+
+ $self->_post_add_acctrans({ $params{ar_id} => $self->amount * -1 });
+
+ $self->_post_update_allocated($data{allocated});
+ };
+
+ if ($self->db->in_transaction) {
+ $worker->();
+ } elsif (!$self->db->do_transaction($worker)) {
+ $::lxdebug->message(0, "convert_to_invoice failed: " . join("\n", (split(/\n/, $self->db->error))[0..2]));
+ return undef;
+ }
+
+ return $self;
+}
+
+sub _post_add_acctrans {
+ my ($self, $entries) = @_;
+
+ while (my ($chart_id, $spec) = each %{ $entries }) {
+ $spec = { taxkey => 0, amount => $spec } unless ref $spec;
+ SL::DB::AccTransaction->new(trans_id => $self->id,
+ chart_id => $chart_id,
+ amount => $spec->{amount},
+ taxkey => $spec->{taxkey},
+ project_id => $self->globalproject_id,
+ transdate => $self->transdate)->save;
+ }
+}
+
+sub _post_create_assemblyitem_entries {
+ my ($self, $assembly_entries) = @_;
+
+ my $items = $self->invoiceitems;
+ my @new_items;
+
+ my $item_idx = 0;
+ foreach my $item (@{ $items }) {
+ next if $item->assemblyitem;
+
+ push @new_items, $item;
+ $item_idx++;
+
+ foreach my $assembly_item (@{ $assembly_entries->[$item_idx] || [ ] }) {
+ push @new_items, SL::DB::InvoiceItem->new(parts_id => $assembly_item->{part},
+ description => $assembly_item->{part}->description,
+ unit => $assembly_item->{part}->unit,
+ qty => $assembly_item->{qty},
+ allocated => $assembly_item->{allocated},
+ sellprice => 0,
+ fxsellprice => 0,
+ assemblyitem => 't');
+ }
+ }
+
+ $self->invoiceitems(\@new_items);
+}
+
+sub _post_update_allocated {
+ my ($self, $allocated) = @_;
+
+ while (my ($invoice_id, $diff) = each %{ $allocated }) {
+ SL::DB::Manager::InvoiceItem->update_all(set => { allocated => { sql => "allocated + $diff" } },
+ where => [ id => $invoice_id ]);
+ }
+}
+
1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+SL::DB::Invoice: Rose model for invoices (table "ar")
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<new_from $source>
+
+Creates a new C<SL::DB::Invoice> instance and copies as much
+information from C<$source> as possible. At the moment only sales
+orders and sales quotations are supported as sources.
+
+The conversion copies order items into invoice items. Dates are copied
+as appropriate, e.g. the C<transdate> field from an order will be
+copied into the invoice's C<orddate> field.
+
+Amounts, prices and taxes are not
+calculated. L<SL::DB::Helper::PriceTaxCalculator::calculate_prices_and_taxes>
+can be used for this.
+
+The object returned is not saved.
+
+=item C<post %params>
+
+Posts the invoice. Required parameters are:
+
+=over 2
+
+=item * C<ar_id>
+
+The ID of the accounds receivable chart the invoices amounts are
+posted to. If it is not set then the first chart configured for
+accounts receivables is used.
+
+=back
+
+This function implements several steps:
+
+=over 2
+
+=item 1. It calculates all prices, amounts and taxes by calling
+L<SL::DB::Helper::PriceTaxCalculator::calculate_prices_and_taxes>.
+
+=item 2. A new and unique invoice number is created.
+
+=item 3. All amounts for costs of goods sold are recorded in
+C<acc_trans>.
+
+=item 4. All amounts for parts, services and assemblies are recorded
+in C<acc_trans> with their respective charts. This is determined by
+the part's buchungsgruppen.
+
+=item 5. The total amount is posted to the accounts receivable chart
+and recorded in C<acc_trans>.
+
+=item 6. Items in C<invoice> are updated according to their allocation
+status (regarding for costs of goold sold). Will only be done if
+Lx-Office is not configured to use Einnahmenüberschussrechnungen
+(C<$::eur>).
+
+=item 7. The invoice and its items are saved.
+
+=back
+
+Returns C<$self> on success and C<undef> on failure. The whole process
+is run inside a transaction. If it fails then nothing is saved to or
+changed in the database. A new transaction is only started if none is
+active.
+
+=item C<basic_info $field>
+
+See L<SL::DB::Object::basic_info>.
+
+=back
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
type => 'one to one',
class => 'SL::DB::Part',
column_map => { parts_id => 'id' },
- }
+ },
+ price_factor_obj => {
+ type => 'one to one',
+ class => 'SL::DB::PriceFactor',
+ column_map => { price_factor_id => 'id' },
+ },
+ unit_obj => {
+ type => 'one to one',
+ class => 'SL::DB::Unit',
+ column_map => { unit => 'name' },
+ },
);
# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
--- /dev/null
+package SL::DB::Manager::BackgroundJob;
+
+use strict;
+
+use SL::DB::Helper::Manager;
+use base qw(SL::DB::Helper::Manager);
+
+sub object_class { 'SL::DB::BackgroundJob' }
+
+__PACKAGE__->make_manager_methods;
+
+sub cleanup {
+ my $class = shift;
+ $class->delete_all(where => [ and => [ type => 'once', last_run_at => { lt => DateTime->now_local->subtract(days => '1') } ] ]);
+}
+
+sub get_all_need_to_run {
+ my $class = shift;
+
+ my $now = DateTime->now_local;
+ my @interval_args = (and => [ type => 'interval',
+ active => 1,
+ next_run_at => { le => $now } ]);
+ my @once_args = (and => [ type => 'once',
+ active => 1,
+ last_run_at => undef,
+ or => [ cron_spec => undef,
+ cron_spec => '',
+ next_run_at => undef,
+ next_run_at => { le => $now } ] ]);
+
+ return $class->get_all(where => [ or => [ @interval_args, @once_args ] ]);
+}
+
+1;
--- /dev/null
+package SL::DB::Manager::Chart;
+
+use strict;
+
+use SL::DB::Helper::Manager;
+use base qw(SL::DB::Helper::Manager);
+
+use SL::DB::Helper::Sorted;
+
+sub object_class { 'SL::DB::Chart' }
+
+__PACKAGE__->make_manager_methods;
+
+sub link_filter {
+ my ($class, $link) = @_;
+
+ return (or => [ link => $link,
+ link => { like => "${link}:\%" },
+ link => { like => "\%:${link}" },
+ link => { like => "\%:${link}:\%" } ]);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::DB::Manager::Chart - Manager class for the model for the C<chart> table
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<link_filter $link>
+
+Returns a query builder filter that matches charts whose 'C<link>'
+field contains C<$link>. Matching is done so that the exact value of
+C<$link> matches but not if C<$link> is only a substring of a
+match. Therefore C<$link = 'AR'> will match the column content 'C<AR>'
+or 'C<AR_paid:AR>' but not 'C<AR_amount>'.
+
+=back
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
+++ /dev/null
-# This file has been auto-generated. Do not modify it; it will be overwritten
-# by rose_auto_create_model.pl automatically.
-package SL::DB::AccTrans;
-
-use strict;
-
-use base qw(SL::DB::Object);
-
-__PACKAGE__->meta->setup(
- table => 'acc_trans',
-
- columns => [
- acc_trans_id => { type => 'bigint', sequence => 'acc_trans_id_seq' },
- trans_id => { type => 'integer', not_null => 1 },
- chart_id => { type => 'integer', not_null => 1 },
- amount => { type => 'numeric', precision => 5, scale => 15 },
- transdate => { type => 'date', default => 'now' },
- gldate => { type => 'date', default => 'now' },
- source => { type => 'text' },
- cleared => { type => 'boolean', default => 'false' },
- fx_transaction => { type => 'boolean', default => 'false' },
- ob_transaction => { type => 'boolean', default => 'false' },
- cb_transaction => { type => 'boolean', default => 'false' },
- project_id => { type => 'integer' },
- memo => { type => 'text' },
- taxkey => { type => 'integer' },
- itime => { type => 'timestamp', default => 'now()' },
- mtime => { type => 'timestamp' },
- id => { type => 'integer', not_null => 1, sequence => 'acc_trans_id_seq1' },
- ],
-
- primary_key_columns => [ 'id' ],
-
- allow_inline_column_values => 1,
-
- foreign_keys => [
- chart => {
- class => 'SL::DB::Chart',
- key_columns => { chart_id => 'id' },
- },
-
- project => {
- class => 'SL::DB::Project',
- key_columns => { project_id => 'id' },
- },
- ],
-);
-
-1;
-;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::AuthGroup;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'group',
+
+ columns => [
+ id => { type => 'serial', not_null => 1 },
+ name => { type => 'text', not_null => 1 },
+ description => { type => 'text' },
+ ],
+
+ primary_key_columns => [ 'id' ],
+
+ unique_key => [ 'name' ],
+);
+
+1;
+;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::AuthGroupRight;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'group_rights',
+
+ columns => [
+ group_id => { type => 'integer', not_null => 1 },
+ right => { type => 'text', not_null => 1 },
+ granted => { type => 'boolean', not_null => 1 },
+ ],
+
+ primary_key_columns => [ 'group_id', 'right' ],
+);
+
+1;
+;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::AuthUser;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'user',
+
+ columns => [
+ id => { type => 'serial', not_null => 1 },
+ login => { type => 'text', not_null => 1 },
+ password => { type => 'text' },
+ ],
+
+ primary_key_columns => [ 'id' ],
+
+ unique_key => [ 'login' ],
+);
+
+1;
+;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::AuthUserConfig;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'user_config',
+
+ columns => [
+ user_id => { type => 'integer', not_null => 1 },
+ cfg_key => { type => 'text', not_null => 1 },
+ cfg_value => { type => 'text' },
+ ],
+
+ primary_key_columns => [ 'user_id', 'cfg_key' ],
+);
+
+1;
+;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::AuthUserGroup;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'user_group',
+
+ columns => [
+ user_id => { type => 'integer', not_null => 1 },
+ group_id => { type => 'integer', not_null => 1 },
+ ],
+
+ primary_key_columns => [ 'user_id', 'group_id' ],
+);
+
+1;
+;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::BackgroundJob;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'background_jobs',
+
+ columns => [
+ id => { type => 'serial', not_null => 1 },
+ type => { type => 'varchar', length => 255 },
+ package_name => { type => 'varchar', length => 255 },
+ last_run_at => { type => 'timestamp' },
+ next_run_at => { type => 'timestamp' },
+ data => { type => 'text' },
+ active => { type => 'boolean' },
+ cron_spec => { type => 'varchar', length => 255 },
+ ],
+
+ primary_key_columns => [ 'id' ],
+);
+
+1;
+;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::BackgroundJobHistory;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'background_job_histories',
+
+ columns => [
+ id => { type => 'serial', not_null => 1 },
+ package_name => { type => 'varchar', length => 255 },
+ run_at => { type => 'timestamp' },
+ status => { type => 'varchar', length => 255 },
+ result => { type => 'text' },
+ error => { type => 'text', alias => 'error_col' },
+ data => { type => 'text' },
+ ],
+
+ primary_key_columns => [ 'id' ],
+);
+
+1;
+;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::PeriodicInvoice;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'periodic_invoices',
+
+ columns => [
+ id => { type => 'integer', not_null => 1, sequence => 'id' },
+ config_id => { type => 'integer', not_null => 1 },
+ ar_id => { type => 'integer', not_null => 1 },
+ period_start_date => { type => 'date', not_null => 1 },
+ itime => { type => 'timestamp', default => 'now()' },
+ ],
+
+ primary_key_columns => [ 'id' ],
+
+ allow_inline_column_values => 1,
+
+ foreign_keys => [
+ ar => {
+ class => 'SL::DB::Invoice',
+ key_columns => { ar_id => 'id' },
+ },
+
+ config => {
+ class => 'SL::DB::PeriodicInvoicesConfig',
+ key_columns => { config_id => 'id' },
+ },
+ ],
+);
+
+1;
+;
--- /dev/null
+# This file has been auto-generated. Do not modify it; it will be overwritten
+# by rose_auto_create_model.pl automatically.
+package SL::DB::PeriodicInvoicesConfig;
+
+use strict;
+
+use base qw(SL::DB::Object);
+
+__PACKAGE__->meta->setup(
+ table => 'periodic_invoices_configs',
+
+ columns => [
+ id => { type => 'integer', not_null => 1, sequence => 'id' },
+ oe_id => { type => 'integer', not_null => 1 },
+ periodicity => { type => 'varchar', length => 10, not_null => 1 },
+ print => { type => 'boolean', default => 'false' },
+ printer_id => { type => 'integer' },
+ copies => { type => 'integer' },
+ active => { type => 'boolean', default => 'true' },
+ start_date => { type => 'date' },
+ ar_chart_id => { type => 'integer', not_null => 1 },
+ terminated => { type => 'boolean', default => 'false' },
+ end_date => { type => 'date' },
+ extend_automatically_by => { type => 'integer' },
+ ],
+
+ primary_key_columns => [ 'id' ],
+
+ foreign_keys => [
+ ar_chart => {
+ class => 'SL::DB::Chart',
+ key_columns => { ar_chart_id => 'id' },
+ },
+
+ oe => {
+ class => 'SL::DB::Order',
+ key_columns => { oe_id => 'id' },
+ },
+
+ printer => {
+ class => 'SL::DB::Printer',
+ key_columns => { printer_id => 'id' },
+ },
+ ],
+);
+
+1;
+;
return $self;
}
+sub call_sub {
+ my $self = shift;
+ my $sub = shift;
+ return $self->$sub(@_);
+}
+
1;
__END__
on. Can be used from methods in this package for getting the actual
object's manager.
+=item C<call_sub $name, @args>
+
+Calls the sub C<$name> on C<$self> with the arguments C<@args> and
+returns its result. This is meant for situations in which the sub's
+name is a composite, e.g.
+
+ my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}");
+
=back
=head1 AUTHOR
use utf8;
use strict;
-use SL::RecordLinks;
+use Carp;
+use DateTime;
+use List::Util qw(max);
use SL::DB::MetaSetup::Order;
use SL::DB::Manager::Order;
use SL::DB::Invoice;
+use SL::DB::Helper::FlattenToForm;
+use SL::DB::Helper::LinkedRecords;
+use SL::DB::Helper::PriceTaxCalculator;
+use SL::DB::Helper::PriceUpdater;
+use SL::DB::Helper::TransNumberGenerator;
+use SL::RecordLinks;
__PACKAGE__->meta->add_relationship(
orderitems => {
manager_args => {
with_objects => [ 'part' ]
}
- }
+ },
+ periodic_invoices_config => {
+ type => 'one to one',
+ class => 'SL::DB::PeriodicInvoicesConfig',
+ column_map => { id => 'oe_id' },
+ },
+ periodic_invoices => {
+ type => 'one to many',
+ class => 'SL::DB::PeriodicInvoice',
+ column_map => { id => 'oe_id' },
+ },
+ payment_term => {
+ type => 'one to one',
+ class => 'SL::DB::PaymentTerm',
+ column_map => { payment_id => 'id' },
+ },
+ contact => {
+ type => 'one to one',
+ class => 'SL::DB::Contact',
+ column_map => { cp_id => 'cp_id' },
+ },
+ shipto => {
+ type => 'one to one',
+ class => 'SL::DB::Shipto',
+ column_map => { shipto_id => 'shipto_id' },
+ },
+ department => {
+ type => 'one to one',
+ class => 'SL::DB::Department',
+ column_map => { department_id => 'id' },
+ },
+ language => {
+ type => 'one to one',
+ class => 'SL::DB::Language',
+ column_map => { language_id => 'id' },
+ },
);
__PACKAGE__->meta->initialize;
# methods
+sub items { goto &orderitems; }
+
sub type {
my $self = shift;
return shift()->invoices(query => [ abschlag => 0 ]);
}
+sub convert_to_invoice {
+ my ($self, %params) = @_;
+
+ croak("Conversion to invoices is only supported for sales records") unless $self->customer_id;
+
+ my $invoice;
+ if (!$self->db->do_transaction(sub {
+ $invoice = SL::DB::Invoice->new_from($self)->post(%params) || die;
+ $self->link_to_record($invoice);
+ $self->update_attributes(closed => 1);
+ # die;
+ })) {
+ return undef;
+ }
+
+ return $invoice;
+}
+
1;
__END__
Rreturns true if the order is of the given type.
+=item C<convert_to_invoice %params>
+
+Creates a new invoice with C<$self> as the basis by calling
+L<SL::DB::Invoice::new_from>. That invoice is posted, and C<$self> is
+linked to the new invoice via L<SL::DB::RecordLink>. C<$self>'s
+C<closed> attribute is set to C<true>, and C<$self> is saved.
+
+The arguments in C<%params> are passed to L<SL::DB::Invoice::post>.
+
+Returns the new invoice instance on success and C<undef> on
+failure. The whole process is run inside a transaction. On failure
+nothing is created or changed in the database.
+
+At the moment only sales quotations and sales orders can be converted.
+
+=item C<create_sales_process>
+
+Creates and saves a new sales process. Can only be called for sales
+orders.
+
+The newly created process will be linked bidirectionally to both
+C<$self> and to all sales quotations that are linked to C<$self>.
+
+Returns the newly created process instance.
+
+=back
+
=head1 BUGS
Nothing here yet.
type => 'one to one',
class => 'SL::DB::Part',
column_map => { parts_id => 'id' },
- }
+ },
+ price_factor_obj => {
+ type => 'one to one',
+ class => 'SL::DB::PriceFactor',
+ column_map => { price_factor_id => 'id' },
+ },
+ unit_obj => {
+ type => 'one to one',
+ class => 'SL::DB::Unit',
+ column_map => { unit => 'name' },
+ },
);
# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
use strict;
use Carp;
+use List::MoreUtils qw(any);
+
use SL::DBUtils;
use SL::DB::MetaSetup::Part;
use SL::DB::Manager::Part;
+use SL::DB::Chart;
__PACKAGE__->meta->add_relationships(
unit_obj => {
class => 'SL::DB::PartsGroup',
column_map => { partsgroup_id => 'id' },
},
+ price_factor => {
+ type => 'one to one',
+ class => 'SL::DB::PriceFactor',
+ column_map => { price_factor_id => 'id' },
+ },
);
__PACKAGE__->meta->initialize;
shift->buchungsgruppen(@_);
}
+sub get_taxkey {
+ my ($self, %params) = @_;
+
+ my $date = $params{date} || DateTime->today_local;
+ my $is_sales = !!$params{is_sales};
+ my $taxzone = $params{ defined($params{taxzone}) ? 'taxzone' : 'taxzone_id' } * 1;
+
+ $self->{__partpriv_taxkey_information} ||= { };
+ my $tk_info = $self->{__partpriv_taxkey_information};
+
+ $tk_info->{$taxzone} ||= { };
+ $tk_info->{$taxzone}->{$is_sales} ||= { };
+
+ if (!exists $tk_info->{$taxzone}->{$is_sales}->{$date}) {
+ $tk_info->{$taxzone}->{$is_sales}->{$date} =
+ $self->get_chart(type => $is_sales ? 'income' : 'expense', taxzone => $taxzone)
+ ->load
+ ->get_active_taxkey($date);
+ }
+
+ return $tk_info->{$taxzone}->{$is_sales}->{$date};
+}
+
+sub get_chart {
+ my ($self, %params) = @_;
+
+ my $type = (any { $_ eq $params{type} } qw(income expense inventory)) ? $params{type} : croak("Invalid 'type' parameter '$params{type}'");
+ my $taxzone = $params{ defined($params{taxzone}) ? 'taxzone' : 'taxzone_id' } * 1;
+
+ $self->{__partpriv_get_chart_id} ||= { };
+ my $charts = $self->{__partpriv_get_chart_id};
+
+ $charts->{$taxzone} ||= { };
+
+ if (!exists $charts->{$taxzone}->{$type}) {
+ my $bugru = $self->buchungsgruppe;
+ my $chart_id = ($type eq 'inventory') ? ($self->inventory_accno_id ? $bugru->inventory_accno_id : undef)
+ : $bugru->call_sub("${type}_accno_id_${taxzone}");
+
+ $charts->{$taxzone}->{$type} = $chart_id ? SL::DB::Chart->new(id => $chart_id)->load : undef;
+ }
+
+ return $charts->{$taxzone}->{$type};
+}
+
1;
__END__
=pod
+=encoding utf-8
+
=head1 NAME
SL::DB::Part: Model for the 'parts' table
C<new_service>, and C<new_assembly>. A Buchungsgruppe should be supplied in this
case, but it will use the default Buchungsgruppe if you don't.
-Matching these there are assorted helper methods dealing with type:
+Matching these there are assorted helper methods dealing with types,
+e.g. L</new_part>, L</new_service>, L</new_assembly>, L</type>,
+L</is_type> and others.
-=head2 new_part PARAMS
+=head1 FUNCTIONS
+
+=over 4
-=head2 new_service PARAMS
+=item C<new_part %PARAMS>
-=head2 new_assembly PARAMS
+=item C<new_service %PARAMS>
+
+=item C<new_assembly %PARAMS>
Will set the appropriate data fields so that the resulting instance will be of
tthe requested type. Since part of the distinction are accounting targets,
providing a C<Buchungsgruppe> is recommended. If none is given the constructor
will load a default one and set the accounting targets from it.
-=head2 type
+=item C<type>
Returns the type as a string. Can be one of C<part>, C<service>, C<assembly>.
-=head2 is_type TYPE
+=item C<is_type $TYPE>
Tests if the current object is a part, a service or an
assembly. C<$type> must be one of the words 'part', 'service' or
Returns 1 if the requested type matches, 0 if it doesn't and
C<confess>es if an unknown C<$type> parameter is encountered.
-=head2 is_part
-
-=head2 is_service
+=item C<is_part>
-=head2 is_assembly
+=item C<is_service>
-Shorthand for is_type('part') etc.
+=item C<is_assembly>
-=head1 FUNCTIONS
+Shorthand for C<is_type('part')> etc.
-=head2 get_sellprice_info %params
+=item C<get_sellprice_info %params>
Retrieves the C<sellprice> and C<price_factor_id> for a part under
different conditions and returns a hash reference with those two keys.
If none of the above conditions is met then the information from
C<$self> is used.
-=head2 get_ordered_qty %params
+=item C<get_ordered_qty %params>
Retrieves the quantity that has been ordered from a vendor but that
has not been delivered yet. Only open purchase orders are considered.
-=head2 orphaned
+=item C<get_taxkey %params>
+
+Retrieves and returns a taxkey object valid for the given date
+C<$params{date}> and tax zone C<$params{taxzone}>
+(C<$params{taxzone_id}> is also recognized). The date defaults to the
+current date if undefined.
+
+This function looks up the income (for trueish values of
+C<$params{is_sales}>) or expense (for falsish values of
+C<$params{is_sales}>) account for the current part. It uses the part's
+associated buchungsgruppe and uses the fields belonging to the tax
+zone given by C<$params{taxzone}> (range 0..3).
+
+The information retrieved by the function is cached.
+
+=item C<get_chart %params>
+
+Retrieves and returns a chart object valid for the given type
+C<$params{type}> and tax zone C<$params{taxzone}>
+(C<$params{taxzone_id}> is also recognized). The type must be one of
+the three key words C<income>, C<expense> and C<inventory>.
+
+This function uses the part's associated buchungsgruppe and uses the
+fields belonging to the tax zone given by C<$params{taxzone}> (range
+0..3).
+
+The information retrieved by the function is cached.
+
+=item C<orphaned>
Checks if this articke is used in orders, invoices, delivery orders or
assemblies.
-=head2 buchungsgruppe BUCHUNGSGRUPPE
+=item C<buchungsgruppe BUCHUNGSGRUPPE>
Used to set the accounting informations from a L<SL:DB::Buchungsgruppe> object.
Please note, that this is a write only accessor, the original Buchungsgruppe can
not be retrieved from an article once set.
-=head1 AUTHOR
+=back
+
+=head1 AUTHORS
-Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
+Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
=cut
--- /dev/null
+package SL::DB::PeriodicInvoice;
+
+use strict;
+
+use SL::DB::MetaSetup::PeriodicInvoice;
+
+__PACKAGE__->meta->add_relationships(
+ invoice => {
+ type => 'one to one',
+ class => 'SL::DB::Invoice',
+ column_map => { ar_id => 'id' },
+ },
+);
+
+__PACKAGE__->meta->initialize;
+
+# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
+__PACKAGE__->meta->make_manager_class;
+
+1;
--- /dev/null
+package SL::DB::PeriodicInvoicesConfig;
+
+use strict;
+
+use Readonly;
+
+use SL::DB::MetaSetup::PeriodicInvoicesConfig;
+
+__PACKAGE__->meta->add_relationships(
+ order => {
+ type => 'one to one',
+ class => 'SL::DB::Order',
+ column_map => { oe_id => 'id' },
+ },
+);
+
+__PACKAGE__->meta->initialize;
+
+# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
+__PACKAGE__->meta->make_manager_class;
+
+Readonly our @PERIODICITIES => qw(m q f b y);
+Readonly our %PERIOD_LENGTHS => ( m => 1, q => 3, f => 4, b => 6, y => 12 );
+
+sub get_period_length {
+ my $self = shift;
+ return $PERIOD_LENGTHS{ $self->periodicity } || 1;
+}
+
+sub _log_msg {
+ $::lxdebug->message(LXDebug->DEBUG1(), join('', @_));
+}
+
+sub handle_automatic_extension {
+ my $self = shift;
+
+ _log_msg("HAE for " . $self->id . "\n");
+ # Don't extend configs that have been terminated. There's nothing to
+ # extend if there's no end date.
+ return if $self->terminated || !$self->end_date;
+
+ my $today = DateTime->now_local;
+ my $end_date = $self->end_date;
+
+ _log_msg("today $today end_date $end_date\n");
+
+ # The end date has not been reached yet, therefore no extension is
+ # needed.
+ return if $today <= $end_date;
+
+ # The end date has been reached. If no automatic extension has been
+ # set then terminate the config and return.
+ if (!$self->extend_automatically_by) {
+ _log_msg("setting inactive\n");
+ $self->active(0);
+ $self->save;
+ return;
+ }
+
+ # Add the automatic extension period to the new end date as long as
+ # the new end date is in the past. Then save it and get out.
+ $end_date->add(months => $self->extend_automatically_by) while $today > $end_date;
+ _log_msg("new end date $end_date\n");
+
+ $self->end_date($end_date);
+ $self->save;
+
+ return $end_date;
+}
+
+sub get_previous_invoice_date {
+ my $self = shift;
+
+ my $query = <<SQL;
+ SELECT MAX(ar.transdate)
+ FROM periodic_invoices
+ LEFT JOIN ar ON (ar.id = periodic_invoices.ar_id)
+ WHERE periodic_invoices.config_id = ?
+SQL
+
+ my ($max_transdate) = $self->dbh->selectrow_array($query, undef, $self->id);
+
+ return undef unless $max_transdate;
+ return ref $max_transdate ? $max_transdate : $self->db->parse_date($max_transdate);
+}
+
+1;
use SL::DB::MetaSetup::PurchaseInvoice;
use SL::DB::Manager::PurchaseInvoice;
+use SL::DB::Helper::LinkedRecords;
+# The calculator hasn't been adjusted for purchase invoices yet.
+# use SL::DB::Helper::PriceTaxCalculator;
__PACKAGE__->meta->add_relationship(invoiceitems => { type => 'one to many',
class => 'SL::DB::InvoiceItem',
__PACKAGE__->meta->initialize;
+sub items { goto &invoiceitems; }
+
1;
-# This file has been auto-generated only because it didn't exist.
-# Feel free to modify it at will; it will not be overwritten automatically.
-
package SL::DB::Tax;
use strict;
use SL::DB::MetaSetup::Tax;
+__PACKAGE__->meta->add_relationships(chart => { type => 'one to one',
+ class => 'SL::DB::Chart',
+ column_map => { chart_id => 'id' },
+ },
+ );
+
+__PACKAGE__->meta->initialize;
+
# Creates get_all, get_all_count, get_all_iterator, delete_all and update_all.
__PACKAGE__->meta->make_manager_class;
];
}
+sub base_factor {
+ my ($self) = @_;
+
+ if (!defined $self->{__base_factor}) {
+ $self->{__base_factor} = !$self->base_unit || !$self->factor || ($self->name eq $self->base_unit) ? 1 : $self->factor * $self->base->base_factor;
+ }
+
+ return $self->{__base_factor};
+}
+
+sub convert_to {
+ my ($self, $qty, $other_unit) = @_;
+
+ my $my_base_factor = $self->base_factor || 1;
+ my $other_base_factor = $other_unit->base_factor || 1;
+
+ return $qty * $my_base_factor / $other_base_factor;
+}
+
1;
$::locale = undef;
$::form = undef;
$::myconfig = ();
- Form::disconnect_standard_dbh();
+ Form::disconnect_standard_dbh unless $self->_interface_is_fcgi;
$::lxdebug->end_request;
$::lxdebug->leave_sub;
sub unrequire_bin_mozilla {
my $self = shift;
- return unless $self->{interface} =~ m/^(?:fastcgi|fcgid|fcgi)$/;
+ return unless $self->_interface_is_fcgi;
for (keys %INC) {
next unless m#^bin/mozilla/#;
}
}
+sub _interface_is_fcgi {
+ my $self = shift;
+ return $self->{interface} =~ m/^(?:fastcgi|fcgid|fcgi)$/;
+}
+
sub _route_request {
my $script_name = shift;
use CGI::Ajax;
use Cwd;
use Encode;
+use File::Copy;
use IO::File;
use SL::Auth;
use SL::Auth::DB;
use SL::Auth::LDAP;
use SL::AM;
use SL::Common;
+use SL::CVar;
+use SL::DB;
use SL::DBUtils;
+use SL::DO;
+use SL::IC;
+use SL::IS;
use SL::Mailer;
use SL::Menu;
+use SL::OE;
use SL::Template;
use SL::User;
use Template;
use URI;
use List::Util qw(first max min sum);
-use List::MoreUtils qw(any apply);
+use List::MoreUtils qw(all any apply);
use strict;
$main::lxdebug->leave_sub();
}
+sub throw_on_error {
+ my ($self, $code) = @_;
+ local $self->{__ERROR_HANDLER} = sub { die({ error => $_[0] }) };
+ $code->();
+}
+
sub error {
$main::lxdebug->enter_sub();
$main::lxdebug->show_backtrace();
my ($self, $msg) = @_;
- if ($ENV{HTTP_USER_AGENT}) {
+
+ if ($self->{__ERROR_HANDLER}) {
+ $self->{__ERROR_HANDLER}->($msg);
+
+ } elsif ($ENV{HTTP_USER_AGENT}) {
$msg =~ s/\n/<br>/g;
$self->show_generic_error($msg);
my ($self, $error, %params) = @_;
+ if ($self->{__ERROR_HANDLER}) {
+ $self->{__ERROR_HANDLER}->($error);
+ $main::lxdebug->leave_sub();
+ return;
+ }
+
my $add_params = {
'title_error' => $params{title},
'label_error' => $error,
$self->error("$self->{IN} : " . $template->get_error());
}
+ if ($self->{media} eq 'file') {
+ copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
+ $self->cleanup;
+ chdir("$self->{cwd}");
+
+ $::lxdebug->leave_sub();
+
+ return;
+ }
+
if ($template->uses_temp_file() || $self->{media} eq 'email') {
if ($self->{media} eq 'email') {
undef $standard_dbh;
}
- $standard_dbh ||= $self->dbconnect_noauto($myconfig);
+ $standard_dbh ||= SL::DB::create->dbh;
$main::lxdebug->leave_sub(2);
$main::lxdebug->leave_sub();
}
+sub prepare_for_printing {
+ my ($self) = @_;
+
+ $self->{templates} ||= $::myconfig{templates};
+ $self->{formname} ||= $self->{type};
+ $self->{media} ||= 'email';
+
+ die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
+
+ # set shipto from billto unless set
+ my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
+ if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
+ $self->{shiptoname} = $::myconfig{company};
+ $self->{shiptostreet} = $::myconfig{address};
+ }
+
+ my $language = $self->{language} ? '_' . $self->{language} : '';
+
+ my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
+ if ($self->{language_id}) {
+ ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
+ } else {
+ $output_dateformat = $::myconfig{dateformat};
+ $output_numberformat = $::myconfig{numberformat};
+ $output_longdates = 1;
+ }
+
+ # Retrieve accounts for tax calculation.
+ IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
+
+ if ($self->{type} =~ /_delivery_order$/) {
+ DO->order_details();
+ } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
+ OE->order_details(\%::myconfig, $self);
+ } else {
+ IS->invoice_details(\%::myconfig, $self, $::locale);
+ }
+
+ # Chose extension & set source file name
+ my $extension = 'html';
+ if ($self->{format} eq 'postscript') {
+ $self->{postscript} = 1;
+ $extension = 'tex';
+ } elsif ($self->{"format"} =~ /pdf/) {
+ $self->{pdf} = 1;
+ $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
+ } elsif ($self->{"format"} =~ /opendocument/) {
+ $self->{opendocument} = 1;
+ $extension = 'odt';
+ } elsif ($self->{"format"} =~ /excel/) {
+ $self->{excel} = 1;
+ $extension = 'xls';
+ }
+
+ my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
+ my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
+ $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
+
+ # Format dates.
+ $self->format_dates($output_dateformat, $output_longdates,
+ qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
+ transdate_oe deliverydate_oe employee_startdate employee_enddate),
+ grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
+
+ $self->reformat_numbers($output_numberformat, 2,
+ qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
+ grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
+
+ $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
+
+ my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
+
+ if (scalar @{ $cvar_date_fields }) {
+ $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
+ }
+
+ while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
+ $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
+ }
+
+ return $self;
+}
+
+sub format_dates {
+ my ($self, $dateformat, $longformat, @indices) = @_;
+
+ $dateformat ||= $::myconfig{dateformat};
+
+ foreach my $idx (@indices) {
+ if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
+ for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
+ $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
+ }
+ }
+
+ next unless defined $self->{$idx};
+
+ if (!ref($self->{$idx})) {
+ $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
+
+ } elsif (ref($self->{$idx}) eq "ARRAY") {
+ for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
+ $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
+ }
+ }
+ }
+}
+
+sub reformat_numbers {
+ my ($self, $numberformat, $places, @indices) = @_;
+
+ return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
+
+ foreach my $idx (@indices) {
+ if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
+ for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
+ $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
+ }
+ }
+
+ next unless defined $self->{$idx};
+
+ if (!ref($self->{$idx})) {
+ $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
+
+ } elsif (ref($self->{$idx}) eq "ARRAY") {
+ for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
+ $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
+ }
+ }
+ }
+
+ my $saved_numberformat = $::myconfig{numberformat};
+ $::myconfig{numberformat} = $numberformat;
+
+ foreach my $idx (@indices) {
+ if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
+ for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
+ $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
+ }
+ }
+
+ next unless defined $self->{$idx};
+
+ if (!ref($self->{$idx})) {
+ $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
+
+ } elsif (ref($self->{$idx}) eq "ARRAY") {
+ for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
+ $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
+ }
+ }
+ }
+
+ $::myconfig{numberformat} = $saved_numberformat;
+}
+
1;
__END__
=head1 NAME
-SL::Helpers::Flash - helper functions for storing messages to be
+SL::Helper::Flash - helper functions for storing messages to be
displayed to the user
=head1 SYNOPSIS
$query = qq|UPDATE ar SET paid = ? WHERE id = ?|;
do_query($form, $dbh, $query, $form->{paid}, conv_i($form->{id}));
- if (!$provided_dbh) {
- $dbh->commit();
- $dbh->disconnect();
- }
+ $dbh->commit if !$provided_dbh;
$main::lxdebug->leave_sub();
return;
'table' => 'ar',);
my $rc = 1;
- if (!$provided_dbh) {
- $dbh->commit();
- $dbh->disconnect();
- }
+ $dbh->commit if !$provided_dbh;
$main::lxdebug->leave_sub();
# Falls wir ein Storno haben, müssen zwei Felder in der stornierten Rechnung wieder
# zurückgesetzt werden. Vgl:
- # id | storno | storno_id | paid | amount
+ # id | storno | storno_id | paid | amount
#----+--------+-----------+---------+-----------
# 18 | f | | 0.00000 | 119.00000
# ZU:
package OE;
use List::Util qw(max first);
+use YAML;
+
use SL::AM;
use SL::Common;
use SL::CVar;
+use SL::DB::PeriodicInvoicesConfig;
use SL::DBUtils;
use SL::IC;
my @values;
my $where;
+ my ($periodic_invoices_columns, $periodic_invoices_joins);
+
my $rate = ($form->{vc} eq 'customer') ? 'buy' : 'sell';
if ($form->{type} =~ /_quotation$/) {
$quotation = '1';
$ordnumber = 'quonumber';
+
+ } elsif ($form->{type} eq 'sales_order') {
+ $periodic_invoices_columns = qq| , COALESCE(pcfg.active, 'f') AS periodic_invoices |;
+ $periodic_invoices_joins = qq| LEFT JOIN periodic_invoices_configs pcfg ON (o.id = pcfg.oe_id) |;
}
my $vc = $form->{vc} eq "customer" ? "customer" : "vendor";
qq| pr.projectnumber AS globalprojectnumber, | .
qq| e.name AS employee, s.name AS salesman, | .
qq| ct.${vc}number AS vcnumber, ct.country, ct.ustid | .
+ $periodic_invoices_columns .
qq|FROM oe o | .
qq|JOIN $vc ct ON (o.${vc}_id = ct.id) | .
qq|LEFT JOIN employee e ON (o.employee_id = e.id) | .
qq|LEFT JOIN exchangerate ex ON (ex.curr = o.curr | .
qq| AND ex.transdate = o.transdate) | .
qq|LEFT JOIN project pr ON (o.globalproject_id = pr.id) | .
+ qq|$periodic_invoices_joins | .
qq|WHERE (o.quotation = ?) |;
push(@values, $quotation);
push(@values, '%' . $form->{transaction_description} . '%');
}
+ if ($form->{periodic_invoices_active} ne $form->{periodic_invoices_inactive}) {
+ my $not = 'NOT' if ($form->{periodic_invoices_inactive});
+ $query .= qq| AND ${not} COALESCE(pcfg.active, 'f')|;
+ }
+
my $sortdir = !defined $form->{sortdir} ? 'ASC' : $form->{sortdir} ? 'ASC' : 'DESC';
my $sortorder = join(', ', map { "${_} ${sortdir} " } ("o.id", $form->sort_columns("transdate", $ordnumber, "name")));
my %allowed_sort_columns = (
my ($self, $myconfig, $form) = @_;
# connect to database, turn off autocommit
- my $dbh = $form->dbconnect_noauto($myconfig);
+ my $dbh = $form->get_standard_dbh;
my ($query, @values, $sth, $null);
my $exchangerate = 0;
}
}
+ $self->save_periodic_invoices_config(dbh => $dbh,
+ oe_id => $form->{id},
+ config_yaml => $form->{periodic_invoices_config})
+ if ($form->{type} eq 'sales_order');
+
$form->{saved_xyznumber} = $form->{$form->{type} =~ /_quotation$/ ?
"quonumber" : "ordnumber"};
Common::webdav_folder($form) if ($main::webdav);
my $rc = $dbh->commit;
- $dbh->disconnect;
$main::lxdebug->leave_sub();
return $rc;
}
+sub save_periodic_invoices_config {
+ my ($self, %params) = @_;
+
+ return if !$params{oe_id};
+
+ my $config = $params{config_yaml} ? YAML::Load($params{config_yaml}) : undef;
+ return if 'HASH' ne ref $config;
+
+ my $obj = SL::DB::Manager::PeriodicInvoicesConfig->find_by(oe_id => $params{oe_id})
+ || SL::DB::PeriodicInvoicesConfig->new(oe_id => $params{oe_id});
+ $obj->update_attributes(%{ $config });
+}
+
+sub load_periodic_invoice_config {
+ my $self = shift;
+ my $form = shift;
+
+ delete $form->{periodic_invoices_config};
+
+ if ($form->{id}) {
+ my $config_obj = SL::DB::Manager::PeriodicInvoicesConfig->find_by(oe_id => $form->{id});
+
+ if ($config_obj) {
+ my $config = { map { $_ => $config_obj->$_ } qw(active terminated periodicity start_date_as_date end_date_as_date extend_automatically_by ar_chart_id
+ print printer_id copies) };
+ $form->{periodic_invoices_config} = YAML::Dump($config);
+ }
+ }
+}
+
sub _close_quotations_rfqs {
$main::lxdebug->enter_sub();
# delete-values
@values = (conv_i($form->{id}));
+ # periodic invoices and their configuration
+ do_query($form, $dbh, qq|DELETE FROM periodic_invoices WHERE config_id IN (SELECT id FROM periodic_invoices_configs WHERE oe_id = ?)|, @values);
+ do_query($form, $dbh, qq|DELETE FROM periodic_invoices_configs WHERE oe_id = ?|, @values);
+
# delete status entries
$query = qq|DELETE FROM status | .
qq|WHERE trans_id = ?|;
Common::webdav_folder($form) if ($main::webdav);
+ $self->load_periodic_invoice_config($form);
+
my $rc = $dbh->commit;
- $dbh->disconnect;
$main::lxdebug->leave_sub();
}
sub format_dates {
- $main::lxdebug->enter_sub();
-
- my ($dateformat, $longformat, @indices) = @_;
-
- my $form = $main::form;
- my %myconfig = %main::myconfig;
- my $locale = $main::locale;
-
- $dateformat = $myconfig{"dateformat"} unless ($dateformat);
-
- foreach my $idx (@indices) {
- if ($form->{TEMPLATE_ARRAYS} && (ref($form->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
- for (my $i = 0; $i < scalar(@{$form->{TEMPLATE_ARRAYS}->{$idx}}); $i++) {
- $form->{TEMPLATE_ARRAYS}->{$idx}->[$i] =
- $locale->reformat_date(\%myconfig, $form->{TEMPLATE_ARRAYS}->{$idx}->[$i],
- $dateformat, $longformat);
- }
- }
-
- next unless (defined($form->{$idx}));
-
- if (!ref($form->{$idx})) {
- $form->{$idx} = $locale->reformat_date(\%myconfig, $form->{$idx},
- $dateformat, $longformat);
-
- } elsif (ref($form->{$idx}) eq "ARRAY") {
- for (my $i = 0; $i < scalar(@{$form->{$idx}}); $i++) {
- $form->{$idx}->[$i] =
- $locale->reformat_date(\%myconfig, $form->{$idx}->[$i],
- $dateformat, $longformat);
- }
- }
- }
-
- $main::lxdebug->leave_sub();
+ return $::form->format_dates(@_);
}
sub reformat_numbers {
- $main::lxdebug->enter_sub();
-
- my ($numberformat, $places, @indices) = @_;
-
- my $form = $main::form;
- my %myconfig = %main::myconfig;
-
- return $main::lxdebug->leave_sub()
- if (!$numberformat || ($numberformat eq $myconfig{"numberformat"}));
-
- foreach my $idx (@indices) {
- if ($form->{TEMPLATE_ARRAYS} && (ref($form->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
- for (my $i = 0; $i < scalar(@{$form->{TEMPLATE_ARRAYS}->{$idx}}); $i++) {
- $form->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $form->parse_amount(\%myconfig, $form->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
- }
- }
-
- next unless (defined($form->{$idx}));
-
- if (!ref($form->{$idx})) {
- $form->{$idx} = $form->parse_amount(\%myconfig, $form->{$idx});
-
- } elsif (ref($form->{$idx}) eq "ARRAY") {
- for (my $i = 0; $i < scalar(@{$form->{$idx}}); $i++) {
- $form->{$idx}->[$i] =
- $form->parse_amount(\%myconfig, $form->{$idx}->[$i]);
- }
- }
- }
-
- my $saved_numberformat = $myconfig{"numberformat"};
- $myconfig{"numberformat"} = $numberformat;
-
- foreach my $idx (@indices) {
- if ($form->{TEMPLATE_ARRAYS} && (ref($form->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
- for (my $i = 0; $i < scalar(@{$form->{TEMPLATE_ARRAYS}->{$idx}}); $i++) {
- $form->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $form->format_amount(\%myconfig, $form->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
- }
- }
-
- next unless (defined($form->{$idx}));
-
- if (!ref($form->{$idx})) {
- $form->{$idx} = $form->format_amount(\%myconfig, $form->{$idx}, $places);
-
- } elsif (ref($form->{$idx}) eq "ARRAY") {
- for (my $i = 0; $i < scalar(@{$form->{$idx}}); $i++) {
- $form->{$idx}->[$i] =
- $form->format_amount(\%myconfig, $form->{$idx}->[$i], $places);
- }
- }
- }
-
- $myconfig{"numberformat"} = $saved_numberformat;
-
- $main::lxdebug->leave_sub();
-}
-
-# -------------------------------------------------------------------------
-
-sub show_history {
- $main::lxdebug->enter_sub();
-
- my $form = $main::form;
- my %myconfig = %main::myconfig;
- my $locale = $main::locale;
-
- my $dbh = $form->dbconnect(\%myconfig);
- my ($sort, $sortby) = split(/\-\-/, $form->{order});
- $sort =~ s/.*\.(.*)/$1/;
-
- $form->{title} = $locale->text("History");
- $form->header();
- print $form->parse_html_template( "common/show_history", {
- "DATEN" => $form->get_history($dbh,$form->{input_name},"",$form->{order}),
- "SUCCESS" => ($form->get_history($dbh,$form->{input_name}) ne "0"),
- uc($sort) => 1,
- uc($sort)."BY" => $sortby
- } );
-
- $dbh->disconnect();
- $main::lxdebug->leave_sub();
+ return $::form->format_numbers(@_);
}
# -------------------------------------------------------------------------
use SL::MoreCommon qw(ary_diff);
use SL::PE;
use SL::ReportGenerator;
+use List::MoreUtils qw(any none);
use List::Util qw(max reduce sum);
use Data::Dumper;
$onload .= qq|;setupPoints('|. $myconfig{numberformat} .qq|', '|. $locale->text("wrongformat") .qq|')|;
$TMPL_VAR{onload} = $onload;
+ if ($form->{type} eq 'sales_order') {
+ if (!$form->{periodic_invoices_config}) {
+ $form->{periodic_invoices_status} = $locale->text('not configured');
+
+ } else {
+ my $config = YAML::Load($form->{periodic_invoices_config});
+ $form->{periodic_invoices_status} = $config->{active} ? $locale->text('active') : $locale->text('inactive');
+ }
+ }
+
$form->{javascript} .= qq|<script type="text/javascript" src="js/show_form_details.js"></script>|;
$form->{javascript} .= qq|<script type="text/javascript" src="js/show_history.js"></script>|;
$form->{javascript} .= qq|<script type="text/javascript" src="js/show_vc_details.js"></script>|;
"salesman",
"shipvia", "globalprojectnumber",
"transaction_description", "open",
- "delivered", "marge_total", "marge_percent",
+ "delivered", "periodic_invoices",
+ "marge_total", "marge_percent",
"vcnumber", "ustid",
"country",
);
unshift @columns, "ids";
}
- $form->{l_open} = $form->{l_closed} = "Y" if ($form->{open} && $form->{closed});
- $form->{l_delivered} = "Y" if ($form->{delivered} && $form->{notdelivered});
+ $form->{l_open} = $form->{l_closed} = "Y" if ($form->{open} && $form->{closed});
+ $form->{l_delivered} = "Y" if ($form->{delivered} && $form->{notdelivered});
+ $form->{l_periodic_invoices} = "Y" if ($form->{periodic_invoices_active} && $form->{periodic_invoices_inactive});
my $attachment_basename;
if ($form->{vc} eq 'vendor') {
my @hidden_variables = map { "l_${_}" } @columns;
push @hidden_variables, "l_subtotal", $form->{vc}, qw(l_closed l_notdelivered open closed delivered notdelivered ordnumber quonumber
transaction_description transdatefrom transdateto type vc employee_id salesman_id
- reqdatefrom reqdateto projectnumber project_id);
+ reqdatefrom reqdateto projectnumber project_id periodic_invoices_active periodic_invoices_inactive);
my $href = build_std_url('action=orders', grep { $form->{$_} } @hidden_variables);
'vcnumber' => { 'text' => $form->{vc} eq 'customer' ? $locale->text('Customer Number') : $locale->text('Vendor Number'), },
'country' => { 'text' => $locale->text('Country'), },
'ustid' => { 'text' => $locale->text('USt-IdNr.'), },
+ 'periodic_invoices' => { 'text' => $locale->text('Per. Inv.'), },
);
foreach my $name (qw(id transdate reqdate quonumber ordnumber name employee salesman shipvia transaction_description)) {
push @options, $locale->text('Closed') if $form->{closed};
push @options, $locale->text('Delivered') if $form->{delivered};
push @options, $locale->text('Not delivered') if $form->{notdelivered};
+ push @options, $locale->text('Periodic invoices active') if $form->{periodic_invoices_actibe};
$report->set_options('top_info_text' => join("\n", @options),
'raw_top_info_text' => $form->parse_html_template('oe/orders_top'),
foreach my $oe (@{ $form->{OE} }) {
map { $oe->{$_} *= $oe->{exchangerate} } @subtotal_columns;
- $oe->{tax} = $oe->{amount} - $oe->{netamount};
- $oe->{open} = $oe->{closed} ? $locale->text('No') : $locale->text('Yes');
- $oe->{delivered} = $oe->{delivered} ? $locale->text('Yes') : $locale->text('No');
+ $oe->{tax} = $oe->{amount} - $oe->{netamount};
+ $oe->{open} = $oe->{closed} ? $locale->text('No') : $locale->text('Yes');
+ $oe->{delivered} = $oe->{delivered} ? $locale->text('Yes') : $locale->text('No');
+ $oe->{periodic_invoices} = $oe->{periodic_invoices} ? $locale->text('On') : $locale->text('Off');
map { $subtotals{$_} += $oe->{$_};
$totals{$_} += $oe->{$_} } @subtotal_columns;
return $content;
}
+sub edit_periodic_invoices_config {
+ $::lxdebug->enter_sub();
+
+ $::form->{type} = 'sales_order';
+
+ check_oe_access();
+
+ my $config;
+ $config = YAML::Load($::form->{periodic_invoices_config}) if $::form->{periodic_invoices_config};
+
+ if ('HASH' ne ref $config) {
+ $config = { periodicity => 'y',
+ start_date_as_date => $::form->{transdate},
+ extend_automatically_by => 12,
+ active => 1,
+ };
+ }
+
+ $config->{periodicity} = 'm' if none { $_ eq $config->{periodicity} } qw(m q y);
+
+ $::form->get_lists(printers => "ALL_PRINTERS",
+ charts => { key => 'ALL_CHARTS',
+ transdate => 'current_date' });
+
+ $::form->{AR} = [ grep { $_->{link} =~ m/(?:^|:)AR(?::|$)/ } @{ $::form->{ALL_CHARTS} } ];
+ $::form->{title} = $::locale->text('Edit the configuration for periodic invoices');
+
+ $::form->header();
+ print $::form->parse_html_template('oe/edit_periodic_invoices_config', $config);
+
+ $::lxdebug->leave_sub();
+}
+
+sub save_periodic_invoices_config {
+ $::lxdebug->enter_sub();
+
+ $::form->{type} = 'sales_order';
+
+ check_oe_access();
+
+ $::form->isblank('start_date_as_date', $::locale->text('The start date is missing.'));
+
+ my $config = { active => $::form->{active} ? 1 : 0,
+ terminated => $::form->{terminated} ? 1 : 0,
+ periodicity => (any { $_ eq $::form->{periodicity} } qw(m q y)) ? $::form->{periodicity} : 'm',
+ start_date_as_date => $::form->{start_date_as_date},
+ end_date_as_date => $::form->{end_date_as_date},
+ print => $::form->{print} ? 1 : 0,
+ printer_id => $::form->{print} ? $::form->{printer_id} * 1 : undef,
+ copies => $::form->{copies} * 1 ? $::form->{copies} : 1,
+ extend_automatically_by => $::form->{extend_automatically_by} * 1 || undef,
+ ar_chart_id => $::form->{ar_chart_id} * 1,
+ };
+
+ $::form->{periodic_invoices_config} = YAML::Dump($config);
+
+ $::form->{title} = $::locale->text('Edit the configuration for periodic invoices');
+ $::form->header;
+ print $::form->parse_html_template('oe/save_periodic_invoices_config', $config);
+
+ $::lxdebug->leave_sub();
+}
+
sub dispatcher {
my $form = $main::form;
my $locale = $main::locale;
--- /dev/null
+[periodic_invoices]
+# The user name a report about the posted and printed invoices is sent
+# to.
+send_email_to = login
+# The "From:" header for said email.
+email_from = Lx-Office Daemon <root@localhost>
+# The subject for said email.
+email_subject = Benachrichtigung: automatisch erstellte Rechnungen
+# The template file used for the email's body.
+email_template = templates/webpages/oe/periodic_invoices_email.txt
--- /dev/null
+[task_server]
+# User name to use for database access
+login =
+# Set to 1 for debug messages in /tmp/lx-office-debug.log
+debug = 0
+# Chose a system user the daemon should run under when started as root.
+run_as = www
--- /dev/null
+function edit_periodic_invoices_config() {
+ var width = 750;
+ var height = 550;
+ var parm = centerParms(width, height) + ",width=" + width + ",height=" + height + ",status=yes,scrollbars=yes";
+
+ var config = $('#periodic_invoices_config').attr('value');
+ var transdate = $('#transdate').attr('value');
+
+ var url = "oe.pl?" +
+ "action=edit_periodic_invoices_config&" +
+ "periodic_invoices_config=" + encodeURIComponent(config) + "&" +
+ "transdate=" + encodeURIComponent(transdate);
+
+ // alert(url);
+ window.open(url, "_new_generic", parm);
+}
'Company Name' => 'Firmenname',
'Compare to' => 'Gegenüberstellen zu',
'Configuration of individual TODO items' => 'Konfiguration für die einzelnen Aufgabenlistenpunkte',
+ 'Configure' => 'Konfigurieren',
'Confirm' => 'Bestätigen',
'Confirm!' => 'Bestätigen Sie!',
'Confirmation' => 'Auftragsbestätigung',
'Edit rights' => 'Rechte bearbeiten',
'Edit templates' => 'Vorlagen bearbeiten',
'Edit the Delivery Order' => 'Lieferschein bearbeiten',
+ 'Edit the configuration for periodic invoices' => 'Konfiguration für wiederkehrende Rechnungen bearbeiten',
'Edit the membership of all users in all groups:' => 'Bearbeiten der Mitgliedschaft aller Benutzer in allen Gruppen:',
'Edit the purchase_order' => 'Bearbeiten des Lieferantenauftrags',
'Edit the request_quotation' => 'Bearbeiten der Preisanfrage',
'Element disabled' => 'Element deaktiviert',
'Employee' => 'Bearbeiter',
'Empty transaction!' => 'Buchung ist leer!',
+ 'End date' => 'Enddatum',
'Enter a description for this new draft.' => 'Geben Sie eine Beschreibung für diesen Entwurf ein.',
'Enter longdescription' => 'Langtext eingeben',
'Enter the requested execution date or leave empty for the quickest possible execution:' => 'Geben Sie das jeweils gewünschte Ausführungsdatum an, oder lassen Sie das Feld leer für die schnellstmögliche Ausführung:',
'Export date' => 'Exportdatum',
'Export date from' => 'Exportdatum von',
'Export date to' => 'Exportdatum bis',
+ 'Extend automatically by n months' => 'Automatische Verlängerung um x Monate',
'Extended' => 'Gesamt',
'Extension Of Time' => 'Dauerfristverlängerung',
'Factor' => 'Faktor',
'Payment posted!' => 'Zahlung gebucht!',
'Payment terms deleted!' => 'Zahlungskonditionen gelöscht!',
'Payments' => 'Zahlungsausgänge',
+ 'Per. Inv.' => 'Wied. Rech.',
'Period' => 'Zeitraum',
'Period:' => 'Zeitraum:',
+ 'Periodic Invoices' => 'Wiederkehrende Rechnungen',
+ 'Periodic invoices active' => 'Wiederkehrende Rechnungen aktiv',
+ 'Periodic invoices inactive' => 'Wiederkehrende Rechnungen inaktiv',
+ 'Periodicity' => 'Periodizität',
'Personal settings' => 'Persönliche Einstellungen',
'Pg Database Administration' => 'Datenbankadministration',
'Phone' => 'Telefon',
'Pricegroups' => 'Preisgruppen',
'Print' => 'Drucken',
'Print and Post' => 'Drucken und Buchen',
+ 'Print automatically' => 'Automatisch ausdrucken',
'Print dunnings' => 'Mahnungen drucken',
'Print list' => 'Liste ausdrucken',
'Print options' => 'Druckoptionen',
'Spoolfile' => 'Druckdatei',
'Start Dunning Process' => 'Mahnprozess starten',
'Start analysis' => 'Analyse beginnen',
+ 'Start date' => 'Startdatum',
'Start the correction assistant' => 'Korrekturassistenten starten',
'Startdate_coa' => 'Gültig ab',
'Starting Balance' => 'Eröffnungsbilanzwerte',
'Statement Balance' => 'Sammelrechnungsbilanz',
'Statement sent to' => 'Sammelrechnung verschickt an',
'Statements sent to printer!' => 'Sammelrechnungen an Drucker geschickt!',
+ 'Status' => 'Status',
'Step 1 of 3: Parts' => 'Schritt 1 von 3: Waren',
'Step 2' => 'Schritt 2',
'Step 2 of 3: Services' => 'Schritt 2 von 3: Dienstleistungen',
'The dunning process started' => 'Der Mahnprozess ist gestartet.',
'The dunnings have been printed.' => 'Die Mahnung(en) wurden gedruckt.',
'The email address is missing.' => 'Die Emailadresse fehlt.',
+ 'The end date is the last day for which invoices will possibly be created.' => 'Das Enddatum ist das letztmögliche Datum, an dem eine Rechnung erzeugt wird.',
'The factor is missing in row %d.' => 'Der Faktor fehlt in Zeile %d.',
'The factor is missing.' => 'Der Faktor fehlt.',
'The first reason is that Lx-Office contained a bug which resulted in the wrong taxkeys being recorded for transactions in which two entries are posted for the same chart with different taxkeys.' => 'Zum Einen gab es einen Bug in Lx-Office, der dazu führte, dass bei Buchungen mit verschiedenen Steuerschlüssel auf ein Konto teilweise falsche Steuerschlüssel gespeichert wurden.',
'The selected warehouse is empty.' => 'Das ausgewählte Lager ist leer.',
'The session is invalid or has expired.' => 'Sie sind von Lx-Office abgemeldet.',
'The source warehouse does not contain any bins.' => 'Das Quelllager enthält keine Lagerplätze.',
+ 'The start date is missing.' => 'Das Startdatum fehlt.',
'The subject is missing.' => 'Der Betreff fehlt.',
'The tables for user management and authentication do not exist. They will be created in the next step in the following database:' => 'Die Tabellen zum Speichern der Benutzerdaten und zur Benutzerauthentifizierung wurden nicht gefunden. Sie werden in der folgenden Datenbank angelegt:',
'The tabulator character' => 'Das Tabulator-Symbol',
'[email]' => '[email]',
'account_description' => 'Beschreibung',
'accrual' => 'Bilanzierung (Soll-Versteuerung)',
+ 'active' => 'aktiv',
'all entries' => 'alle Einträge',
'ap_aging_list' => 'liste_offene_verbindlichkeiten',
'ar_aging_list' => 'liste_offene_forderungen',
'general_ledger_list' => 'buchungsjournal',
'history' => 'Historie',
'history search engine' => 'Historien Suchmaschine',
+ 'inactive' => 'inaktiv',
'invoice' => 'Rechnung',
'invoice_list' => 'debitorenbuchungsliste',
'lead deleted!' => 'Kundenquelle gelöscht',
'mark as paid' => 'als bezahlt markieren',
'missing' => 'Fehlbestand',
'month' => 'Monatliche Abgabe',
+ 'monthly' => 'monatlich',
'new Window' => 'neues Fenster',
'no' => 'nein',
'no bestbefore' => 'keine Mindesthaltbarkeit',
'no chargenumber' => 'keine Chargennummer',
'none (pricegroup)' => 'keine',
+ 'not configured' => 'nicht konfiguriert',
'not executed' => 'nicht ausgeführt',
'not transferred in yet' => 'noch nicht eingelagert',
'not transferred out yet' => 'noch nicht ausgelagert',
'purchase_order' => 'Auftrag',
'purchase_order_list' => 'lieferantenauftragsliste',
'quarter' => 'Vierteljährliche (quartalsweise) Abgabe',
+ 'quarterly' => 'quartalsweise',
'quotation_list' => 'angebotsliste',
'release_material' => 'Materialausgabebe',
'report_generator_dispatch_to is not defined.' => 'report_generator_dispatch_to ist nicht definiert.',
'tax_taxdescription' => 'Steuername',
'tax_taxkey' => 'Steuerschlüssel',
'taxnumber' => 'Automatikkonto',
+ 'terminated' => 'gekündigt',
'to (date)' => 'bis',
'to (time)' => 'bis',
'transfer' => 'Umlagerung',
'warehouse_journal_list' => 'lagerbuchungsliste',
'warehouse_report_list' => 'lagerbestandsliste',
'wrongformat' => 'Falsches Format',
+ 'yearly' => 'jährlich',
'yes' => 'ja',
};
--- /dev/null
+
+# Copyright (C) 2006, David Muir Sharnoff <perl@dave.sharnoff.org>
+
+package Daemon::Generic;
+
+use strict;
+use warnings;
+require Exporter;
+require POSIX;
+use Getopt::Long;
+use File::Slurp;
+use File::Flock;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(newdaemon);
+
+our $VERSION = 0.71;
+
+our $force_quit_delay = 15;
+our $package = __PACKAGE__;
+our $caller;
+
+sub newdaemon
+{
+ my (%args) = @_;
+ my $pkg = $caller || caller() || 'main';
+
+ my $foo = bless {}, $pkg;
+
+ unless ($foo->isa($package)) {
+ no strict qw(refs);
+ my $isa = \@{"${pkg}::ISA"};
+ unshift(@$isa, $package);
+ }
+
+ bless $foo, 'This::Package::Does::Not::Exist';
+ undef $foo;
+
+ new($pkg, %args);
+}
+
+sub new
+{
+ my ($pkg, %args) = @_;
+
+ if ($pkg eq __PACKAGE__) {
+ $pkg = caller() || 'main';
+ }
+
+ srand(time ^ ($$ << 5))
+ unless $args{no_srand};
+
+ my $av0 = $0;
+ $av0 =~ s!/!/.!g;
+
+ my $self = {
+ gd_args => \%args,
+ gd_pidfile => $args{pidfile},
+ gd_logpriority => $args{logpriority},
+ gd_progname => $args{progname}
+ ? $args{progname}
+ : $0,
+ gd_pidbase => $args{pidbase}
+ ? $args{pidbase}
+ : ($args{progname}
+ ? "/var/run/$args{progname}"
+ : "/var/run/$av0"),
+ gd_foreground => $args{foreground} || 0,
+ configfile => $args{configfile}
+ ? $args{configfile}
+ : ($args{progname}
+ ? "/etc/$args{progname}.conf"
+ : "/etc/$av0"),
+ debug => $args{debug} || 0,
+ };
+ bless $self, $pkg;
+
+ $self->gd_getopt;
+ $self->gd_parse_argv;
+
+ my $do = $self->{do} = $ARGV[0];
+
+ $self->gd_help if $do eq 'help';
+ $self->gd_version if $do eq 'version';
+ $self->gd_install if $do eq 'install';
+ $self->gd_uninstall if $do eq 'uninstall';
+
+ $self->gd_pidfile unless $self->{gd_pidfile};
+
+ my %newconfig = $self->gd_preconfig;
+
+ $self->{gd_pidfile} = $newconfig{pidfile} if $newconfig{pidfile};
+
+ print "Configuration looks okay\n" if $do eq 'check';
+
+ my $pidfile = $self->{gd_pidfile};
+ my $killed = 0;
+ my $locked = 0;
+ if (-e $pidfile) {
+ if ($locked = lock($pidfile, undef, 'nonblocking')) {
+ # old process is dead
+ if ($do eq 'status') {
+ print "$0 dead\n";
+ exit 1;
+ }
+ } else {
+ sleep(2) if -M $pidfile < 2/86400;
+ my $oldpid = read_file($pidfile);
+ chomp($oldpid);
+ if ($oldpid) {
+ if ($do eq 'stop' or $do eq 'restart') {
+ $killed = $self->gd_kill($oldpid);
+ $locked = lock($pidfile);
+ if ($do eq 'stop') {
+ unlink($pidfile);
+ exit;
+ }
+ } elsif ($do eq 'reload') {
+ if (kill(1,$oldpid)) {
+ print "Requested reconfiguration\n";
+ exit;
+ } else {
+ print "Kill failed: $!\n";
+ }
+ } elsif ($do eq 'status') {
+ if (kill(0,$oldpid)) {
+ print "$0 running - pid $oldpid\n";
+ $self->gd_check($pidfile, $oldpid);
+ exit 0;
+ } else {
+ print "$0 dead\n";
+ exit 1;
+ }
+ } elsif ($do eq 'check') {
+ if (kill(0,$oldpid)) {
+ print "$0 running - pid $oldpid\n";
+ $self->gd_check($pidfile, $oldpid);
+ exit;
+ }
+ } elsif ($do eq 'start') {
+ print "\u$self->{gd_progname} is already running (pid $oldpid)\n";
+ exit; # according to LSB, this is no error
+ }
+ } else {
+ $self->gd_error("Pid file $pidfile is invalid but locked, exiting\n");
+ }
+ }
+ } else {
+ $locked = lock($pidfile, undef, 'nonblocking')
+ or die "Could not lock pid file $pidfile: $!";
+ }
+
+ if ($do eq 'reload' || $do eq 'stop' || $do eq 'check' || ($do eq 'restart' && ! $killed)) {
+ print "No $0 running\n";
+ }
+
+ if ($do eq 'stop') {
+ unlink($pidfile);
+ exit;
+ }
+
+ if ($do eq 'status') {
+ print "Unused\n";
+ exit 3;
+ }
+
+ if ($do eq 'check') {
+ $self->gd_check($pidfile);
+ exit
+ }
+
+ unless ($do eq 'reload' || $do eq 'restart' || $do eq 'start') {
+ $self->gd_other_cmd($do, $locked);
+ }
+
+ unless ($self->{gd_foreground}) {
+ $self->gd_daemonize;
+ }
+
+ $locked or lock($pidfile, undef, 'nonblocking')
+ or die "Could not lock PID file $pidfile: $!";
+
+ write_file($pidfile, "$$\n");
+
+ print STDERR "Starting up...\n";
+
+ $self->gd_postconfig(%newconfig);
+
+ $self->gd_setup_signals;
+
+ $self->gd_run;
+
+ unlink($pidfile);
+ exit(0);
+}
+
+sub gd_check {}
+
+sub gd_more_opt { return() }
+
+sub gd_getopt
+{
+ my $self = shift;
+ Getopt::Long::Configure("auto_version");
+ GetOptions(
+ 'configfile=s' => \$self->{configfile},
+ 'foreground!' => \$self->{gd_foreground},
+ 'debug!' => \$self->{debug},
+ $self->{gd_args}{options}
+ ? %{$self->{gd_args}{options}}
+ : (),
+ $self->gd_more_opt(),
+ ) or exit($self->gd_usage());
+
+ if (@ARGV < ($self->{gd_args}{minimum_args} || 1)) {
+ exit($self->gd_usage());
+ }
+ if (@ARGV > ($self->{gd_args}{maximum_args} || 1)) {
+ exit($self->gd_usage());
+ }
+}
+
+sub gd_parse_argv { }
+
+sub gd_help
+{
+ my $self = shift;
+ exit($self->gd_usage($self->{gd_args}));
+}
+
+sub gd_version
+{
+ my $self = shift;
+ no strict qw(refs);
+ my $v = $self->{gd_args}{version}
+ || ${ref($self)."::VERSION"}
+ || $::VERSION
+ || $main::VERSION
+ || "?";
+ print "$self->{gd_progname} - version $v\n";;
+ exit;
+}
+
+sub gd_pidfile
+{
+ my $self = shift;
+ my $x = $self->{configfile};
+ $x =~ s!/!.!g;
+ $self->{gd_pidfile} = "$self->{gd_pidbase}$x.pid";
+}
+
+sub gd_other_cmd
+{
+ my $self = shift;
+ $self->gd_usage;
+ exit(1);
+}
+
+sub gd_redirect_output
+{
+ my $self = shift;
+ return if $self->{gd_foreground};
+ my $logname = $self->gd_logname;
+ my $p = $self->{gd_logpriority} ? "-p $self->{gd_logpriority}" : "";
+ open(STDERR, "|logger $p -t '$logname'") or (print "could not open stderr: $!" && exit(1));
+ close(STDOUT);
+ open(STDOUT, ">&STDERR") or die "redirect STDOUT -> STDERR: $!";
+ close(STDIN);
+}
+
+sub gd_daemonize
+{
+ my $self = shift;
+ print "Starting $self->{gd_progname} server\n";
+ $self->gd_redirect_output();
+ my $pid;
+ POSIX::_exit(0) if $pid = fork;
+ die "Could not fork: $!" unless defined $pid;
+ POSIX::_exit(0) if $pid = fork;
+ die "Could not fork: $!" unless defined $pid;
+
+ POSIX::setsid();
+ select(STDERR);
+ $| = 1;
+ print "Sucessfully daemonized\n";
+}
+
+sub gd_logname
+{
+ my $self = shift;
+ return $self->{gd_progname}."[$$]";
+}
+
+sub gd_reconfig_event
+{
+ my $self = shift;
+ print STDERR "Reconfiguration requested\n";
+ $self->gd_postconfig($self->gd_preconfig());
+}
+
+sub gd_quit_event
+{
+ my $self = shift;
+ print STDERR "Quitting...\n";
+ exit(0);
+}
+
+sub gd_setup_signals
+{
+ my $self = shift;
+ $SIG{INT} = sub { $self->gd_quit_event() };
+ $SIG{HUP} = sub { $self->gd_reconfig_event() };
+}
+
+sub gd_run { die "must defined gd_run()" }
+
+sub gd_error
+{
+ my $self = shift;
+ my $e = shift;
+ my $do = $self->{do};
+ if ($do && $do eq 'stop') {
+ warn $e;
+ } else {
+ die $e;
+ }
+}
+
+sub gd_flags_more { return () }
+
+sub gd_flags
+{
+ my $self = shift;
+ return (
+ '-c file' => "Specify configuration file (instead of $self->{configfile})",
+ '-f' => "Run in the foreground (don't detach)",
+ $self->gd_flags_more
+ );
+}
+
+sub gd_commands_more { return () }
+
+sub gd_commands
+{
+ my $self = shift;
+ return (
+ start => "Starts a new $self->{gd_progname} if there isn't one running already",
+ stop => "Stops a running $self->{gd_progname}",
+ reload => "Causes a running $self->{gd_progname} to reload it's config file. Starts a new one if none is running.",
+ restart => "Stops a running $self->{gd_progname} if one is running. Starts a new one.",
+ $self->gd_commands_more(),
+ ($self->gd_can_install()
+ ? ('install' => "Setup $self->{gd_progname} to run automatically after reboot")
+ : ()),
+ ($self->gd_can_uninstall()
+ ? ('uninstall' => "Do not run $self->{gd_progname} after reboots")
+ : ()),
+ check => "Check the configuration file and report the daemon state",
+ help => "Display this usage info",
+ version => "Display the version of $self->{gd_progname}",
+ )
+}
+
+sub gd_positional_more { return() }
+
+sub gd_alts
+{
+ my $offset = shift;
+ my @results;
+ for (my $i = $offset; $i <= $#_; $i += 2) {
+ push(@results, $_[$i]);
+ }
+ return @results;
+}
+
+sub gd_usage
+{
+ my $self = shift;
+
+ require Text::Wrap;
+ import Text::Wrap;
+
+ my $col = 15;
+
+ my @flags = $self->gd_flags;
+ my @commands = $self->gd_commands;
+ my @positional = $self->gd_positional_more;
+
+ my $summary = "Usage: $self->{gd_progname} ";
+ my $details = '';
+ for my $i (gd_alts(0, @flags)) {
+ $summary .= "[ $i ] ";
+ }
+ $summary .= "{ ";
+ $summary .= join(" | ", gd_alts(0, @commands));
+ $summary .= " } ";
+ $summary .= join(" ", gd_alts(0, @positional));
+
+ my (@all) = (@flags, @commands, @positional);
+ while (@all) {
+ my ($key, $desc) = splice(@all, 0, 2);
+ local($Text::Wrap::columns) = 79;
+ $details .= wrap(
+ sprintf(" %-${col}s ", $key),
+ " " x ($col + 2),
+ $desc);
+ $details .= "\n";
+ }
+
+ print "$summary\n$details";
+ return 0;
+}
+
+sub gd_install_pre {}
+sub gd_install_post {}
+
+sub gd_can_install
+{
+ my $self = shift;
+ require File::Basename;
+ my $basename = File::Basename::basename($0);
+ if (
+ -x "/usr/sbin/update-rc.d"
+ &&
+ -x $0
+ &&
+ $0 !~ m{^(?:/usr|/var)?/tmp/}
+ &&
+ eval { symlink("",""); 1 }
+ &&
+ -d "/etc/init.d"
+ &&
+ ! -e "/etc/init.d/$basename"
+ ) {
+ return sub {
+ $self->gd_install_pre("update-rc.d");
+ require Cwd;
+ my $abs_path = Cwd::abs_path($0);
+ symlink($abs_path, "/etc/init.d/$basename")
+ or die "Install failed: symlink /etc/init.d/$basename -> $abs_path: $!\n";
+ print "+ /usr/sbin/update-rc.d $basename defaults\n";
+ system("/usr/sbin/update-rc.d", $basename, "defaults");
+ my $exit = $? >> 8;
+ $self->gd_install_post("update-rc.d");
+ exit($exit) if $exit;
+ };
+ }
+
+ return 0;
+}
+
+sub gd_install
+{
+ my $self = shift;
+ my $ifunc = $self->gd_can_install();
+ die "Install command not supported\n" unless $ifunc;
+ &$ifunc($self);
+ exit(0);
+}
+
+sub gd_uninstall_pre {}
+sub gd_uninstall_post {}
+
+sub gd_can_uninstall
+{
+ my $self = shift;
+ require File::Basename;
+ my $basename = File::Basename::basename($0);
+ require Cwd;
+ my $abs_path = Cwd::abs_path($0) || 'no abs path';
+ my $link = readlink("/etc/init.d/$basename") || 'no link';
+ if (
+ $link eq $abs_path
+ &&
+ -x "/usr/sbin/update-rc.d"
+ ) {
+ return sub {
+ $self->gd_uninstall_pre("update-rc.d");
+ unlink("/etc/init.d/$basename");
+ print "+ /usr/sbin/update-rc.d $basename remove\n";
+ system("/usr/sbin/update-rc.d", $basename, "remove");
+ my $exit = $? >> 8;
+ $self->gd_uninstall_post("update-rc.d");
+ exit($exit) if $exit;
+ }
+ }
+ return 0;
+}
+
+sub gd_uninstall
+{
+ my $self = shift;
+ my $ufunc = $self->gd_can_uninstall();
+ die "Cannot uninstall\n" unless $ufunc;
+ &$ufunc($self);
+ exit(0);
+}
+
+sub gd_kill
+{
+ my ($self, $pid) = @_;
+
+ my $talkmore = 0;
+ my $killed = 0;
+ if (kill(0, $pid)) {
+ $killed = 1;
+ kill(2,$pid);
+ print "Killing $pid\n";
+ my $t = time;
+ sleep(1) if kill(0, $pid);
+ if ($force_quit_delay && kill(0, $pid)) {
+ print "Waiting for $pid to die...\n";
+ $talkmore = 1;
+ while(kill(0, $pid) && time - $t < $force_quit_delay) {
+ sleep(1);
+ }
+ }
+ if (kill(15, $pid)) {
+ print "Killing $pid with -TERM...\n";
+ if ($force_quit_delay) {
+ while(kill(0, $pid) && time - $t < $force_quit_delay * 2) {
+ sleep(1);
+ }
+ } else {
+ sleep(1) if kill(0, $pid);
+ }
+ }
+ if (kill(9, $pid)) {
+ print "Killing $pid with -KILL...\n";
+ my $k9 = time;
+ my $max = $force_quit_delay * 4;
+ $max = 60 if $max < 60;
+ while(kill(0, $pid)) {
+ if (time - $k9 > $max) {
+ print "Giving up on $pid ever dying.\n";
+ exit(1);
+ }
+ print "Waiting for $pid to die...\n";
+ sleep(1);
+ }
+ }
+ print "Process $pid is gone\n" if $talkmore;
+ } else {
+ print "Process $pid no longer running\n";
+ }
+ return $killed;
+}
+
+sub gd_preconfig { die "gd_preconfig() must be redefined"; }
+
+sub gd_postconfig { }
+
+
+1;
--- /dev/null
+
+# Copyright (C) 2006, David Muir Sharnoff <muir@idiom.com>
+
+package Daemon::Generic::Event;
+
+use strict;
+use warnings;
+require Daemon::Generic;
+require Event;
+require Exporter;
+
+our @ISA = qw(Daemon::Generic Exporter);
+our @EXPORT = @Daemon::Generic::EXPORT;
+our $VERSION = 0.3;
+
+sub newdaemon
+{
+ local($Daemon::Generic::caller) = caller() || 'main';
+ local($Daemon::Generic::package) = __PACKAGE__;
+ Daemon::Generic::newdaemon(@_);
+}
+
+sub gd_setup_signals
+{
+ my $self = shift;
+ my $reload_event = Event->signal(
+ signal => 'HUP',
+ desc => 'reload on SIGHUP',
+ prio => 6,
+ cb => sub {
+ $self->gd_reconfig_event;
+ $self->{gd_timer}->cancel()
+ if $self->{gd_timer};
+ $self->gd_setup_timer();
+ },
+ );
+ my $quit_event = Event->signal(
+ signal => 'INT',
+ cb => sub { $self->gd_quit_event; },
+ );
+}
+
+sub gd_setup_timer
+{
+ my $self = shift;
+ if ($self->can('gd_run_body')) {
+ my $interval = ($self->can('gd_interval') && $self->gd_interval()) || 1;
+ $self->{gd_timer} = Event->timer(
+ cb => [ $self, 'gd_run_body' ],
+ interval => $interval,
+ hard => 0,
+ );
+ }
+}
+
+sub gd_run
+{
+ my $self = shift;
+ $self->gd_setup_timer();
+ Event::loop();
+}
+
+sub gd_quit_event
+{
+ my $self = shift;
+ print STDERR "Quitting...\n";
+ Event::unloop_all();
+}
+
+1;
+
+=head1 NAME
+
+ Daemon::Generic::Event - Generic daemon framework with Event.pm
+
+=head1 SYNOPSIS
+
+ use Daemon::Generic::Event;
+
+ @ISA = qw(Daemon::Generic::Event);
+
+ sub gd_preconfig {
+ # stuff
+ }
+
+=head1 DESCRIPTION
+
+Daemon::Generic::Event is a subclass of L<Daemon::Generic> that
+predefines some methods:
+
+=over 15
+
+=item gd_run()
+
+Setup a periodic callback to C<gd_run_body()> if there is a C<gd_run_body()>.
+Call C<Event::loop()>.
+
+=item gd_setup_signals()
+
+Bind SIGHUP to call C<gd_reconfig_event()>.
+Bind SIGINT to call C<gd_quit_event()>.
+
+=back
+
+To use Daemon::Generic::Event, you have to provide a C<gd_preconfig()>
+method. It can be empty if you have a C<gd_run_body()>.
+
+Set up your own events in C<gd_preconfig()> and C<gd_postconfig()>.
+
+If you have a C<gd_run_body()> method, it will be called once per
+second or every C<gd_interval()> seconds if you have a C<gd_interval()>
+method. Unlike in L<Daemon::Generic::While1>, C<gd_run_body()> should
+not include a call to C<sleep()>.
+
+=head1 THANK THE AUTHOR
+
+If you need high-speed internet services (T1, T3, OC3 etc), please
+send me your request-for-quote. I have access to very good pricing:
+you'll save money and get a great service.
+
+=head1 LICENSE
+
+Copyright(C) 2006 David Muir Sharnoff <muir@idiom.com>.
+This module may be used and distributed on the same terms
+as Perl itself.
+
--- /dev/null
+# Copyright (C) 2006, David Muir Sharnoff <muir@idiom.com>
+
+package Daemon::Generic::While1;
+
+use strict;
+use warnings;
+use Carp;
+require Daemon::Generic;
+require POSIX;
+require Exporter;
+
+our @ISA = qw(Daemon::Generic Exporter);
+our @EXPORT = @Daemon::Generic::EXPORT;
+our $VERSION = 0.3;
+
+sub newdaemon
+{
+ local($Daemon::Generic::caller) = caller() || 'main';
+ local($Daemon::Generic::package) = __PACKAGE__;
+ Daemon::Generic::newdaemon(@_);
+}
+
+sub gd_setup_signals
+{
+ my ($self) = @_;
+ $SIG{HUP} = sub {
+ $self->{gd_sighup} = time;
+ };
+ my $child;
+ $SIG{INT} = sub {
+ $self->{gd_sigint} = time;
+ #
+ # We'll be getting a SIGTERM in a bit if we're not dead, so let's use it.
+ #
+ $SIG{TERM} = sub {
+ $self->gd_quit_event();
+ kill(15, $child) if $child; # if we're still alive, let's stay that way
+ };
+ };
+}
+
+sub gd_sleep
+{
+ my ($self, $period) = @_;
+ croak "Sleep period must be defined" unless defined $period;
+ my $hires;
+ if ($period*1000 != int($period*1000)) {
+ $hires = 1;
+ require Time::HiRes;
+ import Time::HiRes qw(time sleep);
+ }
+ my $t = time;
+ while (time - $t < $period) {
+ return if $self->{gd_sigint};
+ return if $self->{gd_sighup};
+ if ($hires) {
+ my $p = (time - $t < 1)
+ ? time - $t
+ : 1;
+ sleep($p);
+ } else {
+ sleep(1);
+ }
+ }
+}
+
+sub gd_run
+{
+ my ($self) = @_;
+ while(1) {
+ if ($self->{gd_sigint}) {
+ $self->{gd_sigint} = 0;
+ $self->gd_quit_event();
+ }
+
+ if ($self->{gd_sighup}) {
+ $self->{gd_sighup} = 0;
+ $self->gd_reconfig_event();
+ }
+
+ $self->gd_run_body();
+ }
+}
+
+sub gd_reconfig_event
+{
+ my $self = shift;
+ print STDERR "Reconfiguration requested\n";
+ $self->gd_postconfig($self->gd_preconfig());
+}
+
+sub gd_quit_event
+{
+ print STDERR "Quitting...\n";
+ exit(0);
+}
+
+
+sub gd_run_body { die "must override gd_run_body()" }
+
+1;
+
+=head1 NAME
+
+ Daemon::Generic::While1 - Daemon framework with default while(1) loop
+
+=head1 SYNOPSIS
+
+ @ISA = qw(Daemon::Generic::While1);
+
+ sub gd_run_body {
+ # stuff
+ }
+
+=head1 DESCRIPTION
+
+This is a slight variation on L<Daemon::Generic>: a default
+C<gd_run()> provided. It has a while(1) loop that calls
+C<gd_run_body()> over and over. It checks for reconifg and
+and terminate events and only actions them between calls
+to C<gd_run_body()>.
+
+Terminate events will be forced through after
+C<$Daemon::Generic::force_quit_delay> seconds if
+C<gd_run_body()> doesn't return quickly enough.
+
+=head1 SUBCLASS METHODS REQUIRD
+
+The following method is required to be overridden to subclass
+Daemon::Generic::While1:
+
+=over 15
+
+=item gd_run_body()
+
+This method will be called over and over. This method should
+include a call to C<sleep(1)> (or a bit more). Reconfig events
+will not interrupt it. Quit events will only interrupt it
+after 15 seconds.
+
+=back
+
+=head1 ADDITIONAL METHODS
+
+The following additional methods are available for your use
+(as compared to L<Daemon::Generic>):
+
+=over 15
+
+=item gd_sleep($period)
+
+This will sleep for C<$period> seconds but in one-second
+intervals so that if a SIGINT or SIGHUP arrives the sleep
+period can end more quickly.
+
+Using this makes it safe for C<gd_run_body()> to sleep for
+longer than C<$Daemon::Generic::force_quit_delay> seconds
+at a time.
+
+=back
+
+=head1 ADDITIONAL MEMBER DATA
+
+The following additional bits of member data are defined:
+
+=over 15
+
+=item gd_sigint
+
+The time at which an (unprocessed) SIGINT was recevied.
+
+=item gd_sighup
+
+The time at which an (unprocessed) SIGHUP was recevied.
+
+=back
+
+=head1 THANK THE AUTHOR
+
+If you need high-speed internet services (T1, T3, OC3 etc), please
+send me your request-for-quote. I have access to very good pricing:
+you'll save money and get a great service.
+
+=head1 LICENSE
+
+Copyright(C) 2006 David Muir Sharnoff <muir@idiom.com>.
+This module may be used and distributed on the same terms
+as Perl itself.
+
--- /dev/null
+package DateTime::Event::Cron;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp;
+
+use vars qw($VERSION);
+
+$VERSION = '0.08';
+
+use constant DEBUG => 0;
+
+use DateTime;
+use DateTime::Set;
+use Set::Crontab;
+
+my %Object_Attributes;
+
+###
+
+sub from_cron {
+ # Return cron as DateTime::Set
+ my $class = shift;
+ my %sparms = @_ == 1 ? (cron => shift) : @_;
+ my %parms;
+ $parms{cron} = delete $sparms{cron};
+ $parms{user_mode} = delete $sparms{user_mode};
+ $parms{cron} or croak "Cron string parameter required.\n";
+ my $dtc = $class->new(%parms);
+ $dtc->as_set(%sparms);
+}
+
+sub from_crontab {
+ # Return list of DateTime::Sets based on entries from
+ # a crontab file.
+ my $class = shift;
+ my %sparms = @_ == 1 ? (file => shift) : @_;
+ my $file = delete $sparms{file};
+ delete $sparms{cron};
+ my $fh = $class->_prepare_fh($file);
+ my @cronsets;
+ while (<$fh>) {
+ chomp;
+ my $set;
+ eval { $set = $class->from_cron(%sparms, cron => $_) };
+ push(@cronsets, $set) if ref $set && !$@;
+ }
+ @cronsets;
+}
+
+sub as_set {
+ # Return self as DateTime::Set
+ my $self = shift;
+ my %sparms = @_;
+ Carp::cluck "Recurrence callbacks overriden by ". ref $self . "\n"
+ if $sparms{next} || $sparms{recurrence} || $sparms{previous};
+ delete $sparms{next};
+ delete $sparms{previous};
+ delete $sparms{recurrence};
+ $sparms{next} = sub { $self->next(@_) };
+ $sparms{previous} = sub { $self->previous(@_) };
+ DateTime::Set->from_recurrence(%sparms);
+}
+
+###
+
+sub new {
+ my $class = shift;
+ my $self = {};
+ bless $self, $class;
+ my %parms = @_ == 1 ? (cron => shift) : @_;
+ my $crontab = $self->_make_cronset(%parms);
+ $self->_cronset($crontab);
+ $self;
+}
+
+sub new_from_cron { new(@_) }
+
+sub new_from_crontab {
+ my $class = shift;
+ my %parms = @_ == 1 ? (file => shift()) : @_;
+ my $fh = $class->_prepare_fh($parms{file});
+ delete $parms{file};
+ my @dtcrons;
+ while (<$fh>) {
+ my $dtc;
+ eval { $dtc = $class->new(%parms, cron => $_) };
+ if (ref $dtc && !$@) {
+ push(@dtcrons, $dtc);
+ $parms{user_mode} = 1 if defined $dtc->user;
+ }
+ }
+ @dtcrons;
+}
+
+###
+
+sub _prepare_fh {
+ my $class = shift;
+ my $fh = shift;
+ if (! ref $fh) {
+ my $file = $fh;
+ local(*FH);
+ $fh = do { local *FH; *FH }; # doubled *FH avoids warning
+ open($fh, "<$file")
+ or croak "Error opening $file for reading\n";
+ }
+ $fh;
+}
+
+###
+
+sub valid {
+ # Is the given date valid according the current cron settings?
+ my($self, $date) = @_;
+ return if !$date || $date->second;
+ $self->minute->contains($date->minute) &&
+ $self->hour->contains($date->hour) &&
+ $self->days_contain($date->day, $date->dow) &&
+ $self->month->contains($date->month);
+}
+
+sub match {
+ # Does the given date match the cron spec?
+ my($self, $date) = @_;
+ $date = DateTime->now unless $date;
+ $self->minute->contains($date->minute) &&
+ $self->hour->contains($date->hour) &&
+ $self->days_contain($date->day, $date->dow) &&
+ $self->month->contains($date->month);
+}
+
+### Return adjacent dates without altering original date
+
+sub next {
+ my($self, $date) = @_;
+ $date = DateTime->now unless $date;
+ $self->increment($date->clone);
+}
+
+sub previous {
+ my($self, $date) = @_;
+ $date = DateTime->now unless $date;
+ $self->decrement($date->clone);
+}
+
+### Change given date to adjacent dates
+
+sub increment {
+ my($self, $date) = @_;
+ $date = DateTime->now unless $date;
+ return $date if $date->is_infinite;
+ do {
+ $self->_attempt_increment($date);
+ } until $self->valid($date);
+ $date;
+}
+
+sub decrement {
+ my($self, $date) = @_;
+ $date = DateTime->now unless $date;
+ return $date if $date->is_infinite;
+ do {
+ $self->_attempt_decrement($date);
+ } until $self->valid($date);
+ $date;
+}
+
+###
+
+sub _attempt_increment {
+ my($self, $date) = @_;
+ ref $date or croak "Reference to datetime object reqired\n";
+ $self->valid($date) ?
+ $self->_valid_incr($date) :
+ $self->_invalid_incr($date);
+}
+
+sub _attempt_decrement {
+ my($self, $date) = @_;
+ ref $date or croak "Reference to datetime object reqired\n";
+ $self->valid($date) ?
+ $self->_valid_decr($date) :
+ $self->_invalid_decr($date);
+}
+
+sub _valid_incr { shift->_minute_incr(@_) }
+
+sub _valid_decr { shift->_minute_decr(@_) }
+
+sub _invalid_incr {
+ # If provided date is valid, return it. Otherwise return
+ # nearest valid date after provided date.
+ my($self, $date) = @_;
+ ref $date or croak "Reference to datetime object reqired\n";
+
+ print STDERR "\nI GOT: ", $date->datetime, "\n" if DEBUG;
+
+ $date->truncate(to => 'minute')->add(minutes => 1)
+ if $date->second;
+
+ print STDERR "RND: ", $date->datetime, "\n" if DEBUG;
+
+ # Find our greatest invalid unit and clip
+ if (!$self->month->contains($date->month)) {
+ $date->truncate(to => 'month');
+ }
+ elsif (!$self->days_contain($date->day, $date->dow)) {
+ $date->truncate(to => 'day');
+ }
+ elsif (!$self->hour->contains($date->hour)) {
+ $date->truncate(to => 'hour');
+ }
+ else {
+ $date->truncate(to => 'minute');
+ }
+
+ print STDERR "BBT: ", $date->datetime, "\n" if DEBUG;
+
+ return $date if $self->valid($date);
+
+ print STDERR "ZZT: ", $date->datetime, "\n" if DEBUG;
+
+ # Extraneous durations clipped. Start searching.
+ while (!$self->valid($date)) {
+ $date->add(months => 1) until $self->month->contains($date->month);
+ print STDERR "MON: ", $date->datetime, "\n" if DEBUG;
+
+ my $day_orig = $date->day;
+ $date->add(days => 1) until $self->days_contain($date->day, $date->dow);
+ $date->truncate(to => 'month') && next if $date->day < $day_orig;
+ print STDERR "DAY: ", $date->datetime, "\n" if DEBUG;
+
+ my $hour_orig = $date->hour;
+ $date->add(hours => 1) until $self->hour->contains($date->hour);
+ $date->truncate(to => 'day') && next if $date->hour < $hour_orig;
+ print STDERR "HOR: ", $date->datetime, "\n" if DEBUG;
+
+ my $min_orig = $date->minute;
+ $date->add(minutes => 1) until $self->minute->contains($date->minute);
+ $date->truncate(to => 'hour') && next if $date->minute < $min_orig;
+ print STDERR "MIN: ", $date->datetime, "\n" if DEBUG;
+ }
+ print STDERR "SET: ", $date->datetime, "\n" if DEBUG;
+ $date;
+}
+
+sub _invalid_decr {
+ # If provided date is valid, return it. Otherwise
+ # return the nearest previous valid date.
+ my($self, $date) = @_;
+ ref $date or croak "Reference to datetime object reqired\n";
+
+ print STDERR "\nD GOT: ", $date->datetime, "\n" if DEBUG;
+
+ if (!$self->month->contains($date->month)) {
+ $date->truncate(to => 'month');
+ }
+ elsif (!$self->days_contain($date->day, $date->dow)) {
+ $date->truncate(to => 'day');
+ }
+ elsif (!$self->hour->contains($date->hour)) {
+ $date->truncate(to => 'hour');
+ }
+ else {
+ $date->truncate(to => 'minute');
+ }
+
+ print STDERR "BBT: ", $date->datetime, "\n" if DEBUG;
+
+ return $date if $self->valid($date);
+
+ print STDERR "ZZT: ", $date->datetime, "\n" if DEBUG;
+
+ # Extraneous durations clipped. Start searching.
+ while (!$self->valid($date)) {
+ if (!$self->month->contains($date->month)) {
+ $date->subtract(months => 1) until $self->month->contains($date->month);
+ $self->_unit_peak($date, 'month');
+ print STDERR "MON: ", $date->datetime, "\n" if DEBUG;
+ }
+ if (!$self->days_contain($date->day, $date->dow)) {
+ my $day_orig = $date->day;
+ $date->subtract(days => 1)
+ until $self->days_contain($date->day, $date->dow);
+ $self->_unit_peak($date, 'month') && next if ($date->day > $day_orig);
+ $self->_unit_peak($date, 'day');
+ print STDERR "DAY: ", $date->datetime, "\n" if DEBUG;
+ }
+ if (!$self->hour->contains($date->hour)) {
+ my $hour_orig = $date->hour;
+ $date->subtract(hours => 1) until $self->hour->contains($date->hour);
+ $self->_unit_peak($date, 'day') && next if ($date->hour > $hour_orig);
+ $self->_unit_peak($date, 'hour');
+ print STDERR "HOR: ", $date->datetime, "\n" if DEBUG;
+ }
+ if (!$self->minute->contains($date->minute)) {
+ my $min_orig = $date->minute;
+ $date->subtract(minutes => 1)
+ until $self->minute->contains($date->minute);
+ $self->_unit_peak($date, 'hour') && next if ($date->minute > $min_orig);
+ print STDERR "MIN: ", $date->datetime, "\n" if DEBUG;
+ }
+ }
+ print STDERR "SET: ", $date->datetime, "\n" if DEBUG;
+ $date;
+}
+
+###
+
+sub _unit_peak {
+ my($self, $date, $unit) = @_;
+ $date && $unit or croak "DateTime ref and unit required.\n";
+ $date->truncate(to => $unit)
+ ->add($unit . 's' => 1)
+ ->subtract(minutes => 1);
+}
+
+### Unit cascades
+
+sub _minute_incr {
+ my($self, $date) = @_;
+ croak "datetime object required\n" unless $date;
+ my $cur = $date->minute;
+ my $next = $self->minute->next($cur);
+ $date->set(minute => $next);
+ $next <= $cur ? $self->_hour_incr($date) : $date;
+}
+
+sub _hour_incr {
+ my($self, $date) = @_;
+ croak "datetime object required\n" unless $date;
+ my $cur = $date->hour;
+ my $next = $self->hour->next($cur);
+ $date->set(hour => $next);
+ $next <= $cur ? $self->_day_incr($date) : $date;
+}
+
+sub _day_incr {
+ my($self, $date) = @_;
+ croak "datetime object required\n" unless $date;
+ $date->add(days => 1);
+ $self->_invalid_incr($date);
+}
+
+sub _minute_decr {
+ my($self, $date) = @_;
+ croak "datetime object required\n" unless $date;
+ my $cur = $date->minute;
+ my $next = $self->minute->previous($cur);
+ $date->set(minute => $next);
+ $next >= $cur ? $self->_hour_decr($date) : $date;
+}
+
+sub _hour_decr {
+ my($self, $date) = @_;
+ croak "datetime object required\n" unless $date;
+ my $cur = $date->hour;
+ my $next = $self->hour->previous($cur);
+ $date->set(hour => $next);
+ $next >= $cur ? $self->_day_decr($date) : $date;
+}
+
+sub _day_decr {
+ my($self, $date) = @_;
+ croak "datetime object required\n" unless $date;
+ $date->subtract(days => 1);
+ $self->_invalid_decr($date);
+}
+
+### Factories
+
+sub _make_cronset { shift; DateTime::Event::Cron::IntegratedSet->new(@_) }
+
+### Shortcuts
+
+sub days_contain { shift->_cronset->days_contain(@_) }
+
+sub minute { shift->_cronset->minute }
+sub hour { shift->_cronset->hour }
+sub day { shift->_cronset->day }
+sub month { shift->_cronset->month }
+sub dow { shift->_cronset->dow }
+sub user { shift->_cronset->user }
+sub command { shift->_cronset->command }
+sub original { shift->_cronset->original }
+
+### Static acessors/mutators
+
+sub _cronset { shift->_attr('cronset', @_) }
+
+sub _attr {
+ my $self = shift;
+ my $name = shift;
+ if (@_) {
+ $Object_Attributes{$self}{$name} = shift;
+ }
+ $Object_Attributes{$self}{$name};
+}
+
+### debugging
+
+sub _dump_sets {
+ my($self, $date) = @_;
+ foreach (qw(minute hour day month dow)) {
+ print STDERR "$_: ", join(',',$self->$_->list), "\n";
+ }
+ if (ref $date) {
+ $date = $date->clone;
+ my @mod;
+ my $mon = $date->month;
+ $date->truncate(to => 'month');
+ while ($date->month == $mon) {
+ push(@mod, $date->day) if $self->days_contain($date->day, $date->dow);
+ $date->add(days => 1);
+ }
+ print STDERR "mod for month($mon): ", join(',', @mod), "\n";
+ }
+ print STDERR "day_squelch: ", $self->_cronset->day_squelch, " ",
+ "dow_squelch: ", $self->_cronset->dow_squelch, "\n";
+ $self;
+}
+
+###
+
+sub DESTROY { delete $Object_Attributes{shift()} }
+
+##########
+
+{
+
+package DateTime::Event::Cron::IntegratedSet;
+
+# IntegratedSet manages the collection of field sets for
+# each cron entry, including sanity checks. Individual
+# field sets are accessed through their respective names,
+# i.e., minute hour day month dow.
+#
+# Also implements some merged field logic for day/dow
+# interactions.
+
+use strict;
+use Carp;
+
+my %Range = (
+ minute => [0..59],
+ hour => [0..23],
+ day => [1..31],
+ month => [1..12],
+ dow => [1..7],
+);
+
+my @Month_Max = qw( 31 29 31 30 31 30 31 31 30 31 30 31 );
+
+my %Object_Attributes;
+
+sub new {
+ my $self = [];
+ bless $self, shift;
+ $self->_range(\%Range);
+ $self->set_cron(@_);
+ $self;
+}
+
+sub set_cron {
+ # Initialize
+ my $self = shift;
+ my %parms = @_;
+ my $cron = $parms{cron};
+ my $user_mode = $parms{user_mode};
+ defined $cron or croak "Cron entry fields required\n";
+ $self->_attr('original', $cron);
+ my @line;
+ if (ref $cron) {
+ @line = grep(!/^\s*$/, @$cron);
+ }
+ else {
+ $cron =~ s/^\s+//;
+ $cron =~ s/\s+$//;
+ @line = split(/\s+/, $cron);
+ }
+ @line >= 5 or croak "At least five cron entry fields required.\n";
+ my @entry = splice(@line, 0, 5);
+ my($user, $command);
+ unless (defined $user_mode) {
+ # auto-detect
+ if (@line > 1 && $line[0] =~ /^\w+$/) {
+ $user_mode = 1;
+ }
+ }
+ $user = shift @line if $user_mode;
+ $command = join(' ', @line);
+ $self->_attr('command', $command);
+ $self->_attr('user', $user);
+ my $i = 0;
+ foreach my $name (qw( minute hour day month dow )) {
+ $self->_attr($name, $self->make_valid_set($name, $entry[$i]));
+ ++$i;
+ }
+ my @day_list = $self->day->list;
+ my @dow_list = $self->dow->list;
+ my $day_range = $self->range('day');
+ my $dow_range = $self->range('dow');
+ $self->day_squelch(scalar @day_list == scalar @$day_range &&
+ scalar @dow_list != scalar @$dow_range ? 1 : 0);
+ $self->dow_squelch(scalar @dow_list == scalar @$dow_range &&
+ scalar @day_list != scalar @$day_range ? 1 : 0);
+ unless ($self->day_squelch) {
+ my @days = $self->day->list;
+ my $pass = 0;
+ MONTH: foreach my $month ($self->month->list) {
+ foreach (@days) {
+ ++$pass && last MONTH if $_ <= $Month_Max[$month - 1];
+ }
+ }
+ croak "Impossible last day for provided months.\n" unless $pass;
+ }
+ $self;
+}
+
+# Field range queries
+sub range {
+ my($self, $name) = @_;
+ my $val = $self->_range->{$name} or croak "Unknown field '$name'\n";
+ $val;
+}
+
+# Perform sanity checks when setting up each field set.
+sub make_valid_set {
+ my($self, $name, $str) = @_;
+ my $range = $self->range($name);
+ my $set = $self->make_set($str, $range);
+ my @list = $set->list;
+ croak "Malformed cron field '$str'\n" unless @list;
+ croak "Field value ($list[-1]) out of range ($range->[0]-$range->[-1])\n"
+ if $list[-1] > $range->[-1];
+ if ($name eq 'dow' && $set->contains(0)) {
+ shift(@list);
+ push(@list, 7) unless $set->contains(7);
+ $set = $self->make_set(join(',',@list), $range);
+ }
+ croak "Field value ($list[0]) out of range ($range->[0]-$range->[-1])\n"
+ if $list[0] < $range->[0];
+ $set;
+}
+
+# No sanity checks
+sub make_set { shift; DateTime::Event::Cron::OrderedSet->new(@_) }
+
+# Flags for when day/dow are applied.
+sub day_squelch { shift->_attr('day_squelch', @_ ) }
+sub dow_squelch { shift->_attr('dow_squelch', @_ ) }
+
+# Merged logic for day/dow
+sub days_contain {
+ my($self, $day, $dow) = @_;
+ defined $day && defined $dow
+ or croak "Day of month and day of week required.\n";
+ my $day_c = $self->day->contains($day);
+ my $dow_c = $self->dow->contains($dow);
+ return $dow_c if $self->day_squelch;
+ return $day_c if $self->dow_squelch;
+ $day_c || $dow_c;
+}
+
+# Set Accessors
+sub minute { shift->_attr('minute' ) }
+sub hour { shift->_attr('hour' ) }
+sub day { shift->_attr('day' ) }
+sub month { shift->_attr('month' ) }
+sub dow { shift->_attr('dow' ) }
+sub user { shift->_attr('user' ) }
+sub command { shift->_attr('command') }
+sub original { shift->_attr('original') }
+
+# Accessors/mutators
+sub _range { shift->_attr('range', @_) }
+
+sub _attr {
+ my $self = shift;
+ my $name = shift;
+ if (@_) {
+ $Object_Attributes{$self}{$name} = shift;
+ }
+ $Object_Attributes{$self}{$name};
+}
+
+sub DESTROY { delete $Object_Attributes{shift()} }
+
+}
+
+##########
+
+{
+
+package DateTime::Event::Cron::OrderedSet;
+
+# Extends Set::Crontab with some progression logic (next/prev)
+
+use strict;
+use Carp;
+use base 'Set::Crontab';
+
+my %Object_Attributes;
+
+sub new {
+ my $class = shift;
+ my($string, $range) = @_;
+ defined $string && ref $range
+ or croak "Cron field and range ref required.\n";
+ my $self = Set::Crontab->new($string, $range);
+ bless $self, $class;
+ my @list = $self->list;
+ my(%next, %prev);
+ foreach (0 .. $#list) {
+ $next{$list[$_]} = $list[($_+1)%@list];
+ $prev{$list[$_]} = $list[($_-1)%@list];
+ }
+ $self->_attr('next', \%next);
+ $self->_attr('previous', \%prev);
+ $self;
+}
+
+sub next {
+ my($self, $entry) = @_;
+ my $hash = $self->_attr('next');
+ croak "Missing entry($entry) in set\n" unless exists $hash->{$entry};
+ my $next = $hash->{$entry};
+ wantarray ? ($next, $next <= $entry) : $next;
+}
+
+sub previous {
+ my($self, $entry) = @_;
+ my $hash = $self->_attr('previous');
+ croak "Missing entry($entry) in set\n" unless exists $hash->{$entry};
+ my $prev = $hash->{$entry};
+ wantarray ? ($prev, $prev >= $entry) : $prev;
+}
+
+sub _attr {
+ my $self = shift;
+ my $name = shift;
+ if (@_) {
+ $Object_Attributes{$self}{$name} = shift;
+ }
+ $Object_Attributes{$self}{$name};
+}
+
+sub DESTROY { delete $Object_Attributes{shift()} }
+
+}
+
+###
+
+1;
+
+__END__
+
+=head1 NAME
+
+DateTime::Event::Cron - DateTime extension for generating recurrence
+sets from crontab lines and files.
+
+=head1 SYNOPSIS
+
+ use DateTime::Event::Cron;
+
+ # check if a date matches (defaults to current time)
+ my $c = DateTime::Event::Cron->new('* 2 * * *');
+ if ($c->match) {
+ # do stuff
+ }
+ if ($c->match($date)) {
+ # do something else for datetime $date
+ }
+
+ # DateTime::Set construction from crontab line
+ $crontab = '*/3 15 1-10 3,4,5 */2';
+ $set = DateTime::Event::Cron->from_cron($crontab);
+ $iter = $set->iterator(after => DateTime->now);
+ while (1) {
+ my $next = $iter->next;
+ my $now = DateTime->now;
+ sleep(($next->subtract_datetime_absolute($now))->seconds);
+ # do stuff...
+ }
+
+ # List of DateTime::Set objects from crontab file
+ @sets = DateTime::Event::Cron->from_crontab(file => '/etc/crontab');
+ $now = DateTime->now;
+ print "Now: ", $now->datetime, "\n";
+ foreach (@sets) {
+ my $next = $_->next($now);
+ print $next->datetime, "\n";
+ }
+
+ # DateTime::Set parameters
+ $crontab = '* * * * *';
+
+ $now = DateTime->now;
+ %set_parms = ( after => $now );
+ $set = DateTime::Event::Cron->from_cron(cron => $crontab, %set_parms);
+ $dt = $set->next;
+ print "Now: ", $now->datetime, " and next: ", $dt->datetime, "\n";
+
+ # Spans for DateTime::Set
+ $crontab = '* * * * *';
+ $now = DateTime->now;
+ $now2 = $now->clone;
+ $span = DateTime::Span->from_datetimes(
+ start => $now->add(minutes => 1),
+ end => $now2->add(hours => 1),
+ );
+ %parms = (cron => $crontab, span => $span);
+ $set = DateTime::Event::Cron->from_cron(%parms);
+ # ...do things with the DateTime::Set
+
+ # Every RTFCT relative to 12am Jan 1st this year
+ $crontab = '7-10 6,12-15 10-28/2 */3 3,4,5';
+ $date = DateTime->now->truncate(to => 'year');
+ $set = DateTime::Event::Cron->from_cron(cron => $crontab, after => $date);
+
+ # Rather than generating DateTime::Set objects, next/prev
+ # calculations can be made directly:
+
+ # Every day at 10am, 2pm, and 6pm. Reference date
+ # defaults to DateTime->now.
+ $crontab = '10,14,18 * * * *';
+ $dtc = DateTime::Event::Cron->new_from_cron(cron => $crontab);
+ $next_datetime = $dtc->next;
+ $last_datetime = $dtc->previous;
+ ...
+
+ # List of DateTime::Event::Cron objects from
+ # crontab file
+ @dtc = DateTime::Event::Cron->new_from_crontab(file => '/etc/crontab');
+
+ # Full cron lines with user, such as from /etc/crontab
+ # or files in /etc/cron.d, are supported and auto-detected:
+ $crontab = '* * * * * gump /bin/date';
+ $dtc = DateTime::Event::Cron->new(cron => $crontab);
+
+ # Auto-detection of users is disabled if you explicitly
+ # enable/disable via the user_mode parameter:
+ $dtc = DateTime::Event::Cron->new(cron => $crontab, user_mode => 1);
+ my $user = $dtc->user;
+ my $command = $dtc->command;
+
+ # Unparsed original cron entry
+ my $original = $dtc->original;
+
+=head1 DESCRIPTION
+
+DateTime::Event::Cron generated DateTime events or DateTime::Set objects
+based on crontab-style entries.
+
+=head1 METHODS
+
+The cron fields are typical crontab-style entries. For more information,
+see L<crontab(5)> and extensions described in L<Set::Crontab>. The
+fields can be passed as a single string or as a reference to an array
+containing each field. Only the first five fields are retained.
+
+=head2 DateTime::Set Factories
+
+See L<DateTime::Set> for methods provided by Set objects, such as
+C<next()> and C<previous()>.
+
+=over 4
+
+=item from_cron($cronline)
+
+=item from_cron(cron => $cronline, %parms, %set_parms)
+
+Generates a DateTime::Set recurrence for the cron line provided. See
+new() for details on %parms. Optionally takes parameters for
+DateTime::Set.
+
+=item from_crontab(file => $crontab_fh, %parms, %set_parms)
+
+Returns a list of DateTime::Set recurrences based on lines from a
+crontab file. C<$crontab_fh> can be either a filename or filehandle
+reference. See new() for details on %parm. Optionally takes parameters
+for DateTime::Set which will be passed along to each set for each line.
+
+=item as_set(%set_parms)
+
+Generates a DateTime::Set recurrence from an existing
+DateTime::Event::Cron object.
+
+=back
+
+=head2 Constructors
+
+=over 4
+
+=item new_from_cron(cron => $cronstring, %parms)
+
+Returns a DateTime::Event::Cron object based on the cron specification.
+Optional parameters include the boolean 'user_mode' which indicates that
+the crontab entry includes a username column before the command.
+
+=item new_from_crontab(file => $fh, %parms)
+
+Returns a list of DateTime::Event::Cron objects based on the lines of a
+crontab file. C<$fh> can be either a filename or a filehandle reference.
+Optional parameters include the boolean 'user_mode' as mentioned above.
+
+=back
+
+=head2 Other methods
+
+=over 4
+
+=item next()
+
+=item next($date)
+
+Returns the next valid datetime according to the cron specification.
+C<$date> defaults to DateTime->now unless provided.
+
+=item previous()
+
+=item previous($date)
+
+Returns the previous valid datetime according to the cron specification.
+C<$date> defaults to DateTime->now unless provided.
+
+=item increment($date)
+
+=item decrement($date)
+
+Same as C<next()> and C<previous()> except that the provided datetime is
+modified to the new datetime.
+
+=item match($date)
+
+Returns whether or not the given datetime (defaults to current time)
+matches the current cron specification. Dates are truncated to minute
+resolution.
+
+=item valid($date)
+
+A more strict version of match(). Returns whether the given datetime is
+valid under the current cron specification. Cron dates are only accurate
+to the minute -- datetimes with seconds greater than 0 are invalid by
+default. (note: never fear, all methods accepting dates will accept
+invalid dates -- they will simply be rounded to the next nearest valid
+date in all cases except this particular method)
+
+=item command()
+
+Returns the command string, if any, from the original crontab entry.
+Currently no expansion is performed such as resolving environment
+variables, etc.
+
+=item user()
+
+Returns the username under which this cron command was to be executed,
+assuming such a field was present in the original cron entry.
+
+=item original()
+
+Returns the original, unparsed cron string including any user or
+command fields.
+
+=back
+
+=head1 AUTHOR
+
+Matthew P. Sisk E<lt>sisk@mojotoad.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Matthew P. Sisk. All rights reserved. All wrongs
+revenged. This program is free software; you can distribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+DateTime(3), DateTime::Set(3), DateTime::Event::Recurrence(3),
+DateTime::Event::ICal(3), DateTime::Span(3), Set::Crontab(3), crontab(5)
+
+=cut
--- /dev/null
+
+package DateTime::Set;
+
+use strict;
+use Carp;
+use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
+use DateTime 0.12; # this is for version checking only
+use DateTime::Duration;
+use DateTime::Span;
+use Set::Infinite 0.59;
+use Set::Infinite::_recurrence;
+
+use vars qw( $VERSION );
+
+use constant INFINITY => 100 ** 100 ** 100 ;
+use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
+
+BEGIN {
+ $VERSION = '0.28';
+}
+
+
+sub _fix_datetime {
+ # internal function -
+ # (not a class method)
+ #
+ # checks that the parameter is an object, and
+ # also protects the object against mutation
+
+ return $_[0]
+ unless defined $_[0]; # error
+ return $_[0]->clone
+ if ref( $_[0] ); # "immutable" datetime
+ return DateTime::Infinite::Future->new
+ if $_[0] == INFINITY; # Inf
+ return DateTime::Infinite::Past->new
+ if $_[0] == NEG_INFINITY; # -Inf
+ return $_[0]; # error
+}
+
+sub _fix_return_datetime {
+ my ( $dt, $dt_arg ) = @_;
+
+ # internal function -
+ # (not a class method)
+ #
+ # checks that the returned datetime has the same
+ # time zone as the parameter
+
+ # TODO: set locale
+
+ return unless $dt;
+ return unless $dt_arg;
+ if ( $dt_arg->can('time_zone_long_name') &&
+ !( $dt_arg->time_zone_long_name eq 'floating' ) )
+ {
+ $dt->set_time_zone( $dt_arg->time_zone );
+ }
+ return $dt;
+}
+
+sub iterate {
+ # deprecated method - use map() or grep() instead
+ my ( $self, $callback ) = @_;
+ my $class = ref( $self );
+ my $return = $class->empty_set;
+ $return->{set} = $self->{set}->iterate(
+ sub {
+ my $min = $_[0]->min;
+ $callback->( $min->clone ) if ref($min);
+ }
+ );
+ $return;
+}
+
+sub map {
+ my ( $self, $callback ) = @_;
+ my $class = ref( $self );
+ die "The callback parameter to map() must be a subroutine reference"
+ unless ref( $callback ) eq 'CODE';
+ my $return = $class->empty_set;
+ $return->{set} = $self->{set}->iterate(
+ sub {
+ local $_ = $_[0]->min;
+ next unless ref( $_ );
+ $_ = $_->clone;
+ my @list = $callback->();
+ my $set = Set::Infinite::_recurrence->new();
+ $set = $set->union( $_ ) for @list;
+ return $set;
+ }
+ );
+ $return;
+}
+
+sub grep {
+ my ( $self, $callback ) = @_;
+ my $class = ref( $self );
+ die "The callback parameter to grep() must be a subroutine reference"
+ unless ref( $callback ) eq 'CODE';
+ my $return = $class->empty_set;
+ $return->{set} = $self->{set}->iterate(
+ sub {
+ local $_ = $_[0]->min;
+ next unless ref( $_ );
+ $_ = $_->clone;
+ my $result = $callback->();
+ return $_ if $result;
+ return;
+ }
+ );
+ $return;
+}
+
+sub add { return shift->add_duration( DateTime::Duration->new(@_) ) }
+
+sub subtract { return shift->subtract_duration( DateTime::Duration->new(@_) ) }
+
+sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }
+
+sub add_duration {
+ my ( $self, $dur ) = @_;
+ $dur = $dur->clone; # $dur must be "immutable"
+
+ $self->{set} = $self->{set}->iterate(
+ sub {
+ my $min = $_[0]->min;
+ $min->clone->add_duration( $dur ) if ref($min);
+ },
+ backtrack_callback => sub {
+ my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
+ if ( ref($min) )
+ {
+ $min = $min->clone;
+ $min->subtract_duration( $dur );
+ }
+ if ( ref($max) )
+ {
+ $max = $max->clone;
+ $max->subtract_duration( $dur );
+ }
+ return Set::Infinite::_recurrence->new( $min, $max );
+ },
+ );
+ $self;
+}
+
+sub set_time_zone {
+ my ( $self, $tz ) = @_;
+
+ $self->{set} = $self->{set}->iterate(
+ sub {
+ my $min = $_[0]->min;
+ $min->clone->set_time_zone( $tz ) if ref($min);
+ },
+ backtrack_callback => sub {
+ my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
+ if ( ref($min) )
+ {
+ $min = $min->clone;
+ $min->set_time_zone( $tz );
+ }
+ if ( ref($max) )
+ {
+ $max = $max->clone;
+ $max->set_time_zone( $tz );
+ }
+ return Set::Infinite::_recurrence->new( $min, $max );
+ },
+ );
+ $self;
+}
+
+sub set {
+ my $self = shift;
+ my %args = validate( @_,
+ { locale => { type => SCALAR | OBJECT,
+ default => undef },
+ }
+ );
+ $self->{set} = $self->{set}->iterate(
+ sub {
+ my $min = $_[0]->min;
+ $min->clone->set( %args ) if ref($min);
+ },
+ );
+ $self;
+}
+
+sub from_recurrence {
+ my $class = shift;
+
+ my %args = @_;
+ my %param;
+
+ # Parameter renaming, such that we can use either
+ # recurrence => xxx or next => xxx, previous => xxx
+ $param{next} = delete $args{recurrence} || delete $args{next};
+ $param{previous} = delete $args{previous};
+
+ $param{span} = delete $args{span};
+ # they might be specifying a span using begin / end
+ $param{span} = DateTime::Span->new( %args ) if keys %args;
+
+ my $self = {};
+
+ die "Not enough arguments in from_recurrence()"
+ unless $param{next} || $param{previous};
+
+ if ( ! $param{previous} )
+ {
+ my $data = {};
+ $param{previous} =
+ sub {
+ _callback_previous ( _fix_datetime( $_[0] ), $param{next}, $data );
+ }
+ }
+ else
+ {
+ my $previous = $param{previous};
+ $param{previous} =
+ sub {
+ $previous->( _fix_datetime( $_[0] ) );
+ }
+ }
+
+ if ( ! $param{next} )
+ {
+ my $data = {};
+ $param{next} =
+ sub {
+ _callback_next ( _fix_datetime( $_[0] ), $param{previous}, $data );
+ }
+ }
+ else
+ {
+ my $next = $param{next};
+ $param{next} =
+ sub {
+ $next->( _fix_datetime( $_[0] ) );
+ }
+ }
+
+ my ( $min, $max );
+ $max = $param{previous}->( DateTime::Infinite::Future->new );
+ $min = $param{next}->( DateTime::Infinite::Past->new );
+ $max = INFINITY if $max->is_infinite;
+ $min = NEG_INFINITY if $min->is_infinite;
+
+ my $base_set = Set::Infinite::_recurrence->new( $min, $max );
+ $base_set = $base_set->intersection( $param{span}->{set} )
+ if $param{span};
+
+ # warn "base set is $base_set\n";
+
+ my $data = {};
+ $self->{set} =
+ $base_set->_recurrence(
+ $param{next},
+ $param{previous},
+ $data,
+ );
+ bless $self, $class;
+
+ return $self;
+}
+
+sub from_datetimes {
+ my $class = shift;
+ my %args = validate( @_,
+ { dates =>
+ { type => ARRAYREF,
+ },
+ }
+ );
+ my $self = {};
+ $self->{set} = Set::Infinite::_recurrence->new;
+ # possible optimization: sort datetimes and use "push"
+ for( @{ $args{dates} } )
+ {
+ # DateTime::Infinite objects are not welcome here,
+ # but this is not enforced (it does't hurt)
+
+ carp "The 'dates' argument to from_datetimes() must only contain ".
+ "datetime objects"
+ unless UNIVERSAL::can( $_, 'utc_rd_values' );
+
+ $self->{set} = $self->{set}->union( $_->clone );
+ }
+
+ bless $self, $class;
+ return $self;
+}
+
+sub empty_set {
+ my $class = shift;
+
+ return bless { set => Set::Infinite::_recurrence->new }, $class;
+}
+
+sub clone {
+ my $self = bless { %{ $_[0] } }, ref $_[0];
+ $self->{set} = $_[0]->{set}->copy;
+ return $self;
+}
+
+# default callback that returns the
+# "previous" value in a callback recurrence.
+#
+# This is used to simulate a 'previous' callback,
+# when then 'previous' argument in 'from_recurrence' is missing.
+#
+sub _callback_previous {
+ my ($value, $callback_next, $callback_info) = @_;
+ my $previous = $value->clone;
+
+ return $value if $value->is_infinite;
+
+ my $freq = $callback_info->{freq};
+ unless (defined $freq)
+ {
+ # This is called just once, to setup the recurrence frequency
+ my $previous = $callback_next->( $value );
+ my $next = $callback_next->( $previous );
+ $freq = 2 * ( $previous - $next );
+ # save it for future use with this same recurrence
+ $callback_info->{freq} = $freq;
+ }
+
+ $previous->add_duration( $freq );
+ $previous = $callback_next->( $previous );
+ if ($previous >= $value)
+ {
+ # This error happens if the event frequency oscilates widely
+ # (more than 100% of difference from one interval to next)
+ my @freq = $freq->deltas;
+ print STDERR "_callback_previous: Delta components are: @freq\n";
+ warn "_callback_previous: iterator can't find a previous value, got ".
+ $previous->ymd." after ".$value->ymd;
+ }
+ my $previous1;
+ while (1)
+ {
+ $previous1 = $previous->clone;
+ $previous = $callback_next->( $previous );
+ return $previous1 if $previous >= $value;
+ }
+}
+
+# default callback that returns the
+# "next" value in a callback recurrence.
+#
+# This is used to simulate a 'next' callback,
+# when then 'next' argument in 'from_recurrence' is missing.
+#
+sub _callback_next {
+ my ($value, $callback_previous, $callback_info) = @_;
+ my $next = $value->clone;
+
+ return $value if $value->is_infinite;
+
+ my $freq = $callback_info->{freq};
+ unless (defined $freq)
+ {
+ # This is called just once, to setup the recurrence frequency
+ my $next = $callback_previous->( $value );
+ my $previous = $callback_previous->( $next );
+ $freq = 2 * ( $next - $previous );
+ # save it for future use with this same recurrence
+ $callback_info->{freq} = $freq;
+ }
+
+ $next->add_duration( $freq );
+ $next = $callback_previous->( $next );
+ if ($next <= $value)
+ {
+ # This error happens if the event frequency oscilates widely
+ # (more than 100% of difference from one interval to next)
+ my @freq = $freq->deltas;
+ print STDERR "_callback_next: Delta components are: @freq\n";
+ warn "_callback_next: iterator can't find a previous value, got ".
+ $next->ymd." before ".$value->ymd;
+ }
+ my $next1;
+ while (1)
+ {
+ $next1 = $next->clone;
+ $next = $callback_previous->( $next );
+ return $next1 if $next >= $value;
+ }
+}
+
+sub iterator {
+ my $self = shift;
+
+ my %args = @_;
+ my $span;
+ $span = delete $args{span};
+ $span = DateTime::Span->new( %args ) if %args;
+
+ return $self->intersection( $span ) if $span;
+ return $self->clone;
+}
+
+
+# next() gets the next element from an iterator()
+# next( $dt ) returns the next element after a datetime.
+sub next {
+ my $self = shift;
+ return undef unless ref( $self->{set} );
+
+ if ( @_ )
+ {
+ if ( $self->{set}->_is_recurrence )
+ {
+ return _fix_return_datetime(
+ $self->{set}->{param}[0]->( $_[0] ), $_[0] );
+ }
+ else
+ {
+ my $span = DateTime::Span->from_datetimes( after => $_[0] );
+ return _fix_return_datetime(
+ $self->intersection( $span )->next, $_[0] );
+ }
+ }
+
+ my ($head, $tail) = $self->{set}->first;
+ $self->{set} = $tail;
+ return $head->min if defined $head;
+ return $head;
+}
+
+# previous() gets the last element from an iterator()
+# previous( $dt ) returns the previous element before a datetime.
+sub previous {
+ my $self = shift;
+ return undef unless ref( $self->{set} );
+
+ if ( @_ )
+ {
+ if ( $self->{set}->_is_recurrence )
+ {
+ return _fix_return_datetime(
+ $self->{set}->{param}[1]->( $_[0] ), $_[0] );
+ }
+ else
+ {
+ my $span = DateTime::Span->from_datetimes( before => $_[0] );
+ return _fix_return_datetime(
+ $self->intersection( $span )->previous, $_[0] );
+ }
+ }
+
+ my ($head, $tail) = $self->{set}->last;
+ $self->{set} = $tail;
+ return $head->max if defined $head;
+ return $head;
+}
+
+# "current" means less-or-equal to a datetime
+sub current {
+ my $self = shift;
+
+ return undef unless ref( $self->{set} );
+
+ if ( $self->{set}->_is_recurrence )
+ {
+ my $tmp = $self->next( $_[0] );
+ return $self->previous( $tmp );
+ }
+
+ return $_[0] if $self->contains( $_[0] );
+ $self->previous( $_[0] );
+}
+
+sub closest {
+ my $self = shift;
+ # return $_[0] if $self->contains( $_[0] );
+ my $dt1 = $self->current( $_[0] );
+ my $dt2 = $self->next( $_[0] );
+
+ return $dt2 unless defined $dt1;
+ return $dt1 unless defined $dt2;
+
+ my $delta = $_[0] - $dt1;
+ return $dt1 if ( $dt2 - $delta ) >= $_[0];
+
+ return $dt2;
+}
+
+sub as_list {
+ my $self = shift;
+ return undef unless ref( $self->{set} );
+
+ my %args = @_;
+ my $span;
+ $span = delete $args{span};
+ $span = DateTime::Span->new( %args ) if %args;
+
+ my $set = $self->clone;
+ $set = $set->intersection( $span ) if $span;
+
+ return if $set->{set}->is_null; # nothing = empty
+
+ # Note: removing this line means we may end up in an infinite loop!
+ ## return undef if $set->{set}->is_too_complex; # undef = no begin/end
+
+ return undef
+ if $set->max->is_infinite ||
+ $set->min->is_infinite;
+
+ my @result;
+ my $next = $self->min;
+ if ( $span ) {
+ my $next1 = $span->min;
+ $next = $next1 if $next1 && $next1 > $next;
+ $next = $self->current( $next );
+ }
+ my $last = $self->max;
+ if ( $span ) {
+ my $last1 = $span->max;
+ $last = $last1 if $last1 && $last1 < $last;
+ }
+ do {
+ push @result, $next if !$span || $span->contains($next);
+ $next = $self->next( $next );
+ }
+ while $next && $next <= $last;
+ return @result;
+}
+
+sub intersection {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
+ return $tmp;
+}
+
+sub intersects {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ unless ( $set2->can( 'union' ) )
+ {
+ if ( $set1->{set}->_is_recurrence )
+ {
+ for ( $set2, @_ )
+ {
+ return 1 if $set1->current( $_ ) == $_;
+ }
+ return 0;
+ }
+ $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
+ }
+ return $set1->{set}->intersects( $set2->{set} );
+}
+
+sub contains {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ unless ( $set2->can( 'union' ) )
+ {
+ if ( $set1->{set}->_is_recurrence )
+ {
+ for ( $set2, @_ )
+ {
+ return 0 unless $set1->current( $_ ) == $_;
+ }
+ return 1;
+ }
+ $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
+ }
+ return $set1->{set}->contains( $set2->{set} );
+}
+
+sub union {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->union( $set2->{set} );
+ bless $tmp, 'DateTime::SpanSet'
+ if $set2->isa('DateTime::Span') or $set2->isa('DateTime::SpanSet');
+ return $tmp;
+}
+
+sub complement {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ if (defined $set2)
+ {
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ # TODO: "compose complement";
+ $tmp->{set} = $set1->{set}->complement( $set2->{set} );
+ }
+ else
+ {
+ $tmp->{set} = $set1->{set}->complement;
+ bless $tmp, 'DateTime::SpanSet';
+ }
+ return $tmp;
+}
+
+sub min {
+ return _fix_datetime( $_[0]->{set}->min );
+}
+
+sub max {
+ return _fix_datetime( $_[0]->{set}->max );
+}
+
+# returns a DateTime::Span
+sub span {
+ my $set = $_[0]->{set}->span;
+ my $self = bless { set => $set }, 'DateTime::Span';
+ return $self;
+}
+
+sub count {
+ my ($self) = shift;
+ return undef unless ref( $self->{set} );
+
+ my %args = @_;
+ my $span;
+ $span = delete $args{span};
+ $span = DateTime::Span->new( %args ) if %args;
+
+ my $set = $self->clone;
+ $set = $set->intersection( $span ) if $span;
+
+ return $set->{set}->count
+ unless $set->{set}->is_too_complex;
+
+ return undef
+ if $set->max->is_infinite ||
+ $set->min->is_infinite;
+
+ my $count = 0;
+ my $iter = $set->iterator;
+ $count++ while $iter->next;
+ return $count;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DateTime::Set - Datetime sets and set math
+
+=head1 SYNOPSIS
+
+ use DateTime;
+ use DateTime::Set;
+
+ $date1 = DateTime->new( year => 2002, month => 3, day => 11 );
+ $set1 = DateTime::Set->from_datetimes( dates => [ $date1 ] );
+ # set1 = 2002-03-11
+
+ $date2 = DateTime->new( year => 2003, month => 4, day => 12 );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $date1, $date2 ] );
+ # set2 = 2002-03-11, and 2003-04-12
+
+ $date3 = DateTime->new( year => 2003, month => 4, day => 1 );
+ print $set2->next( $date3 )->ymd; # 2003-04-12
+ print $set2->previous( $date3 )->ymd; # 2002-03-11
+ print $set2->current( $date3 )->ymd; # 2002-03-11
+ print $set2->closest( $date3 )->ymd; # 2003-04-12
+
+ # a 'monthly' recurrence:
+ $set = DateTime::Set->from_recurrence(
+ recurrence => sub {
+ return $_[0] if $_[0]->is_infinite;
+ return $_[0]->truncate( to => 'month' )->add( months => 1 )
+ },
+ span => $date_span1, # optional span
+ );
+
+ $set = $set1->union( $set2 ); # like "OR", "insert", "both"
+ $set = $set1->complement( $set2 ); # like "delete", "remove"
+ $set = $set1->intersection( $set2 ); # like "AND", "while"
+ $set = $set1->complement; # like "NOT", "negate", "invert"
+
+ if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $set1->contains( $set2 ) ) { ... # like "is-fully-inside"
+
+ # data extraction
+ $date = $set1->min; # first date of the set
+ $date = $set1->max; # last date of the set
+
+ $iter = $set1->iterator;
+ while ( $dt = $iter->next ) {
+ print $dt->ymd;
+ };
+
+=head1 DESCRIPTION
+
+DateTime::Set is a module for datetime sets. It can be used to handle
+two different types of sets.
+
+The first is a fixed set of predefined datetime objects. For example,
+if we wanted to create a set of datetimes containing the birthdays of
+people in our family for the current year.
+
+The second type of set that it can handle is one based on a
+recurrence, such as "every Wednesday", or "noon on the 15th day of
+every month". This type of set can have fixed starting and ending
+datetimes, but neither is required. So our "every Wednesday set"
+could be "every Wednesday from the beginning of time until the end of
+time", or "every Wednesday after 2003-03-05 until the end of time", or
+"every Wednesday between 2003-03-05 and 2004-01-07".
+
+This module also supports set math operations, so you do things like
+create a new set from the union or difference of two sets, check
+whether a datetime is a member of a given set, etc.
+
+This is different from a C<DateTime::Span>, which handles a continuous
+range as opposed to individual datetime points. There is also a module
+C<DateTime::SpanSet> to handle sets of spans.
+
+=head1 METHODS
+
+=over 4
+
+=item * from_datetimes
+
+Creates a new set from a list of datetimes.
+
+ $dates = DateTime::Set->from_datetimes( dates => [ $dt1, $dt2, $dt3 ] );
+
+The datetimes can be objects from class C<DateTime>, or from a
+C<DateTime::Calendar::*> class.
+
+C<DateTime::Infinite::*> objects are not valid set members.
+
+=item * from_recurrence
+
+Creates a new set specified via a "recurrence" callback.
+
+ $months = DateTime::Set->from_recurrence(
+ span => $dt_span_this_year, # optional span
+ recurrence => sub {
+ return $_[0]->truncate( to => 'month' )->add( months => 1 )
+ },
+ );
+
+The C<span> parameter is optional. It must be a C<DateTime::Span> object.
+
+The span can also be specified using C<begin> / C<after> and C<before>
+/ C<end> parameters, as in the C<DateTime::Span> constructor. In this
+case, if there is a C<span> parameter it will be ignored.
+
+ $months = DateTime::Set->from_recurrence(
+ after => $dt_now,
+ recurrence => sub {
+ return $_[0]->truncate( to => 'month' )->add( months => 1 );
+ },
+ );
+
+The recurrence function will be passed a single parameter, a datetime
+object. The parameter can be an object from class C<DateTime>, or from
+one of the C<DateTime::Calendar::*> classes. The parameter can also
+be a C<DateTime::Infinite::Future> or a C<DateTime::Infinite::Past>
+object.
+
+The recurrence must return the I<next> event after that object. There
+is no guarantee as to what the returned object will be set to, only
+that it will be greater than the object passed to the recurrence.
+
+If there are no more datetimes after the given parameter, then the
+recurrence function should return C<DateTime::Infinite::Future>.
+
+It is ok to modify the parameter C<$_[0]> inside the recurrence
+function. There are no side-effects.
+
+For example, if you wanted a recurrence that generated datetimes in
+increments of 30 seconds, it would look like this:
+
+ sub every_30_seconds {
+ my $dt = shift;
+ if ( $dt->second < 30 ) {
+ return $dt->truncate( to => 'minute' )->add( seconds => 30 );
+ } else {
+ return $dt->truncate( to => 'minute' )->add( minutes => 1 );
+ }
+ }
+
+Note that this recurrence takes leap seconds into account. Consider
+using C<truncate()> in this manner to avoid complicated arithmetic
+problems!
+
+It is also possible to create a recurrence by specifying either or both
+of 'next' and 'previous' callbacks.
+
+The callbacks can return C<DateTime::Infinite::Future> and
+C<DateTime::Infinite::Past> objects, in order to define I<bounded
+recurrences>. In this case, both 'next' and 'previous' callbacks must
+be defined:
+
+ # "monthly from $dt until forever"
+
+ my $months = DateTime::Set->from_recurrence(
+ next => sub {
+ return $dt if $_[0] < $dt;
+ $_[0]->truncate( to => 'month' );
+ $_[0]->add( months => 1 );
+ return $_[0];
+ },
+ previous => sub {
+ my $param = $_[0]->clone;
+ $_[0]->truncate( to => 'month' );
+ $_[0]->subtract( months => 1 ) if $_[0] == $param;
+ return $_[0] if $_[0] >= $dt;
+ return DateTime::Infinite::Past->new;
+ },
+ );
+
+Bounded recurrences are easier to write using C<span> parameters. See above.
+
+See also C<DateTime::Event::Recurrence> and the other
+C<DateTime::Event::*> factory modules for generating specialized
+recurrences, such as sunrise and sunset times, and holidays.
+
+=item * empty_set
+
+Creates a new empty set.
+
+ $set = DateTime::Set->empty_set;
+ print "empty set" unless defined $set->max;
+
+=item * clone
+
+This object method returns a replica of the given object.
+
+C<clone> is useful if you want to apply a transformation to a set,
+but you want to keep the previous value:
+
+ $set2 = $set1->clone;
+ $set2->add_duration( year => 1 ); # $set1 is unaltered
+
+=item * add_duration( $duration )
+
+This method adds the specified duration to every element of the set.
+
+ $dt_dur = new DateTime::Duration( year => 1 );
+ $set->add_duration( $dt_dur );
+
+The original set is modified. If you want to keep the old values use:
+
+ $new_set = $set->clone->add_duration( $dt_dur );
+
+=item * add
+
+This method is syntactic sugar around the C<add_duration()> method.
+
+ $meetings_2004 = $meetings_2003->clone->add( years => 1 );
+
+=item * subtract_duration( $duration_object )
+
+When given a C<DateTime::Duration> object, this method simply calls
+C<invert()> on that object and passes that new duration to the
+C<add_duration> method.
+
+=item * subtract( DateTime::Duration->new parameters )
+
+Like C<add()>, this is syntactic sugar for the C<subtract_duration()>
+method.
+
+=item * set_time_zone( $tz )
+
+This method will attempt to apply the C<set_time_zone> method to every
+datetime in the set.
+
+=item * set( locale => .. )
+
+This method can be used to change the C<locale> of a datetime set.
+
+=item * min
+
+=item * max
+
+The first and last C<DateTime> in the set. These methods may return
+C<undef> if the set is empty. It is also possible that these methods
+may return a C<DateTime::Infinite::Past> or
+C<DateTime::Infinite::Future> object.
+
+These methods return just a I<copy> of the actual boundary value.
+If you modify the result, the set will not be modified.
+
+=item * span
+
+Returns the total span of the set, as a C<DateTime::Span> object.
+
+=item * iterator / next / previous
+
+These methods can be used to iterate over the datetimes in a set.
+
+ $iter = $set1->iterator;
+ while ( $dt = $iter->next ) {
+ print $dt->ymd;
+ }
+
+ # iterate backwards
+ $iter = $set1->iterator;
+ while ( $dt = $iter->previous ) {
+ print $dt->ymd;
+ }
+
+The boundaries of the iterator can be limited by passing it a C<span>
+parameter. This should be a C<DateTime::Span> object which delimits
+the iterator's boundaries. Optionally, instead of passing an object,
+you can pass any parameters that would work for one of the
+C<DateTime::Span> class's constructors, and an object will be created
+for you.
+
+Obviously, if the span you specify is not restricted both at the start
+and end, then your iterator may iterate forever, depending on the
+nature of your set. User beware!
+
+The C<next()> or C<previous()> method will return C<undef> when there
+are no more datetimes in the iterator.
+
+=item * as_list
+
+Returns the set elements as a list of C<DateTime> objects. Just as
+with the C<iterator()> method, the C<as_list()> method can be limited
+by a span.
+
+ my @dt = $set->as_list( span => $span );
+
+Applying C<as_list()> to a large recurrence set is a very expensive
+operation, both in CPU time and in the memory used. If you I<really>
+need to extract elements from a large set, you can limit the set with
+a shorter span:
+
+ my @short_list = $large_set->as_list( span => $short_span );
+
+For I<infinite> sets, C<as_list()> will return C<undef>. Please note
+that this is explicitly not an empty list, since an empty list is a
+valid return value for empty sets!
+
+=item * count
+
+Returns a count of C<DateTime> objects in the set. Just as with the
+C<iterator()> method, the C<count()> method can be limited by a span.
+
+ defined( my $n = $set->count) or die "can't count";
+
+ my $n = $set->count( span => $span );
+ die "can't count" unless defined $n;
+
+Applying C<count()> to a large recurrence set is a very expensive
+operation, both in CPU time and in the memory used. If you I<really>
+need to count elements from a large set, you can limit the set with a
+shorter span:
+
+ my $count = $large_set->count( span => $short_span );
+
+For I<infinite> sets, C<count()> will return C<undef>. Please note
+that this is explicitly not a scalar zero, since a zero count is a
+valid return value for empty sets!
+
+=item * union
+
+=item * intersection
+
+=item * complement
+
+These set operation methods can accept a C<DateTime> list, a
+C<DateTime::Set>, a C<DateTime::Span>, or a C<DateTime::SpanSet>
+object as an argument.
+
+ $set = $set1->union( $set2 ); # like "OR", "insert", "both"
+ $set = $set1->complement( $set2 ); # like "delete", "remove"
+ $set = $set1->intersection( $set2 ); # like "AND", "while"
+ $set = $set1->complement; # like "NOT", "negate", "invert"
+
+The C<union> of a C<DateTime::Set> with a C<DateTime::Span> or a
+C<DateTime::SpanSet> object returns a C<DateTime::SpanSet> object.
+
+If C<complement> is called without any arguments, then the result is a
+C<DateTime::SpanSet> object representing the spans between each of the
+set's elements. If complement is given an argument, then the return
+value is a C<DateTime::Set> object representing the I<set difference>
+between the sets.
+
+All other operations will always return a C<DateTime::Set>.
+
+=item * intersects
+
+=item * contains
+
+These set operations result in a boolean value.
+
+ if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $set1->contains( $dt ) ) { ... # like "is-fully-inside"
+
+These methods can accept a C<DateTime> list, a C<DateTime::Set>, a
+C<DateTime::Span>, or a C<DateTime::SpanSet> object as an argument.
+
+=item * previous
+
+=item * next
+
+=item * current
+
+=item * closest
+
+ my $dt = $set->next( $dt );
+ my $dt = $set->previous( $dt );
+ my $dt = $set->current( $dt );
+ my $dt = $set->closest( $dt );
+
+These methods are used to find a set member relative to a given
+datetime.
+
+The C<current()> method returns C<$dt> if $dt is an event, otherwise
+it returns the previous event.
+
+The C<closest()> method returns C<$dt> if $dt is an event, otherwise
+it returns the closest event (previous or next).
+
+All of these methods may return C<undef> if there is no matching
+datetime in the set.
+
+These methods will try to set the returned value to the same time zone
+as the argument, unless the argument has a 'floating' time zone.
+
+=item * map ( sub { ... } )
+
+ # example: remove the hour:minute:second information
+ $set = $set2->map(
+ sub {
+ return $_->truncate( to => day );
+ }
+ );
+
+ # example: postpone or antecipate events which
+ # match datetimes within another set
+ $set = $set2->map(
+ sub {
+ return $_->add( days => 1 ) while $holidays->contains( $_ );
+ }
+ );
+
+This method is the "set" version of Perl "map".
+
+It evaluates a subroutine for each element of the set (locally setting
+"$_" to each datetime) and returns the set composed of the results of
+each such evaluation.
+
+Like Perl "map", each element of the set may produce zero, one, or
+more elements in the returned value.
+
+Unlike Perl "map", changing "$_" does not change the original
+set. This means that calling map in void context has no effect.
+
+The callback subroutine may be called later in the program, due to
+lazy evaluation. So don't count on subroutine side-effects. For
+example, a C<print> inside the subroutine may happen later than you
+expect.
+
+The callback return value is expected to be within the span of the
+C<previous> and the C<next> element in the original set. This is a
+limitation of the backtracking algorithm used in the C<Set::Infinite>
+library.
+
+For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
+result for the value C<2010> is expected to be within the span C<[
+2001 .. 2015 ]>.
+
+=item * grep ( sub { ... } )
+
+ # example: filter out any sundays
+ $set = $set2->grep(
+ sub {
+ return ( $_->day_of_week != 7 );
+ }
+ );
+
+This method is the "set" version of Perl "grep".
+
+It evaluates a subroutine for each element of the set (locally setting
+"$_" to each datetime) and returns the set consisting of those
+elements for which the expression evaluated to true.
+
+Unlike Perl "grep", changing "$_" does not change the original
+set. This means that calling grep in void context has no effect.
+
+Changing "$_" does change the resulting set.
+
+The callback subroutine may be called later in the program, due to
+lazy evaluation. So don't count on subroutine side-effects. For
+example, a C<print> inside the subroutine may happen later than you
+expect.
+
+=item * iterate ( sub { ... } )
+
+I<deprecated method - please use "map" or "grep" instead.>
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+The API was developed together with Dave Rolsky and the DateTime
+Community.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003-2006 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can distribute it and/or modify it
+under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file included
+with this module.
+
+=head1 SEE ALSO
+
+Set::Infinite
+
+For details on the Perl DateTime Suite project please see
+L<http://datetime.perl.org>.
+
+=cut
+
--- /dev/null
+# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package DateTime::Span;
+
+use strict;
+
+use DateTime::Set;
+use DateTime::SpanSet;
+
+use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
+use vars qw( $VERSION );
+
+use constant INFINITY => DateTime::INFINITY;
+use constant NEG_INFINITY => DateTime::NEG_INFINITY;
+$VERSION = $DateTime::Set::VERSION;
+
+sub set_time_zone {
+ my ( $self, $tz ) = @_;
+
+ $self->{set} = $self->{set}->iterate(
+ sub {
+ my %tmp = %{ $_[0]->{list}[0] };
+ $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
+ $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
+ \%tmp;
+ }
+ );
+ return $self;
+}
+
+# note: the constructor must clone its DateTime parameters, such that
+# the set elements become immutable
+sub from_datetimes {
+ my $class = shift;
+ my %args = validate( @_,
+ { start =>
+ { type => OBJECT,
+ optional => 1,
+ },
+ end =>
+ { type => OBJECT,
+ optional => 1,
+ },
+ after =>
+ { type => OBJECT,
+ optional => 1,
+ },
+ before =>
+ { type => OBJECT,
+ optional => 1,
+ },
+ }
+ );
+ my $self = {};
+ my $set;
+
+ die "No arguments given to DateTime::Span->from_datetimes\n"
+ unless keys %args;
+
+ if ( exists $args{start} && exists $args{after} ) {
+ die "Cannot give both start and after arguments to DateTime::Span->from_datetimes\n";
+ }
+ if ( exists $args{end} && exists $args{before} ) {
+ die "Cannot give both end and before arguments to DateTime::Span->from_datetimes\n";
+ }
+
+ my ( $start, $open_start, $end, $open_end );
+ ( $start, $open_start ) = ( NEG_INFINITY, 0 );
+ ( $start, $open_start ) = ( $args{start}, 0 ) if exists $args{start};
+ ( $start, $open_start ) = ( $args{after}, 1 ) if exists $args{after};
+ ( $end, $open_end ) = ( INFINITY, 0 );
+ ( $end, $open_end ) = ( $args{end}, 0 ) if exists $args{end};
+ ( $end, $open_end ) = ( $args{before}, 1 ) if exists $args{before};
+
+ if ( $start > $end ) {
+ die "Span cannot start after the end in DateTime::Span->from_datetimes\n";
+ }
+ $set = Set::Infinite::_recurrence->new( $start, $end );
+ if ( $start != $end ) {
+ # remove start, such that we have ">" instead of ">="
+ $set = $set->complement( $start ) if $open_start;
+ # remove end, such that we have "<" instead of "<="
+ $set = $set->complement( $end ) if $open_end;
+ }
+
+ $self->{set} = $set;
+ bless $self, $class;
+ return $self;
+}
+
+sub from_datetime_and_duration {
+ my $class = shift;
+ my %args = @_;
+
+ my $key;
+ my $dt;
+ # extract datetime parameters
+ for ( qw( start end before after ) ) {
+ if ( exists $args{$_} ) {
+ $key = $_;
+ $dt = delete $args{$_};
+ }
+ }
+
+ # extract duration parameters
+ my $dt_duration;
+ if ( exists $args{duration} ) {
+ $dt_duration = $args{duration};
+ }
+ else {
+ $dt_duration = DateTime::Duration->new( %args );
+ }
+ # warn "Creating span from $key => ".$dt->datetime." and $dt_duration";
+ my $other_date = $dt->clone->add_duration( $dt_duration );
+ # warn "Creating span from $key => ".$dt->datetime." and ".$other_date->datetime;
+ my $other_key;
+ if ( $dt_duration->is_positive ) {
+ # check if have to invert keys
+ $key = 'after' if $key eq 'end';
+ $key = 'start' if $key eq 'before';
+ $other_key = 'before';
+ }
+ else {
+ # check if have to invert keys
+ $other_key = 'end' if $key eq 'after';
+ $other_key = 'before' if $key eq 'start';
+ $key = 'start';
+ }
+ return $class->new( $key => $dt, $other_key => $other_date );
+}
+
+# This method is intentionally not documented. It's really only for
+# use by ::Set and ::SpanSet's as_list() and iterator() methods.
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ # If we find anything _not_ appropriate for from_datetimes, we
+ # assume it must be for durations, and call this constructor.
+ # This way, we don't need to hardcode the DateTime::Duration
+ # parameters.
+ foreach ( keys %args )
+ {
+ return $class->from_datetime_and_duration(%args)
+ unless /^(?:before|after|start|end)$/;
+ }
+
+ return $class->from_datetimes(%args);
+}
+
+sub clone {
+ bless {
+ set => $_[0]->{set}->copy,
+ }, ref $_[0];
+}
+
+# Set::Infinite methods
+
+sub intersection {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ my $tmp = {}; # $class->new();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
+
+ # intersection() can generate something more complex than a span.
+ bless $tmp, 'DateTime::SpanSet';
+
+ return $tmp;
+}
+
+sub intersects {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ return $set1->{set}->intersects( $set2->{set} );
+}
+
+sub contains {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ return $set1->{set}->contains( $set2->{set} );
+}
+
+sub union {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ my $tmp = {}; # $class->new();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->union( $set2->{set} );
+
+ # union() can generate something more complex than a span.
+ bless $tmp, 'DateTime::SpanSet';
+
+ # # We have to check it's internal structure to find out.
+ # if ( $#{ $tmp->{set}->{list} } != 0 ) {
+ # bless $tmp, 'Date::SpanSet';
+ # }
+
+ return $tmp;
+}
+
+sub complement {
+ my ($set1, $set2) = @_;
+ my $class = ref($set1);
+ my $tmp = {}; # $class->new;
+ if (defined $set2) {
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->complement( $set2->{set} );
+ }
+ else {
+ $tmp->{set} = $set1->{set}->complement;
+ }
+
+ # complement() can generate something more complex than a span.
+ bless $tmp, 'DateTime::SpanSet';
+
+ # # We have to check it's internal structure to find out.
+ # if ( $#{ $tmp->{set}->{list} } != 0 ) {
+ # bless $tmp, 'Date::SpanSet';
+ # }
+
+ return $tmp;
+}
+
+sub start {
+ return DateTime::Set::_fix_datetime( $_[0]->{set}->min );
+}
+
+*min = \&start;
+
+sub end {
+ return DateTime::Set::_fix_datetime( $_[0]->{set}->max );
+}
+
+*max = \&end;
+
+sub start_is_open {
+ # min_a returns info about the set boundary
+ my ($min, $open) = $_[0]->{set}->min_a;
+ return $open;
+}
+
+sub start_is_closed { $_[0]->start_is_open ? 0 : 1 }
+
+sub end_is_open {
+ # max_a returns info about the set boundary
+ my ($max, $open) = $_[0]->{set}->max_a;
+ return $open;
+}
+
+sub end_is_closed { $_[0]->end_is_open ? 0 : 1 }
+
+
+# span == $self
+sub span { @_ }
+
+sub duration {
+ my $dur;
+
+ local $@;
+ eval {
+ local $SIG{__DIE__}; # don't want to trap this (rt ticket 5434)
+ $dur = $_[0]->end->subtract_datetime_absolute( $_[0]->start )
+ };
+
+ return $dur if defined $dur;
+
+ return DateTime::Infinite::Future->new -
+ DateTime::Infinite::Past->new;
+}
+*size = \&duration;
+
+1;
+
+__END__
+
+=head1 NAME
+
+DateTime::Span - Datetime spans
+
+=head1 SYNOPSIS
+
+ use DateTime;
+ use DateTime::Span;
+
+ $date1 = DateTime->new( year => 2002, month => 3, day => 11 );
+ $date2 = DateTime->new( year => 2003, month => 4, day => 12 );
+ $set2 = DateTime::Span->from_datetimes( start => $date1, end => $date2 );
+ # set2 = 2002-03-11 until 2003-04-12
+
+ $set = $set1->union( $set2 ); # like "OR", "insert", "both"
+ $set = $set1->complement( $set2 ); # like "delete", "remove"
+ $set = $set1->intersection( $set2 ); # like "AND", "while"
+ $set = $set1->complement; # like "NOT", "negate", "invert"
+
+ if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $set1->contains( $set2 ) ) { ... # like "is-fully-inside"
+
+ # data extraction
+ $date = $set1->start; # first date of the span
+ $date = $set1->end; # last date of the span
+
+=head1 DESCRIPTION
+
+C<DateTime::Span> is a module for handling datetime spans, otherwise
+known as ranges or periods ("from X to Y, inclusive of all datetimes
+in between").
+
+This is different from a C<DateTime::Set>, which is made of individual
+datetime points as opposed to a range. There is also a module
+C<DateTime::SpanSet> to handle sets of spans.
+
+=head1 METHODS
+
+=over 4
+
+=item * from_datetimes
+
+Creates a new span based on a starting and ending datetime.
+
+A 'closed' span includes its end-dates:
+
+ $span = DateTime::Span->from_datetimes( start => $dt1, end => $dt2 );
+
+An 'open' span does not include its end-dates:
+
+ $span = DateTime::Span->from_datetimes( after => $dt1, before => $dt2 );
+
+A 'semi-open' span includes one of its end-dates:
+
+ $span = DateTime::Span->from_datetimes( start => $dt1, before => $dt2 );
+ $span = DateTime::Span->from_datetimes( after => $dt1, end => $dt2 );
+
+A span might have just a beginning date, or just an ending date.
+These spans end, or start, in an imaginary 'forever' date:
+
+ $span = DateTime::Span->from_datetimes( start => $dt1 );
+ $span = DateTime::Span->from_datetimes( end => $dt2 );
+ $span = DateTime::Span->from_datetimes( after => $dt1 );
+ $span = DateTime::Span->from_datetimes( before => $dt2 );
+
+You cannot give both a "start" and "after" argument, nor can you give
+both an "end" and "before" argument. Either of these conditions will
+cause the C<from_datetimes()> method to die.
+
+To summarize, a datetime passed as either "start" or "end" is included
+in the span. A datetime passed as either "after" or "before" is
+excluded from the span.
+
+=item * from_datetime_and_duration
+
+Creates a new span.
+
+ $span = DateTime::Span->from_datetime_and_duration(
+ start => $dt1, duration => $dt_dur1 );
+ $span = DateTime::Span->from_datetime_and_duration(
+ after => $dt1, hours => 12 );
+
+The new "end of the set" is I<open> by default.
+
+=item * clone
+
+This object method returns a replica of the given object.
+
+=item * set_time_zone( $tz )
+
+This method accepts either a time zone object or a string that can be
+passed as the "name" parameter to C<< DateTime::TimeZone->new() >>.
+If the new time zone's offset is different from the old time zone,
+then the I<local> time is adjusted accordingly.
+
+If the old time zone was a floating time zone, then no adjustments to
+the local time are made, except to account for leap seconds. If the
+new time zone is floating, then the I<UTC> time is adjusted in order
+to leave the local time untouched.
+
+=item * duration
+
+The total size of the set, as a C<DateTime::Duration> object, or as a
+scalar containing infinity.
+
+Also available as C<size()>.
+
+=item * start
+
+=item * end
+
+First or last dates in the span.
+
+It is possible that the return value from these methods may be a
+C<DateTime::Infinite::Future> or a C<DateTime::Infinite::Past>xs object.
+
+If the set ends C<before> a date C<$dt>, it returns C<$dt>. Note that
+in this case C<$dt> is not a set element - but it is a set boundary.
+
+=cut
+
+# scalar containing either negative infinity
+# or positive infinity.
+
+=item * start_is_closed
+
+=item * end_is_closed
+
+Returns true if the first or last dates belong to the span ( begin <= x <= end ).
+
+=item * start_is_open
+
+=item * end_is_open
+
+Returns true if the first or last dates are excluded from the span ( begin < x < end ).
+
+=item * union
+
+=item * intersection
+
+=item * complement
+
+Set operations may be performed not only with C<DateTime::Span>
+objects, but also with C<DateTime::Set> and C<DateTime::SpanSet>
+objects. These set operations always return a C<DateTime::SpanSet>
+object.
+
+ $set = $span->union( $set2 ); # like "OR", "insert", "both"
+ $set = $span->complement( $set2 ); # like "delete", "remove"
+ $set = $span->intersection( $set2 ); # like "AND", "while"
+ $set = $span->complement; # like "NOT", "negate", "invert"
+
+=item * intersects
+
+=item * contains
+
+These set functions return a boolean value.
+
+ if ( $span->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $span->contains( $dt ) ) { ... # like "is-fully-inside"
+
+These methods can accept a C<DateTime>, C<DateTime::Set>,
+C<DateTime::Span>, or C<DateTime::SpanSet> object as an argument.
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+The API was developed together with Dave Rolsky and the DateTime Community.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003-2006 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can distribute it and/or modify it
+under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file
+included with this module.
+
+=head1 SEE ALSO
+
+Set::Infinite
+
+For details on the Perl DateTime Suite project please see
+L<http://datetime.perl.org>.
+
+=cut
+
--- /dev/null
+# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package DateTime::SpanSet;
+
+use strict;
+
+use DateTime::Set;
+use DateTime::Infinite;
+
+use Carp;
+use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
+use vars qw( $VERSION );
+
+use constant INFINITY => 100 ** 100 ** 100 ;
+use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
+$VERSION = $DateTime::Set::VERSION;
+
+sub iterate {
+ my ( $self, $callback ) = @_;
+ my $class = ref( $self );
+ my $return = $class->empty_set;
+ $return->{set} = $self->{set}->iterate(
+ sub {
+ my $span = bless { set => $_[0] }, 'DateTime::Span';
+ $callback->( $span->clone );
+ $span = $span->{set}
+ if UNIVERSAL::can( $span, 'union' );
+ return $span;
+ }
+ );
+ $return;
+}
+
+sub map {
+ my ( $self, $callback ) = @_;
+ my $class = ref( $self );
+ die "The callback parameter to map() must be a subroutine reference"
+ unless ref( $callback ) eq 'CODE';
+ my $return = $class->empty_set;
+ $return->{set} = $self->{set}->iterate(
+ sub {
+ local $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
+ my @list = $callback->();
+ my $set = $class->empty_set;
+ $set = $set->union( $_ ) for @list;
+ return $set->{set};
+ }
+ );
+ $return;
+}
+
+sub grep {
+ my ( $self, $callback ) = @_;
+ my $class = ref( $self );
+ die "The callback parameter to grep() must be a subroutine reference"
+ unless ref( $callback ) eq 'CODE';
+ my $return = $class->empty_set;
+ $return->{set} = $self->{set}->iterate(
+ sub {
+ local $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
+ my $result = $callback->();
+ return $_ if $result;
+ return;
+ }
+ );
+ $return;
+}
+
+sub set_time_zone {
+ my ( $self, $tz ) = @_;
+
+ # TODO - use iterate() instead
+
+ my $result = $self->{set}->iterate(
+ sub {
+ my %tmp = %{ $_[0]->{list}[0] };
+ $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
+ $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
+ \%tmp;
+ },
+ backtrack_callback => sub {
+ my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
+ if ( ref($min) )
+ {
+ $min = $min->clone;
+ $min->set_time_zone( 'floating' );
+ }
+ if ( ref($max) )
+ {
+ $max = $max->clone;
+ $max->set_time_zone( 'floating' );
+ }
+ return Set::Infinite::_recurrence->new( $min, $max );
+ },
+ );
+
+ ### this code enables 'subroutine method' behaviour
+ $self->{set} = $result;
+ return $self;
+}
+
+sub from_spans {
+ my $class = shift;
+ my %args = validate( @_,
+ { spans =>
+ { type => ARRAYREF,
+ optional => 1,
+ },
+ }
+ );
+ my $self = {};
+ my $set = Set::Infinite::_recurrence->new();
+ $set = $set->union( $_->{set} ) for @{ $args{spans} };
+ $self->{set} = $set;
+ bless $self, $class;
+ return $self;
+}
+
+sub from_set_and_duration {
+ # set => $dt_set, days => 1
+ my $class = shift;
+ my %args = @_;
+ my $set = delete $args{set} ||
+ carp "from_set_and_duration needs a 'set' parameter";
+
+ $set = $set->as_set
+ if UNIVERSAL::can( $set, 'as_set' );
+ unless ( UNIVERSAL::can( $set, 'union' ) ) {
+ carp "'set' must be a set" };
+
+ my $duration = delete $args{duration} ||
+ new DateTime::Duration( %args );
+ my $end_set = $set->clone->add_duration( $duration );
+ return $class->from_sets( start_set => $set,
+ end_set => $end_set );
+}
+
+sub from_sets {
+ my $class = shift;
+ my %args = validate( @_,
+ { start_set =>
+ { # can => 'union',
+ optional => 0,
+ },
+ end_set =>
+ { # can => 'union',
+ optional => 0,
+ },
+ }
+ );
+ my $start_set = delete $args{start_set};
+ my $end_set = delete $args{end_set};
+
+ $start_set = $start_set->as_set
+ if UNIVERSAL::can( $start_set, 'as_set' );
+ $end_set = $end_set->as_set
+ if UNIVERSAL::can( $end_set, 'as_set' );
+
+ unless ( UNIVERSAL::can( $start_set, 'union' ) ) {
+ carp "'start_set' must be a set" };
+ unless ( UNIVERSAL::can( $end_set, 'union' ) ) {
+ carp "'end_set' must be a set" };
+
+ my $self;
+ $self->{set} = $start_set->{set}->until(
+ $end_set->{set} );
+ bless $self, $class;
+ return $self;
+}
+
+sub start_set {
+ if ( exists $_[0]->{set}{method} &&
+ $_[0]->{set}{method} eq 'until' )
+ {
+ return bless { set => $_[0]->{set}{parent}[0] }, 'DateTime::Set';
+ }
+ my $return = DateTime::Set->empty_set;
+ $return->{set} = $_[0]->{set}->start_set;
+ $return;
+}
+
+sub end_set {
+ if ( exists $_[0]->{set}{method} &&
+ $_[0]->{set}{method} eq 'until' )
+ {
+ return bless { set => $_[0]->{set}{parent}[1] }, 'DateTime::Set';
+ }
+ my $return = DateTime::Set->empty_set;
+ $return->{set} = $_[0]->{set}->end_set;
+ $return;
+}
+
+sub empty_set {
+ my $class = shift;
+
+ return bless { set => Set::Infinite::_recurrence->new }, $class;
+}
+
+sub clone {
+ bless {
+ set => $_[0]->{set}->copy,
+ }, ref $_[0];
+}
+
+
+sub iterator {
+ my $self = shift;
+
+ my %args = @_;
+ my $span;
+ $span = delete $args{span};
+ $span = DateTime::Span->new( %args ) if %args;
+
+ return $self->intersection( $span ) if $span;
+ return $self->clone;
+}
+
+
+# next() gets the next element from an iterator()
+sub next {
+ my ($self) = shift;
+
+ # TODO: this is fixing an error from elsewhere
+ # - find out what's going on! (with "sunset.pl")
+ return undef unless ref $self->{set};
+
+ if ( @_ )
+ {
+ my $max;
+ $max = $_[0]->max if UNIVERSAL::can( $_[0], 'union' );
+ $max = $_[0] if ! defined $max;
+
+ return undef if ! ref( $max ) && $max == INFINITY;
+
+ my $span = DateTime::Span->from_datetimes( start => $max );
+ my $iterator = $self->intersection( $span );
+ my $return = $iterator->next;
+
+ return $return if ! defined $return;
+ return $return if ! $return->intersects( $max );
+
+ return $iterator->next;
+ }
+
+ my ($head, $tail) = $self->{set}->first;
+ $self->{set} = $tail;
+ return $head unless ref $head;
+ my $return = {
+ set => $head,
+ };
+ bless $return, 'DateTime::Span';
+ return $return;
+}
+
+# previous() gets the last element from an iterator()
+sub previous {
+ my ($self) = shift;
+
+ return undef unless ref $self->{set};
+
+ if ( @_ )
+ {
+ my $min;
+ $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
+ $min = $_[0] if ! defined $min;
+
+ return undef if ! ref( $min ) && $min == INFINITY;
+
+ my $span = DateTime::Span->from_datetimes( end => $min );
+ my $iterator = $self->intersection( $span );
+ my $return = $iterator->previous;
+
+ return $return if ! defined $return;
+ return $return if ! $return->intersects( $min );
+
+ return $iterator->previous;
+ }
+
+ my ($head, $tail) = $self->{set}->last;
+ $self->{set} = $tail;
+ return $head unless ref $head;
+ my $return = {
+ set => $head,
+ };
+ bless $return, 'DateTime::Span';
+ return $return;
+}
+
+# "current" means less-or-equal to a DateTime
+sub current {
+ my $self = shift;
+
+ my $previous;
+ my $next;
+ {
+ my $min;
+ $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
+ $min = $_[0] if ! defined $min;
+ return undef if ! ref( $min ) && $min == INFINITY;
+ my $span = DateTime::Span->from_datetimes( end => $min );
+ my $iterator = $self->intersection( $span );
+ $previous = $iterator->previous;
+ $span = DateTime::Span->from_datetimes( start => $min );
+ $iterator = $self->intersection( $span );
+ $next = $iterator->next;
+ }
+ return $previous unless defined $next;
+
+ my $dt1 = defined $previous
+ ? $next->union( $previous )
+ : $next;
+
+ my $return = $dt1->intersected_spans( $_[0] );
+
+ $return = $previous
+ if !defined $return->max;
+
+ bless $return, 'DateTime::SpanSet'
+ if defined $return;
+ return $return;
+}
+
+sub closest {
+ my $self = shift;
+ my $dt = shift;
+
+ my $dt1 = $self->current( $dt );
+ my $dt2 = $self->next( $dt );
+ bless $dt2, 'DateTime::SpanSet'
+ if defined $dt2;
+
+ return $dt2 unless defined $dt1;
+ return $dt1 unless defined $dt2;
+
+ $dt = DateTime::Set->from_datetimes( dates => [ $dt ] )
+ unless UNIVERSAL::can( $dt, 'union' );
+
+ return $dt1 if $dt1->contains( $dt );
+
+ my $delta = $dt->min - $dt1->max;
+ return $dt1 if ( $dt2->min - $delta ) >= $dt->max;
+
+ return $dt2;
+}
+
+sub as_list {
+ my $self = shift;
+ return undef unless ref( $self->{set} );
+
+ my %args = @_;
+ my $span;
+ $span = delete $args{span};
+ $span = DateTime::Span->new( %args ) if %args;
+
+ my $set = $self->clone;
+ $set = $set->intersection( $span ) if $span;
+
+ # Note: removing this line means we may end up in an infinite loop!
+ return undef if $set->{set}->is_too_complex; # undef = no begin/end
+
+ # return if $set->{set}->is_null; # nothing = empty
+ my @result;
+ # we should extract _copies_ of the set elements,
+ # such that the user can't modify the set indirectly
+
+ my $iter = $set->iterator;
+ while ( my $dt = $iter->next )
+ {
+ push @result, $dt
+ if ref( $dt ); # we don't want to return INFINITY value
+ };
+
+ return @result;
+}
+
+# Set::Infinite methods
+
+sub intersection {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
+ return $tmp;
+}
+
+sub intersected_spans {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->intersected_spans( $set2->{set} );
+ return $tmp;
+}
+
+sub intersects {
+ my ($set1, $set2) = ( shift, shift );
+
+ unless ( $set2->can( 'union' ) )
+ {
+ for ( $set2, @_ )
+ {
+ return 1 if $set1->contains( $_ );
+ }
+ return 0;
+ }
+
+ my $class = ref($set1);
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ return $set1->{set}->intersects( $set2->{set} );
+}
+
+sub contains {
+ my ($set1, $set2) = ( shift, shift );
+
+ unless ( $set2->can( 'union' ) )
+ {
+ if ( exists $set1->{set}{method} &&
+ $set1->{set}{method} eq 'until' )
+ {
+ my $start_set = $set1->start_set;
+ my $end_set = $set1->end_set;
+
+ for ( $set2, @_ )
+ {
+ my $start = $start_set->next( $set2 );
+ my $end = $end_set->next( $set2 );
+
+ goto ABORT unless defined $start && defined $end;
+
+ return 0 if $start < $end;
+ }
+ return 1;
+
+ ABORT: ;
+ # don't know
+ }
+ }
+
+ my $class = ref($set1);
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ return $set1->{set}->contains( $set2->{set} );
+}
+
+sub union {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->union( $set2->{set} );
+ return $tmp;
+}
+
+sub complement {
+ my ($set1, $set2) = ( shift, shift );
+ my $class = ref($set1);
+ my $tmp = $class->empty_set();
+ if (defined $set2) {
+ $set2 = $set2->as_spanset
+ if $set2->can( 'as_spanset' );
+ $set2 = $set2->as_set
+ if $set2->can( 'as_set' );
+ $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
+ unless $set2->can( 'union' );
+ $tmp->{set} = $set1->{set}->complement( $set2->{set} );
+ }
+ else {
+ $tmp->{set} = $set1->{set}->complement;
+ }
+ return $tmp;
+}
+
+sub min {
+ return DateTime::Set::_fix_datetime( $_[0]->{set}->min );
+}
+
+sub max {
+ return DateTime::Set::_fix_datetime( $_[0]->{set}->max );
+}
+
+# returns a DateTime::Span
+sub span {
+ my $set = $_[0]->{set}->span;
+ my $self = bless { set => $set }, 'DateTime::Span';
+ return $self;
+}
+
+# returns a DateTime::Duration
+sub duration {
+ my $dur;
+
+ return DateTime::Duration->new( seconds => 0 )
+ if $_[0]->{set}->is_empty;
+
+ local $@;
+ eval {
+ local $SIG{__DIE__}; # don't want to trap this (rt ticket 5434)
+ $dur = $_[0]->{set}->size
+ };
+
+ return $dur if defined $dur && ref( $dur );
+ return DateTime::Infinite::Future->new -
+ DateTime::Infinite::Past->new;
+ # return INFINITY;
+}
+*size = \&duration;
+
+1;
+
+__END__
+
+=head1 NAME
+
+DateTime::SpanSet - set of DateTime spans
+
+=head1 SYNOPSIS
+
+ $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span, $dt_span ] );
+
+ $set = $spanset->union( $set2 ); # like "OR", "insert", "both"
+ $set = $spanset->complement( $set2 ); # like "delete", "remove"
+ $set = $spanset->intersection( $set2 ); # like "AND", "while"
+ $set = $spanset->complement; # like "NOT", "negate", "invert"
+
+ if ( $spanset->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $spanset->contains( $set2 ) ) { ... # like "is-fully-inside"
+
+ # data extraction
+ $date = $spanset->min; # first date of the set
+ $date = $spanset->max; # last date of the set
+
+ $iter = $spanset->iterator;
+ while ( $dt = $iter->next ) {
+ # $dt is a DateTime::Span
+ print $dt->start->ymd; # first date of span
+ print $dt->end->ymd; # last date of span
+ };
+
+=head1 DESCRIPTION
+
+C<DateTime::SpanSet> is a class that represents sets of datetime
+spans. An example would be a recurring meeting that occurs from
+13:00-15:00 every Friday.
+
+This is different from a C<DateTime::Set>, which is made of individual
+datetime points as opposed to ranges.
+
+=head1 METHODS
+
+=over 4
+
+=item * from_spans
+
+Creates a new span set from one or more C<DateTime::Span> objects.
+
+ $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span ] );
+
+=item * from_set_and_duration
+
+Creates a new span set from one or more C<DateTime::Set> objects and a
+duration.
+
+The duration can be a C<DateTime::Duration> object, or the parameters
+to create a new C<DateTime::Duration> object, such as "days",
+"months", etc.
+
+ $spanset =
+ DateTime::SpanSet->from_set_and_duration
+ ( set => $dt_set, days => 1 );
+
+=item * from_sets
+
+Creates a new span set from two C<DateTime::Set> objects.
+
+One set defines the I<starting dates>, and the other defines the I<end
+dates>.
+
+ $spanset =
+ DateTime::SpanSet->from_sets
+ ( start_set => $dt_set1, end_set => $dt_set2 );
+
+The spans have the starting date C<closed>, and the end date C<open>,
+like in C<[$dt1, $dt2)>.
+
+If an end date comes without a starting date before it, then it
+defines a span like C<(-inf, $dt)>.
+
+If a starting date comes without an end date after it, then it defines
+a span like C<[$dt, inf)>.
+
+=item * empty_set
+
+Creates a new empty set.
+
+=item * clone
+
+This object method returns a replica of the given object.
+
+=item * set_time_zone( $tz )
+
+This method accepts either a time zone object or a string that can be
+passed as the "name" parameter to C<< DateTime::TimeZone->new() >>.
+If the new time zone's offset is different from the old time zone,
+then the I<local> time is adjusted accordingly.
+
+If the old time zone was a floating time zone, then no adjustments to
+the local time are made, except to account for leap seconds. If the
+new time zone is floating, then the I<UTC> time is adjusted in order
+to leave the local time untouched.
+
+=item * min
+
+=item * max
+
+First or last dates in the set. These methods may return C<undef> if
+the set is empty. It is also possible that these methods may return a
+scalar containing infinity or negative infinity.
+
+=item * duration
+
+The total size of the set, as a C<DateTime::Duration> object.
+
+The duration may be infinite.
+
+Also available as C<size()>.
+
+=item * span
+
+The total span of the set, as a C<DateTime::Span> object.
+
+=item * next
+
+ my $span = $set->next( $dt );
+
+This method is used to find the next span in the set,
+after a given datetime or span.
+
+The return value is a C<DateTime::Span>, or C<undef> if there is no matching
+span in the set.
+
+=item * previous
+
+ my $span = $set->previous( $dt );
+
+This method is used to find the previous span in the set,
+before a given datetime or span.
+
+The return value is a C<DateTime::Span>, or C<undef> if there is no matching
+span in the set.
+
+
+=item * current
+
+ my $span = $set->current( $dt );
+
+This method is used to find the "current" span in the set,
+that intersects a given datetime or span. If no current span
+is found, then the "previous" span is returned.
+
+The return value is a C<DateTime::SpanSet>, or C<undef> if there is no
+matching span in the set.
+
+If a span parameter is given, it may happen that "current" returns
+more than one span.
+
+See also: C<intersected_spans()> method.
+
+=item * closest
+
+ my $span = $set->closest( $dt );
+
+This method is used to find the "closest" span in the set, given a
+datetime or span.
+
+The return value is a C<DateTime::SpanSet>, or C<undef> if the set is
+empty.
+
+If a span parameter is given, it may happen that "closest" returns
+more than one span.
+
+=item * as_list
+
+Returns a list of C<DateTime::Span> objects.
+
+ my @dt_span = $set->as_list( span => $span );
+
+Just as with the C<iterator()> method, the C<as_list()> method can be
+limited by a span.
+
+Applying C<as_list()> to a large recurring spanset is a very expensive
+operation, both in CPU time and in the memory used.
+
+For this reason, when C<as_list()> operates on large recurrence sets,
+it will return at most approximately 200 spans. For larger sets, and
+for I<infinite> sets, C<as_list()> will return C<undef>.
+
+Please note that this is explicitly not an empty list, since an empty
+list is a valid return value for empty sets!
+
+If you I<really> need to extract spans from a large set, you can:
+
+- limit the set with a shorter span:
+
+ my @short_list = $large_set->as_list( span => $short_span );
+
+- use an iterator:
+
+ my @large_list;
+ my $iter = $large_set->iterator;
+ push @large_list, $dt while $dt = $iter->next;
+
+=item * union
+
+=item * intersection
+
+=item * complement
+
+Set operations may be performed not only with C<DateTime::SpanSet>
+objects, but also with C<DateTime>, C<DateTime::Set> and
+C<DateTime::Span> objects. These set operations always return a
+C<DateTime::SpanSet> object.
+
+ $set = $spanset->union( $set2 ); # like "OR", "insert", "both"
+ $set = $spanset->complement( $set2 ); # like "delete", "remove"
+ $set = $spanset->intersection( $set2 ); # like "AND", "while"
+ $set = $spanset->complement; # like "NOT", "negate", "invert"
+
+=item * intersected_spans
+
+This method can accept a C<DateTime> list, a C<DateTime::Set>, a
+C<DateTime::Span>, or a C<DateTime::SpanSet> object as an argument.
+
+ $set = $set1->intersected_spans( $set2 );
+
+The method always returns a C<DateTime::SpanSet> object, containing
+all spans that are intersected by the given set.
+
+Unlike the C<intersection> method, the spans are not modified. See
+diagram below:
+
+ set1 [....] [....] [....] [....]
+ set2 [................]
+
+ intersection [.] [....] [.]
+
+ intersected_spans [....] [....] [....]
+
+=item * intersects
+
+=item * contains
+
+These set functions return a boolean value.
+
+ if ( $spanset->intersects( $set2 ) ) { ... # like "touches", "interferes"
+ if ( $spanset->contains( $dt ) ) { ... # like "is-fully-inside"
+
+These methods can accept a C<DateTime>, C<DateTime::Set>,
+C<DateTime::Span>, or C<DateTime::SpanSet> object as an argument.
+
+=item * iterator / next / previous
+
+This method can be used to iterate over the spans in a set.
+
+ $iter = $spanset->iterator;
+ while ( $dt = $iter->next ) {
+ # $dt is a DateTime::Span
+ print $dt->min->ymd; # first date of span
+ print $dt->max->ymd; # last date of span
+ }
+
+The boundaries of the iterator can be limited by passing it a C<span>
+parameter. This should be a C<DateTime::Span> object which delimits
+the iterator's boundaries. Optionally, instead of passing an object,
+you can pass any parameters that would work for one of the
+C<DateTime::Span> class's constructors, and an object will be created
+for you.
+
+Obviously, if the span you specify does is not restricted both at the
+start and end, then your iterator may iterate forever, depending on
+the nature of your set. User beware!
+
+The C<next()> or C<previous()> methods will return C<undef> when there
+are no more spans in the iterator.
+
+=item * start_set
+
+=item * end_set
+
+These methods do the inverse of the C<from_sets> method:
+
+C<start_set> retrieves a DateTime::Set with the start datetime of each
+span.
+
+C<end_set> retrieves a DateTime::Set with the end datetime of each
+span.
+
+=item * map ( sub { ... } )
+
+ # example: enlarge the spans
+ $set = $set2->map(
+ sub {
+ my $start = $_->start;
+ my $end = $_->end;
+ return DateTime::Span->from_datetimes(
+ start => $start,
+ before => $end,
+ );
+ }
+ );
+
+This method is the "set" version of Perl "map".
+
+It evaluates a subroutine for each element of the set (locally setting
+"$_" to each DateTime::Span) and returns the set composed of the
+results of each such evaluation.
+
+Like Perl "map", each element of the set may produce zero, one, or
+more elements in the returned value.
+
+Unlike Perl "map", changing "$_" does not change the original
+set. This means that calling map in void context has no effect.
+
+The callback subroutine may not be called immediately. Don't count on
+subroutine side-effects. For example, a C<print> inside the subroutine
+may happen later than you expect.
+
+The callback return value is expected to be within the span of the
+C<previous> and the C<next> element in the original set.
+
+For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
+result for the value C<2010> is expected to be within the span C<[
+2001 .. 2015 ]>.
+
+=item * grep ( sub { ... } )
+
+ # example: filter out all spans happening today
+ my $today = DateTime->today;
+ $set = $set2->grep(
+ sub {
+ return ( ! $_->contains( $today ) );
+ }
+ );
+
+This method is the "set" version of Perl "grep".
+
+It evaluates a subroutine for each element of the set (locally setting
+"$_" to each DateTime::Span) and returns the set consisting of those
+elements for which the expression evaluated to true.
+
+Unlike Perl "grep", changing "$_" does not change the original
+set. This means that calling grep in void context has no effect.
+
+Changing "$_" does change the resulting set.
+
+The callback subroutine may not be called immediately. Don't count on
+subroutine side-effects. For example, a C<print> inside the subroutine
+may happen later than you expect.
+
+=item * iterate
+
+I<Internal method - use "map" or "grep" instead.>
+
+This function apply a callback subroutine to all elements of a set and
+returns the resulting set.
+
+The parameter C<$_[0]> to the callback subroutine is a
+C<DateTime::Span> object.
+
+If the callback returns C<undef>, the datetime is removed from the
+set:
+
+ sub remove_sundays {
+ $_[0] unless $_[0]->start->day_of_week == 7;
+ }
+
+The callback return value is expected to be within the span of the
+C<previous> and the C<next> element in the original set.
+
+For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
+result for the value C<2010> is expected to be within the span C<[
+2001 .. 2015 ]>.
+
+The callback subroutine may not be called immediately. Don't count on
+subroutine side-effects. For example, a C<print> inside the subroutine
+may happen later than you expect.
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+The API was developed together with Dave Rolsky and the DateTime Community.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can distribute it and/or
+modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file
+included with this module.
+
+=head1 SEE ALSO
+
+Set::Infinite
+
+For details on the Perl DateTime Suite project please see
+L<http://datetime.perl.org>.
+
+=cut
+
--- /dev/null
+# Copyright (C) 1996, 1998 David Muir Sharnoff
+
+package File::Flock;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(lock unlock lock_rename);
+
+use Carp;
+use POSIX qw(EAGAIN EACCES EWOULDBLOCK ENOENT EEXIST O_EXCL O_CREAT O_RDWR);
+use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN);
+use IO::File;
+
+use vars qw($VERSION $debug $av0debug);
+
+BEGIN {
+ $VERSION = 2008.01;
+ $debug = 0;
+ $av0debug = 0;
+}
+
+use strict;
+no strict qw(refs);
+
+my %locks; # did we create the file?
+my %lockHandle;
+my %shared;
+my %pid;
+my %rm;
+
+sub new
+{
+ my ($pkg, $file, $shared, $nonblocking) = @_;
+ &lock($file, $shared, $nonblocking) or return undef;
+ return bless \$file, $pkg;
+}
+
+sub DESTROY
+{
+ my ($this) = @_;
+ unlock($$this);
+}
+
+sub lock
+{
+ my ($file, $shared, $nonblocking) = @_;
+
+ my $f = new IO::File;
+
+ my $created = 0;
+ my $previous = exists $locks{$file};
+
+ # the file may be springing in and out of existance...
+ OPEN:
+ for(;;) {
+ if (-e $file) {
+ unless (sysopen($f, $file, O_RDWR)) {
+ redo OPEN if $! == ENOENT;
+ croak "open $file: $!";
+ }
+ } else {
+ unless (sysopen($f, $file, O_CREAT|O_EXCL|O_RDWR)) {
+ redo OPEN if $! == EEXIST;
+ croak "open >$file: $!";
+ }
+ print STDERR " {$$ " if $debug; # }
+ $created = 1;
+ }
+ last;
+ }
+ $locks{$file} = $created || $locks{$file} || 0;
+ $shared{$file} = $shared;
+ $pid{$file} = $$;
+
+ $lockHandle{$file} = $f;
+
+ my $flags;
+
+ $flags = $shared ? LOCK_SH : LOCK_EX;
+ $flags |= LOCK_NB
+ if $nonblocking;
+
+ local($0) = "$0 - locking $file" if $av0debug && ! $nonblocking;
+ my $r = flock($f, $flags);
+
+ print STDERR " ($$ " if $debug and $r;
+
+ if ($r) {
+ # let's check to make sure the file wasn't
+ # removed on us!
+
+ my $ifile = (stat($file))[1];
+ my $ihandle;
+ eval { $ihandle = (stat($f))[1] };
+ croak $@ if $@;
+
+ return 1 if defined $ifile
+ and defined $ihandle
+ and $ifile == $ihandle;
+
+ # oh well, try again
+ flock($f, LOCK_UN);
+ close($f);
+ return File::Flock::lock($file);
+ }
+
+ return 1 if $r;
+ if ($nonblocking and
+ (($! == EAGAIN)
+ or ($! == EACCES)
+ or ($! == EWOULDBLOCK)))
+ {
+ if (! $previous) {
+ delete $locks{$file};
+ delete $lockHandle{$file};
+ delete $shared{$file};
+ delete $pid{$file};
+ }
+ if ($created) {
+ # oops, a bad thing just happened.
+ # We don't want to block, but we made the file.
+ &background_remove($f, $file);
+ }
+ close($f);
+ return 0;
+ }
+ croak "flock $f $flags: $!";
+}
+
+#
+# get a lock on a file and remove it if it's empty. This is to
+# remove files that were created just so that they could be locked.
+#
+# To do this without blocking, defer any files that are locked to the
+# the END block.
+#
+sub background_remove
+{
+ my ($f, $file) = @_;
+
+ if (flock($f, LOCK_EX|LOCK_NB)) {
+ unlink($file)
+ if -s $file == 0;
+ flock($f, LOCK_UN);
+ return 1;
+ } else {
+ $rm{$file} = 1
+ unless exists $rm{$file};
+ return 0;
+ }
+}
+
+sub unlock
+{
+ my ($file) = @_;
+
+ if (ref $file eq 'File::Flock') {
+ bless $file, 'UNIVERSAL'; # avoid destructor later
+ $file = $$file;
+ }
+
+ croak "no lock on $file" unless exists $locks{$file};
+ my $created = $locks{$file};
+ my $unlocked = 0;
+
+
+ my $size = -s $file;
+ if ($created && defined($size) && $size == 0) {
+ if ($shared{$file}) {
+ $unlocked =
+ &background_remove($lockHandle{$file}, $file);
+ } else {
+ # {
+ print STDERR " $$} " if $debug;
+ unlink($file)
+ or croak "unlink $file: $!";
+ }
+ }
+ delete $locks{$file};
+ delete $pid{$file};
+
+ my $f = $lockHandle{$file};
+
+ delete $lockHandle{$file};
+
+ return 0 unless defined $f;
+
+ print STDERR " $$) " if $debug;
+ $unlocked or flock($f, LOCK_UN)
+ or croak "flock $file UN: $!";
+
+ close($f);
+ return 1;
+}
+
+sub lock_rename
+{
+ my ($oldfile, $newfile) = @_;
+
+ if (exists $locks{$newfile}) {
+ unlock $newfile;
+ }
+ delete $locks{$newfile};
+ delete $shared{$newfile};
+ delete $pid{$newfile};
+ delete $lockHandle{$newfile};
+ delete $rm{$newfile};
+
+ $locks{$newfile} = $locks{$oldfile} if exists $locks{$oldfile};
+ $shared{$newfile} = $shared{$oldfile} if exists $shared{$oldfile};
+ $pid{$newfile} = $pid{$oldfile} if exists $pid{$oldfile};
+ $lockHandle{$newfile} = $lockHandle{$oldfile} if exists $lockHandle{$oldfile};
+ $rm{$newfile} = $rm{$oldfile} if exists $rm{$oldfile};
+
+ delete $locks{$oldfile};
+ delete $shared{$oldfile};
+ delete $pid{$oldfile};
+ delete $lockHandle{$oldfile};
+ delete $rm{$oldfile};
+}
+
+#
+# Unlock any files that are still locked and remove any files
+# that were created just so that they could be locked.
+#
+END {
+ my $f;
+ for $f (keys %locks) {
+ &unlock($f)
+ if $pid{$f} == $$;
+ }
+
+ my %bgrm;
+ for my $file (keys %rm) {
+ my $f = new IO::File;
+ if (sysopen($f, $file, O_RDWR)) {
+ if (flock($f, LOCK_EX|LOCK_NB)) {
+ unlink($file)
+ if -s $file == 0;
+ flock($f, LOCK_UN);
+ } else {
+ $bgrm{$file} = 1;
+ }
+ close($f);
+ }
+ }
+ if (%bgrm) {
+ my $ppid = fork;
+ croak "cannot fork" unless defined $ppid;
+ my $pppid = $$;
+ my $b0 = $0;
+ $0 = "$b0: waiting for child ($ppid) to fork()";
+ unless ($ppid) {
+ my $pid = fork;
+ croak "cannot fork" unless defined $pid;
+ unless ($pid) {
+ for my $file (keys %bgrm) {
+ my $f = new IO::File;
+ if (sysopen($f, $file, O_RDWR)) {
+ if (flock($f, LOCK_EX)) {
+ unlink($file)
+ if -s $file == 0;
+ flock($f, LOCK_UN);
+ }
+ close($f);
+ }
+ }
+ print STDERR " $pppid] $pppid)" if $debug;
+ }
+ kill(9, $$); # exit w/o END or anything else
+ }
+ waitpid($ppid, 0);
+ kill(9, $$); # exit w/o END or anything else
+ }
+}
+
+1;
+
+__DATA__
+
+=head1 NAME
+
+ File::Flock - file locking with flock
+
+=head1 SYNOPSIS
+
+ use File::Flock;
+
+ lock($filename);
+
+ lock($filename, 'shared');
+
+ lock($filename, undef, 'nonblocking');
+
+ lock($filename, 'shared', 'nonblocking');
+
+ unlock($filename);
+
+ my $lock = new File::Flock '/somefile';
+
+ lock_rename($oldfilename, $newfilename)
+
+=head1 DESCRIPTION
+
+Lock files using the flock() call. If the file to be locked does not
+exist, then the file is created. If the file was created then it will
+be removed when it is unlocked assuming it's still an empty file.
+
+Locks can be created by new'ing a B<File::Flock> object. Such locks
+are automatically removed when the object goes out of scope. The
+B<unlock()> method may also be used.
+
+B<lock_rename()> is used to tell File::Flock when a file has been
+renamed (and thus the internal locking data that is stored based
+on the filename should be moved to a new name). B<unlock()> the
+new name rather than the original name.
+
+=head1 LICENSE
+
+File::Flock may be used/modified/distibuted on the same terms
+as perl itself.
+
+=head1 AUTHOR
+
+David Muir Sharnoff <muir@idiom.org>
+
+
--- /dev/null
+# Copyright 2001 Abhijit Menon-Sen <ams@toroid.org>
+
+package Set::Crontab;
+
+use strict;
+use Carp;
+use vars qw( $VERSION );
+
+$VERSION = '1.03';
+
+sub _expand
+{
+ my (@list, @and, @not);
+ my ($self, $spec, $range) = @_;
+
+ # 1,2-4,*/3,!13,>9,<15
+ foreach (split /,/, $spec) {
+ my @pick;
+ my $step = $1 if s#/(\d+)$##;
+
+ # 0+"01" == 1
+ if (/^(\d+)$/) { push @pick, 0+$1; }
+ elsif (/^\*$/) { push @pick, @$range; }
+ elsif (/^(\d+)-(\d+)$/) { push @pick, 0+$1..0+$2; }
+ elsif (/^!(\d+)$/) { push @not, "\$_ != 0+$1"; }
+ elsif (/^([<>])(\d+)$/) { push @and, "\$_ $1 0+$2"; }
+
+ if ($step) {
+ my $i;
+ @pick = grep { defined $_ if $i++ % $step == 0 } @pick;
+ }
+
+ push @list, @pick;
+ }
+
+ if (@and) {
+ my $and = join q{ && }, @and;
+ push @list, grep { defined $_ if eval $and } @$range;
+ }
+
+ if (@not) {
+ my $not = join q{ && }, @not;
+ @list = grep { defined $_ if eval $not } (@list ? @list : @$range);
+ }
+
+ @list = sort { $a <=> $b } @list;
+ return \@list;
+}
+
+sub _initialise
+{
+ my ($self, $spec, $range) = @_;
+ return undef unless ref($self);
+
+ croak "Usage: ".__PACKAGE__."->new(\$spec, [\@range])"
+ unless defined $spec && ref($range) eq "ARRAY";
+
+ $self->{LIST} = $self->_expand($spec, $range);
+ $self->{HASH} = {map {$_ => 1} @{$self->{LIST}}};
+
+ return $self;
+};
+
+sub new
+{
+ my $class = shift;
+ my $self = bless {}, ref($class) || $class;
+ return $self->_initialise(@_);
+}
+
+sub contains
+{
+ my ($self, $num) = @_;
+
+ croak "Usage: \$set->contains(\$num)" unless ref($self) && defined $num;
+ return exists $self->{HASH}{$num};
+}
+
+sub list
+{
+ my $self = shift;
+
+ croak "Usage: \$set->list()" unless ref($self);
+ return @{$self->{LIST}};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Set::Crontab - Expand crontab(5)-style integer lists
+
+=head1 SYNOPSIS
+
+$s = Set::Crontab->new("1-9/3,>15,>30,!23", [0..30]);
+
+if ($s->contains(3)) { ... }
+
+=head1 DESCRIPTION
+
+Set::Crontab parses crontab-style lists of integers and defines some
+utility functions to make it easier to deal with them.
+
+=head2 Syntax
+
+Numbers, ranges, *, and step values all work exactly as described in
+L<crontab(5)>. A few extensions to the standard syntax are described
+below.
+
+=over 4
+
+=item < and >
+
+<N selects the elements smaller than N from the entire range, and adds
+them to the set. >N does likewise for elements larger than N.
+
+=item !
+
+!N excludes N from the set. It applies to the other specified
+range; otherwise it applies to the specified ranges (i.e. "!3" with a
+range of "1-10" corresponds to "1-2,4-10", but ">3,!7" in the same range
+means "4-6,8-10").
+
+=back
+
+=head2 Functions
+
+=over 4
+
+=item new($spec, [@range])
+
+Creates a new Set::Crontab object and returns a reference to it.
+
+=item contains($num)
+
+Returns true if C<$num> exists in the set.
+
+=item list()
+
+Returns the expanded list corresponding to the set. Elements are in
+ascending order.
+
+=back
+
+The functions described above croak if they are called with incorrect
+arguments.
+
+=head1 SEE ALSO
+
+L<crontab(5)>
+
+=head1 AUTHOR
+
+Abhijit Menon-Sen <ams@toroid.org>
+
+Copyright 2001 Abhijit Menon-Sen <ams@toroid.org>
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
--- /dev/null
+package Set::Infinite;
+
+# Copyright (c) 2001, 2002, 2003, 2004 Flavio Soibelmann Glock.
+# All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+use 5.005_03;
+
+# These methods are inherited from Set::Infinite::Basic "as-is":
+# type list fixtype numeric min max integer real new span copy
+# start_set end_set universal_set empty_set minus difference
+# symmetric_difference is_empty
+
+use strict;
+use base qw(Set::Infinite::Basic Exporter);
+use Carp;
+use Set::Infinite::Arithmetic;
+
+use overload
+ '<=>' => \&spaceship,
+ '""' => \&as_string;
+
+use vars qw(@EXPORT_OK $VERSION
+ $TRACE $DEBUG_BT $PRETTY_PRINT $inf $minus_inf $neg_inf
+ %_first %_last %_backtrack
+ $too_complex $backtrack_depth
+ $max_backtrack_depth $max_intersection_depth
+ $trace_level %level_title );
+
+@EXPORT_OK = qw(inf $inf trace_open trace_close);
+
+$inf = 100**100**100;
+$neg_inf = $minus_inf = -$inf;
+
+
+# obsolete methods - included for backward compatibility
+sub inf () { $inf }
+sub minus_inf () { $minus_inf }
+sub no_cleanup { $_[0] }
+*type = \&Set::Infinite::Basic::type;
+sub compact { @_ }
+
+
+BEGIN {
+ $VERSION = "0.65";
+ $TRACE = 0; # enable basic trace method execution
+ $DEBUG_BT = 0; # enable backtrack tracer
+ $PRETTY_PRINT = 0; # 0 = print 'Too Complex'; 1 = describe functions
+ $trace_level = 0; # indentation level when debugging
+
+ $too_complex = "Too complex";
+ $backtrack_depth = 0;
+ $max_backtrack_depth = 10; # _backtrack()
+ $max_intersection_depth = 5; # first()
+}
+
+sub trace { # title=>'aaa'
+ return $_[0] unless $TRACE;
+ my ($self, %parm) = @_;
+ my @caller = caller(1);
+ # print "self $self ". ref($self). "\n";
+ print "" . ( ' | ' x $trace_level ) .
+ "$parm{title} ". $self->copy .
+ ( exists $parm{arg} ? " -- " . $parm{arg}->copy : "" ).
+ " $caller[1]:$caller[2] ]\n" if $TRACE == 1;
+ return $self;
+}
+
+sub trace_open {
+ return $_[0] unless $TRACE;
+ my ($self, %parm) = @_;
+ my @caller = caller(1);
+ print "" . ( ' | ' x $trace_level ) .
+ "\\ $parm{title} ". $self->copy .
+ ( exists $parm{arg} ? " -- ". $parm{arg}->copy : "" ).
+ " $caller[1]:$caller[2] ]\n";
+ $trace_level++;
+ $level_title{$trace_level} = $parm{title};
+ return $self;
+}
+
+sub trace_close {
+ return $_[0] unless $TRACE;
+ my ($self, %parm) = @_;
+ my @caller = caller(0);
+ print "" . ( ' | ' x ($trace_level-1) ) .
+ "\/ $level_title{$trace_level} ".
+ ( exists $parm{arg} ?
+ (
+ defined $parm{arg} ?
+ "ret ". ( UNIVERSAL::isa($parm{arg}, __PACKAGE__ ) ?
+ $parm{arg}->copy :
+ "<$parm{arg}>" ) :
+ "undef"
+ ) :
+ "" # no arg
+ ).
+ " $caller[1]:$caller[2] ]\n";
+ $trace_level--;
+ return $self;
+}
+
+
+# creates a 'function' object that can be solved by _backtrack()
+sub _function {
+ my ($self, $method) = (shift, shift);
+ my $b = $self->empty_set();
+ $b->{too_complex} = 1;
+ $b->{parent} = $self;
+ $b->{method} = $method;
+ $b->{param} = [ @_ ];
+ return $b;
+}
+
+
+# same as _function, but with 2 arguments
+sub _function2 {
+ my ($self, $method, $arg) = (shift, shift, shift);
+ unless ( $self->{too_complex} || $arg->{too_complex} ) {
+ return $self->$method($arg, @_);
+ }
+ my $b = $self->empty_set();
+ $b->{too_complex} = 1;
+ $b->{parent} = [ $self, $arg ];
+ $b->{method} = $method;
+ $b->{param} = [ @_ ];
+ return $b;
+}
+
+
+sub quantize {
+ my $self = shift;
+ $self->trace_open(title=>"quantize") if $TRACE;
+ my @min = $self->min_a;
+ my @max = $self->max_a;
+ if (($self->{too_complex}) or
+ (defined $min[0] && $min[0] == $neg_inf) or
+ (defined $max[0] && $max[0] == $inf)) {
+
+ return $self->_function( 'quantize', @_ );
+ }
+
+ my @a;
+ my %rule = @_;
+ my $b = $self->empty_set();
+ my $parent = $self;
+
+ $rule{unit} = 'one' unless $rule{unit};
+ $rule{quant} = 1 unless $rule{quant};
+ $rule{parent} = $parent;
+ $rule{strict} = $parent unless exists $rule{strict};
+ $rule{type} = $parent->{type};
+
+ my ($min, $open_begin) = $parent->min_a;
+
+ unless (defined $min) {
+ $self->trace_close( arg => $b ) if $TRACE;
+ return $b;
+ }
+
+ $rule{fixtype} = 1 unless exists $rule{fixtype};
+ $Set::Infinite::Arithmetic::Init_quantizer{$rule{unit}}->(\%rule);
+
+ $rule{sub_unit} = $Set::Infinite::Arithmetic::Offset_to_value{$rule{unit}};
+ carp "Quantize unit '".$rule{unit}."' not implemented" unless ref( $rule{sub_unit} ) eq 'CODE';
+
+ my ($max, $open_end) = $parent->max_a;
+ $rule{offset} = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $min);
+ my $last_offset = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $max);
+ $rule{size} = $last_offset - $rule{offset} + 1;
+ my ($index, $tmp, $this, $next);
+ for $index (0 .. $rule{size} ) {
+ # ($this, $next) = $rule{sub_unit} (\%rule, $index);
+ ($this, $next) = $rule{sub_unit}->(\%rule, $index);
+ unless ( $rule{fixtype} ) {
+ $tmp = { a => $this , b => $next ,
+ open_begin => 0, open_end => 1 };
+ }
+ else {
+ $tmp = Set::Infinite::Basic::_simple_new($this,$next, $rule{type} );
+ $tmp->{open_end} = 1;
+ }
+ next if ( $rule{strict} and not $rule{strict}->intersects($tmp));
+ push @a, $tmp;
+ }
+
+ $b->{list} = \@a; # change data
+ $self->trace_close( arg => $b ) if $TRACE;
+ return $b;
+}
+
+
+sub _first_n {
+ my $self = shift;
+ my $n = shift;
+ my $tail = $self->copy;
+ my @result;
+ my $first;
+ for ( 1 .. $n )
+ {
+ ( $first, $tail ) = $tail->first if $tail;
+ push @result, $first;
+ }
+ return $tail, @result;
+}
+
+sub _last_n {
+ my $self = shift;
+ my $n = shift;
+ my $tail = $self->copy;
+ my @result;
+ my $last;
+ for ( 1 .. $n )
+ {
+ ( $last, $tail ) = $tail->last if $tail;
+ unshift @result, $last;
+ }
+ return $tail, @result;
+}
+
+
+sub select {
+ my $self = shift;
+ $self->trace_open(title=>"select") if $TRACE;
+
+ my %param = @_;
+ die "select() - parameter 'freq' is deprecated" if exists $param{freq};
+
+ my $res;
+ my $count;
+ my @by;
+ @by = @{ $param{by} } if exists $param{by};
+ $count = delete $param{count} || $inf;
+ # warn "select: count=$count by=[@by]";
+
+ if ($count <= 0) {
+ $self->trace_close( arg => $res ) if $TRACE;
+ return $self->empty_set();
+ }
+
+ my @set;
+ my $tail;
+ my $first;
+ my $last;
+ if ( @by )
+ {
+ my @res;
+ if ( ! $self->is_too_complex )
+ {
+ $res = $self->new;
+ @res = @{ $self->{list} }[ @by ] ;
+ }
+ else
+ {
+ my ( @pos_by, @neg_by );
+ for ( @by ) {
+ ( $_ < 0 ) ? push @neg_by, $_ :
+ push @pos_by, $_;
+ }
+ my @first;
+ if ( @pos_by ) {
+ @pos_by = sort { $a <=> $b } @pos_by;
+ ( $tail, @set ) = $self->_first_n( 1 + $pos_by[-1] );
+ @first = @set[ @pos_by ];
+ }
+ my @last;
+ if ( @neg_by ) {
+ @neg_by = sort { $a <=> $b } @neg_by;
+ ( $tail, @set ) = $self->_last_n( - $neg_by[0] );
+ @last = @set[ @neg_by ];
+ }
+ @res = map { $_->{list}[0] } ( @first , @last );
+ }
+
+ $res = $self->new;
+ @res = sort { $a->{a} <=> $b->{a} } grep { defined } @res;
+ my $last;
+ my @a;
+ for ( @res ) {
+ push @a, $_ if ! $last || $last->{a} != $_->{a};
+ $last = $_;
+ }
+ $res->{list} = \@a;
+ }
+ else
+ {
+ $res = $self;
+ }
+
+ return $res if $count == $inf;
+ my $count_set = $self->empty_set();
+ if ( ! $self->is_too_complex )
+ {
+ my @a;
+ @a = grep { defined } @{ $res->{list} }[ 0 .. $count - 1 ] ;
+ $count_set->{list} = \@a;
+ }
+ else
+ {
+ my $last;
+ while ( $res ) {
+ ( $first, $res ) = $res->first;
+ last unless $first;
+ last if $last && $last->{a} == $first->{list}[0]{a};
+ $last = $first->{list}[0];
+ push @{$count_set->{list}}, $first->{list}[0];
+ $count--;
+ last if $count <= 0;
+ }
+ }
+ return $count_set;
+}
+
+BEGIN {
+
+ # %_first and %_last hashes are used to backtrack the value
+ # of first() and last() of an infinite set
+
+ %_first = (
+ 'complement' =>
+ sub {
+ my $self = $_[0];
+ my @parent_min = $self->{parent}->first;
+ unless ( defined $parent_min[0] ) {
+ return (undef, 0);
+ }
+ my $parent_complement;
+ my $first;
+ my @next;
+ my $parent;
+ if ( $parent_min[0]->min == $neg_inf ) {
+ my @parent_second = $parent_min[1]->first;
+ # (-inf..min) (second..?)
+ # (min..second) = complement
+ $first = $self->new( $parent_min[0]->complement );
+ $first->{list}[0]{b} = $parent_second[0]->{list}[0]{a};
+ $first->{list}[0]{open_end} = ! $parent_second[0]->{list}[0]{open_begin};
+ @{ $first->{list} } = () if
+ ( $first->{list}[0]{a} == $first->{list}[0]{b}) &&
+ ( $first->{list}[0]{open_begin} ||
+ $first->{list}[0]{open_end} );
+ @next = $parent_second[0]->max_a;
+ $parent = $parent_second[1];
+ }
+ else {
+ # (min..?)
+ # (-inf..min) = complement
+ $parent_complement = $parent_min[0]->complement;
+ $first = $self->new( $parent_complement->{list}[0] );
+ @next = $parent_min[0]->max_a;
+ $parent = $parent_min[1];
+ }
+ my @no_tail = $self->new($neg_inf,$next[0]);
+ $no_tail[0]->{list}[0]{open_end} = $next[1];
+ my $tail = $parent->union($no_tail[0])->complement;
+ return ($first, $tail);
+ }, # end: first-complement
+ 'intersection' =>
+ sub {
+ my $self = $_[0];
+ my @parent = @{ $self->{parent} };
+ # warn "$method parents @parent";
+ my $retry_count = 0;
+ my (@first, @min, $which, $first1, $intersection);
+ SEARCH: while ($retry_count++ < $max_intersection_depth) {
+ return undef unless defined $parent[0];
+ return undef unless defined $parent[1];
+ @{$first[0]} = $parent[0]->first;
+ @{$first[1]} = $parent[1]->first;
+ unless ( defined $first[0][0] ) {
+ # warn "don't know first of $method";
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ unless ( defined $first[1][0] ) {
+ # warn "don't know first of $method";
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ @{$min[0]} = $first[0][0]->min_a;
+ @{$min[1]} = $first[1][0]->min_a;
+ unless ( defined $min[0][0] && defined $min[1][0] ) {
+ return undef;
+ }
+ # $which is the index to the bigger "first".
+ $which = ($min[0][0] < $min[1][0]) ? 1 : 0;
+ for my $which1 ( $which, 1 - $which ) {
+ my $tmp_parent = $parent[$which1];
+ ($first1, $parent[$which1]) = @{ $first[$which1] };
+ if ( $first1->is_empty ) {
+ # warn "first1 empty! count $retry_count";
+ # trace_close;
+ # return $first1, undef;
+ $intersection = $first1;
+ $which = $which1;
+ last SEARCH;
+ }
+ $intersection = $first1->intersection( $parent[1-$which1] );
+ # warn "intersection with $first1 is $intersection";
+ unless ( $intersection->is_null ) {
+ # $self->trace( title=>"got an intersection" );
+ if ( $intersection->is_too_complex ) {
+ $parent[$which1] = $tmp_parent;
+ }
+ else {
+ $which = $which1;
+ last SEARCH;
+ }
+ };
+ }
+ }
+ if ( $#{ $intersection->{list} } > 0 ) {
+ my $tail;
+ ($intersection, $tail) = $intersection->first;
+ $parent[$which] = $parent[$which]->union( $tail );
+ }
+ my $tmp;
+ if ( defined $parent[$which] and defined $parent[1-$which] ) {
+ $tmp = $parent[$which]->intersection ( $parent[1-$which] );
+ }
+ return ($intersection, $tmp);
+ }, # end: first-intersection
+ 'union' =>
+ sub {
+ my $self = $_[0];
+ my (@first, @min);
+ my @parent = @{ $self->{parent} };
+ @{$first[0]} = $parent[0]->first;
+ @{$first[1]} = $parent[1]->first;
+ unless ( defined $first[0][0] ) {
+ # looks like one set was empty
+ return @{$first[1]};
+ }
+ @{$min[0]} = $first[0][0]->min_a;
+ @{$min[1]} = $first[1][0]->min_a;
+
+ # check min1/min2 for undef
+ unless ( defined $min[0][0] ) {
+ $self->trace_close( arg => "@{$first[1]}" ) if $TRACE;
+ return @{$first[1]}
+ }
+ unless ( defined $min[1][0] ) {
+ $self->trace_close( arg => "@{$first[0]}" ) if $TRACE;
+ return @{$first[0]}
+ }
+
+ my $which = ($min[0][0] < $min[1][0]) ? 0 : 1;
+ my $first = $first[$which][0];
+
+ # find out the tail
+ my $parent1 = $first[$which][1];
+ # warn $self->{parent}[$which]." - $first = $parent1";
+ my $parent2 = ($min[0][0] == $min[1][0]) ?
+ $self->{parent}[1-$which]->complement($first) :
+ $self->{parent}[1-$which];
+ my $tail;
+ if (( ! defined $parent1 ) || $parent1->is_null) {
+ # warn "union parent1 tail is null";
+ $tail = $parent2;
+ }
+ else {
+ my $method = $self->{method};
+ $tail = $parent1->$method( $parent2 );
+ }
+
+ if ( $first->intersects( $tail ) ) {
+ my $first2;
+ ( $first2, $tail ) = $tail->first;
+ $first = $first->union( $first2 );
+ }
+
+ $self->trace_close( arg => "$first $tail" ) if $TRACE;
+ return ($first, $tail);
+ }, # end: first-union
+ 'iterate' =>
+ sub {
+ my $self = $_[0];
+ my $parent = $self->{parent};
+ my ($first, $tail) = $parent->first;
+ $first = $first->iterate( @{$self->{param}} ) if ref($first);
+ $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
+ my $more;
+ ($first, $more) = $first->first if ref($first);
+ $tail = $tail->_function2( 'union', $more ) if defined $more;
+ return ($first, $tail);
+ },
+ 'until' =>
+ sub {
+ my $self = $_[0];
+ my ($a1, $b1) = @{ $self->{parent} };
+ $a1->trace( title=>"computing first()" );
+ my @first1 = $a1->first;
+ my @first2 = $b1->first;
+ my ($first, $tail);
+ if ( $first2[0] <= $first1[0] ) {
+ # added ->first because it returns 2 spans if $a1 == $a2
+ $first = $a1->empty_set()->until( $first2[0] )->first;
+ $tail = $a1->_function2( "until", $first2[1] );
+ }
+ else {
+ $first = $a1->new( $first1[0] )->until( $first2[0] );
+ if ( defined $first1[1] ) {
+ $tail = $first1[1]->_function2( "until", $first2[1] );
+ }
+ else {
+ $tail = undef;
+ }
+ }
+ return ($first, $tail);
+ },
+ 'offset' =>
+ sub {
+ my $self = $_[0];
+ my ($first, $tail) = $self->{parent}->first;
+ $first = $first->offset( @{$self->{param}} );
+ $tail = $tail->_function( 'offset', @{$self->{param}} );
+ my $more;
+ ($first, $more) = $first->first;
+ $tail = $tail->_function2( 'union', $more ) if defined $more;
+ return ($first, $tail);
+ },
+ 'quantize' =>
+ sub {
+ my $self = $_[0];
+ my @min = $self->{parent}->min_a;
+ if ( $min[0] == $neg_inf || $min[0] == $inf ) {
+ return ( $self->new( $min[0] ) , $self->copy );
+ }
+ my $first = $self->new( $min[0] )->quantize( @{$self->{param}} );
+ return ( $first,
+ $self->{parent}->
+ _function2( 'intersection', $first->complement )->
+ _function( 'quantize', @{$self->{param}} ) );
+ },
+ 'tolerance' =>
+ sub {
+ my $self = $_[0];
+ my ($first, $tail) = $self->{parent}->first;
+ $first = $first->tolerance( @{$self->{param}} );
+ $tail = $tail->tolerance( @{$self->{param}} );
+ return ($first, $tail);
+ },
+ ); # %_first
+
+ %_last = (
+ 'complement' =>
+ sub {
+ my $self = $_[0];
+ my @parent_max = $self->{parent}->last;
+ unless ( defined $parent_max[0] ) {
+ return (undef, 0);
+ }
+ my $parent_complement;
+ my $last;
+ my @next;
+ my $parent;
+ if ( $parent_max[0]->max == $inf ) {
+ # (inf..min) (second..?) = parent
+ # (min..second) = complement
+ my @parent_second = $parent_max[1]->last;
+ $last = $self->new( $parent_max[0]->complement );
+ $last->{list}[0]{a} = $parent_second[0]->{list}[0]{b};
+ $last->{list}[0]{open_begin} = ! $parent_second[0]->{list}[0]{open_end};
+ @{ $last->{list} } = () if
+ ( $last->{list}[0]{a} == $last->{list}[0]{b}) &&
+ ( $last->{list}[0]{open_end} ||
+ $last->{list}[0]{open_begin} );
+ @next = $parent_second[0]->min_a;
+ $parent = $parent_second[1];
+ }
+ else {
+ # (min..?)
+ # (-inf..min) = complement
+ $parent_complement = $parent_max[0]->complement;
+ $last = $self->new( $parent_complement->{list}[-1] );
+ @next = $parent_max[0]->min_a;
+ $parent = $parent_max[1];
+ }
+ my @no_tail = $self->new($next[0], $inf);
+ $no_tail[0]->{list}[-1]{open_begin} = $next[1];
+ my $tail = $parent->union($no_tail[-1])->complement;
+ return ($last, $tail);
+ },
+ 'intersection' =>
+ sub {
+ my $self = $_[0];
+ my @parent = @{ $self->{parent} };
+ # TODO: check max1/max2 for undef
+
+ my $retry_count = 0;
+ my (@last, @max, $which, $last1, $intersection);
+
+ SEARCH: while ($retry_count++ < $max_intersection_depth) {
+ return undef unless defined $parent[0];
+ return undef unless defined $parent[1];
+
+ @{$last[0]} = $parent[0]->last;
+ @{$last[1]} = $parent[1]->last;
+ unless ( defined $last[0][0] ) {
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ unless ( defined $last[1][0] ) {
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ @{$max[0]} = $last[0][0]->max_a;
+ @{$max[1]} = $last[1][0]->max_a;
+ unless ( defined $max[0][0] && defined $max[1][0] ) {
+ $self->trace( title=>"can't find max()" ) if $TRACE;
+ $self->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+
+ # $which is the index to the smaller "last".
+ $which = ($max[0][0] > $max[1][0]) ? 1 : 0;
+
+ for my $which1 ( $which, 1 - $which ) {
+ my $tmp_parent = $parent[$which1];
+ ($last1, $parent[$which1]) = @{ $last[$which1] };
+ if ( $last1->is_null ) {
+ $which = $which1;
+ $intersection = $last1;
+ last SEARCH;
+ }
+ $intersection = $last1->intersection( $parent[1-$which1] );
+
+ unless ( $intersection->is_null ) {
+ # $self->trace( title=>"got an intersection" );
+ if ( $intersection->is_too_complex ) {
+ $self->trace( title=>"got a too_complex intersection" ) if $TRACE;
+ # warn "too complex intersection";
+ $parent[$which1] = $tmp_parent;
+ }
+ else {
+ $self->trace( title=>"got an intersection" ) if $TRACE;
+ $which = $which1;
+ last SEARCH;
+ }
+ };
+ }
+ }
+ $self->trace( title=>"exit loop" ) if $TRACE;
+ if ( $#{ $intersection->{list} } > 0 ) {
+ my $tail;
+ ($intersection, $tail) = $intersection->last;
+ $parent[$which] = $parent[$which]->union( $tail );
+ }
+ my $tmp;
+ if ( defined $parent[$which] and defined $parent[1-$which] ) {
+ $tmp = $parent[$which]->intersection ( $parent[1-$which] );
+ }
+ return ($intersection, $tmp);
+ },
+ 'union' =>
+ sub {
+ my $self = $_[0];
+ my (@last, @max);
+ my @parent = @{ $self->{parent} };
+ @{$last[0]} = $parent[0]->last;
+ @{$last[1]} = $parent[1]->last;
+ @{$max[0]} = $last[0][0]->max_a;
+ @{$max[1]} = $last[1][0]->max_a;
+ unless ( defined $max[0][0] ) {
+ return @{$last[1]}
+ }
+ unless ( defined $max[1][0] ) {
+ return @{$last[0]}
+ }
+
+ my $which = ($max[0][0] > $max[1][0]) ? 0 : 1;
+ my $last = $last[$which][0];
+ # find out the tail
+ my $parent1 = $last[$which][1];
+ # warn $self->{parent}[$which]." - $last = $parent1";
+ my $parent2 = ($max[0][0] == $max[1][0]) ?
+ $self->{parent}[1-$which]->complement($last) :
+ $self->{parent}[1-$which];
+ my $tail;
+ if (( ! defined $parent1 ) || $parent1->is_null) {
+ $tail = $parent2;
+ }
+ else {
+ my $method = $self->{method};
+ $tail = $parent1->$method( $parent2 );
+ }
+
+ if ( $last->intersects( $tail ) ) {
+ my $last2;
+ ( $last2, $tail ) = $tail->last;
+ $last = $last->union( $last2 );
+ }
+
+ return ($last, $tail);
+ },
+ 'until' =>
+ sub {
+ my $self = $_[0];
+ my ($a1, $b1) = @{ $self->{parent} };
+ $a1->trace( title=>"computing last()" );
+ my @last1 = $a1->last;
+ my @last2 = $b1->last;
+ my ($last, $tail);
+ if ( $last2[0] <= $last1[0] ) {
+ # added ->last because it returns 2 spans if $a1 == $a2
+ $last = $last2[0]->until( $a1 )->last;
+ $tail = $a1->_function2( "until", $last2[1] );
+ }
+ else {
+ $last = $a1->new( $last1[0] )->until( $last2[0] );
+ if ( defined $last1[1] ) {
+ $tail = $last1[1]->_function2( "until", $last2[1] );
+ }
+ else {
+ $tail = undef;
+ }
+ }
+ return ($last, $tail);
+ },
+ 'iterate' =>
+ sub {
+ my $self = $_[0];
+ my $parent = $self->{parent};
+ my ($last, $tail) = $parent->last;
+ $last = $last->iterate( @{$self->{param}} ) if ref($last);
+ $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
+ my $more;
+ ($last, $more) = $last->last if ref($last);
+ $tail = $tail->_function2( 'union', $more ) if defined $more;
+ return ($last, $tail);
+ },
+ 'offset' =>
+ sub {
+ my $self = $_[0];
+ my ($last, $tail) = $self->{parent}->last;
+ $last = $last->offset( @{$self->{param}} );
+ $tail = $tail->_function( 'offset', @{$self->{param}} );
+ my $more;
+ ($last, $more) = $last->last;
+ $tail = $tail->_function2( 'union', $more ) if defined $more;
+ return ($last, $tail);
+ },
+ 'quantize' =>
+ sub {
+ my $self = $_[0];
+ my @max = $self->{parent}->max_a;
+ if (( $max[0] == $neg_inf ) || ( $max[0] == $inf )) {
+ return ( $self->new( $max[0] ) , $self->copy );
+ }
+ my $last = $self->new( $max[0] )->quantize( @{$self->{param}} );
+ if ($max[1]) { # open_end
+ if ( $last->min <= $max[0] ) {
+ $last = $self->new( $last->min - 1e-9 )->quantize( @{$self->{param}} );
+ }
+ }
+ return ( $last, $self->{parent}->
+ _function2( 'intersection', $last->complement )->
+ _function( 'quantize', @{$self->{param}} ) );
+ },
+ 'tolerance' =>
+ sub {
+ my $self = $_[0];
+ my ($last, $tail) = $self->{parent}->last;
+ $last = $last->tolerance( @{$self->{param}} );
+ $tail = $tail->tolerance( @{$self->{param}} );
+ return ($last, $tail);
+ },
+ ); # %_last
+} # BEGIN
+
+sub first {
+ my $self = $_[0];
+ unless ( exists $self->{first} ) {
+ $self->trace_open(title=>"first") if $TRACE;
+ if ( $self->{too_complex} ) {
+ my $method = $self->{method};
+ # warn "method $method ". ( exists $_first{$method} ? "exists" : "does not exist" );
+ if ( exists $_first{$method} ) {
+ @{$self->{first}} = $_first{$method}->($self);
+ }
+ else {
+ my $redo = $self->{parent}->$method ( @{ $self->{param} } );
+ @{$self->{first}} = $redo->first;
+ }
+ }
+ else {
+ return $self->SUPER::first;
+ }
+ }
+ return wantarray ? @{$self->{first}} : $self->{first}[0];
+}
+
+
+sub last {
+ my $self = $_[0];
+ unless ( exists $self->{last} ) {
+ $self->trace(title=>"last") if $TRACE;
+ if ( $self->{too_complex} ) {
+ my $method = $self->{method};
+ if ( exists $_last{$method} ) {
+ @{$self->{last}} = $_last{$method}->($self);
+ }
+ else {
+ my $redo = $self->{parent}->$method ( @{ $self->{param} } );
+ @{$self->{last}} = $redo->last;
+ }
+ }
+ else {
+ return $self->SUPER::last;
+ }
+ }
+ return wantarray ? @{$self->{last}} : $self->{last}[0];
+}
+
+
+# offset: offsets subsets
+sub offset {
+ my $self = shift;
+ if ($self->{too_complex}) {
+ return $self->_function( 'offset', @_ );
+ }
+ $self->trace_open(title=>"offset") if $TRACE;
+
+ my @a;
+ my %param = @_;
+ my $b1 = $self->empty_set();
+ my ($interval, $ia, $i);
+ $param{mode} = 'offset' unless $param{mode};
+
+ unless (ref($param{value}) eq 'ARRAY') {
+ $param{value} = [0 + $param{value}, 0 + $param{value}];
+ }
+ $param{unit} = 'one' unless $param{unit};
+ my $parts = ($#{$param{value}}) / 2;
+ my $sub_unit = $Set::Infinite::Arithmetic::subs_offset2{$param{unit}};
+ my $sub_mode = $Set::Infinite::Arithmetic::_MODE{$param{mode}};
+
+ carp "unknown unit $param{unit} for offset()" unless defined $sub_unit;
+ carp "unknown mode $param{mode} for offset()" unless defined $sub_mode;
+
+ my ($j);
+ my ($cmp, $this, $next, $ib, $part, $open_begin, $open_end, $tmp);
+
+ my @value;
+ foreach $j (0 .. $parts) {
+ push @value, [ $param{value}[$j+$j], $param{value}[$j+$j + 1] ];
+ }
+
+ foreach $interval ( @{ $self->{list} } ) {
+ $ia = $interval->{a};
+ $ib = $interval->{b};
+ $open_begin = $interval->{open_begin};
+ $open_end = $interval->{open_end};
+ foreach $j (0 .. $parts) {
+ # print " [ofs($ia,$ib)] ";
+ ($this, $next) = $sub_mode->( $sub_unit, $ia, $ib, @{$value[$j]} );
+ next if ($this > $next); # skip if a > b
+ if ($this == $next) {
+ # TODO: fix this
+ $open_end = $open_begin;
+ }
+ push @a, { a => $this , b => $next ,
+ open_begin => $open_begin , open_end => $open_end };
+ } # parts
+ } # self
+ @a = sort { $a->{a} <=> $b->{a} } @a;
+ $b1->{list} = \@a; # change data
+ $self->trace_close( arg => $b1 ) if $TRACE;
+ $b1 = $b1->fixtype if $self->{fixtype};
+ return $b1;
+}
+
+
+sub is_null {
+ $_[0]->{too_complex} ? 0 : $_[0]->SUPER::is_null;
+}
+
+
+sub is_too_complex {
+ $_[0]->{too_complex} ? 1 : 0;
+}
+
+
+# shows how a 'compacted' set looks like after quantize
+sub _quantize_span {
+ my $self = shift;
+ my %param = @_;
+ $self->trace_open(title=>"_quantize_span") if $TRACE;
+ my $res;
+ if ($self->{too_complex}) {
+ $res = $self->{parent};
+ if ($self->{method} ne 'quantize') {
+ $self->trace( title => "parent is a ". $self->{method} );
+ if ( $self->{method} eq 'union' ) {
+ my $arg0 = $self->{parent}[0]->_quantize_span(%param);
+ my $arg1 = $self->{parent}[1]->_quantize_span(%param);
+ $res = $arg0->union( $arg1 );
+ }
+ elsif ( $self->{method} eq 'intersection' ) {
+ my $arg0 = $self->{parent}[0]->_quantize_span(%param);
+ my $arg1 = $self->{parent}[1]->_quantize_span(%param);
+ $res = $arg0->intersection( $arg1 );
+ }
+
+ # TODO: other methods
+ else {
+ $res = $self; # ->_function( "_quantize_span", %param );
+ }
+ $self->trace_close( arg => $res ) if $TRACE;
+ return $res;
+ }
+
+ # $res = $self->{parent};
+ if ($res->{too_complex}) {
+ $res->trace( title => "parent is complex" );
+ $res = $res->_quantize_span( %param );
+ $res = $res->quantize( @{$self->{param}} )->_quantize_span( %param );
+ }
+ else {
+ $res = $res->iterate (
+ sub {
+ $_[0]->quantize( @{$self->{param}} )->span;
+ }
+ );
+ }
+ }
+ else {
+ $res = $self->iterate ( sub { $_[0] } );
+ }
+ $self->trace_close( arg => $res ) if $TRACE;
+ return $res;
+}
+
+
+
+BEGIN {
+
+ %_backtrack = (
+
+ until => sub {
+ my ($self, $arg) = @_;
+ my $before = $self->{parent}[0]->intersection( $neg_inf, $arg->min )->max;
+ $before = $arg->min unless $before;
+ my $after = $self->{parent}[1]->intersection( $arg->max, $inf )->min;
+ $after = $arg->max unless $after;
+ return $arg->new( $before, $after );
+ },
+
+ iterate => sub {
+ my ($self, $arg) = @_;
+
+ if ( defined $self->{backtrack_callback} )
+ {
+ return $arg = $self->new( $self->{backtrack_callback}->( $arg ) );
+ }
+
+ my $before = $self->{parent}->intersection( $neg_inf, $arg->min )->max;
+ $before = $arg->min unless $before;
+ my $after = $self->{parent}->intersection( $arg->max, $inf )->min;
+ $after = $arg->max unless $after;
+
+ return $arg->new( $before, $after );
+ },
+
+ quantize => sub {
+ my ($self, $arg) = @_;
+ if ($arg->{too_complex}) {
+ return $arg;
+ }
+ else {
+ return $arg->quantize( @{$self->{param}} )->_quantize_span;
+ }
+ },
+
+ offset => sub {
+ my ($self, $arg) = @_;
+ # offset - apply offset with negative values
+ my %tmp = @{$self->{param}};
+ my @values = sort @{$tmp{value}};
+
+ my $backtrack_arg2 = $arg->offset(
+ unit => $tmp{unit},
+ mode => $tmp{mode},
+ value => [ - $values[-1], - $values[0] ] );
+ return $arg->union( $backtrack_arg2 ); # fixes some problems with 'begin' mode
+ },
+
+ );
+}
+
+
+sub _backtrack {
+ my ($self, $method, $arg) = @_;
+ return $self->$method ($arg) unless $self->{too_complex};
+
+ $self->trace_open( title => 'backtrack '.$self->{method} ) if $TRACE;
+
+ $backtrack_depth++;
+ if ( $backtrack_depth > $max_backtrack_depth ) {
+ carp ( __PACKAGE__ . ": Backtrack too deep " .
+ "(more than $max_backtrack_depth levels)" );
+ }
+
+ if (exists $_backtrack{ $self->{method} } ) {
+ $arg = $_backtrack{ $self->{method} }->( $self, $arg );
+ }
+
+ my $result;
+ if ( ref($self->{parent}) eq 'ARRAY' ) {
+ # has 2 parents (intersection, union, until)
+
+ my ( $result1, $result2 ) = @{$self->{parent}};
+ $result1 = $result1->_backtrack( $method, $arg )
+ if $result1->{too_complex};
+ $result2 = $result2->_backtrack( $method, $arg )
+ if $result2->{too_complex};
+
+ $method = $self->{method};
+ if ( $result1->{too_complex} || $result2->{too_complex} ) {
+ $result = $result1->_function2( $method, $result2 );
+ }
+ else {
+ $result = $result1->$method ($result2);
+ }
+ }
+ else {
+ # has 1 parent and parameters (offset, select, quantize, iterate)
+
+ $result = $self->{parent}->_backtrack( $method, $arg );
+ $method = $self->{method};
+ $result = $result->$method ( @{$self->{param}} );
+ }
+
+ $backtrack_depth--;
+ $self->trace_close( arg => $result ) if $TRACE;
+ return $result;
+}
+
+
+sub intersects {
+ my $a1 = shift;
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ $a1->trace(title=>"intersects");
+ if ($a1->{too_complex}) {
+ $a1 = $a1->_backtrack('intersection', $b1 );
+ } # don't put 'else' here
+ if ($b1->{too_complex}) {
+ $b1 = $b1->_backtrack('intersection', $a1);
+ }
+ if (($a1->{too_complex}) or ($b1->{too_complex})) {
+ return undef; # we don't know the answer!
+ }
+ return $a1->SUPER::intersects( $b1 );
+}
+
+
+sub iterate {
+ my $self = shift;
+ my $callback = shift;
+ die "First argument to iterate() must be a subroutine reference"
+ unless ref( $callback ) eq 'CODE';
+ my $backtrack_callback;
+ if ( @_ && $_[0] eq 'backtrack_callback' )
+ {
+ ( undef, $backtrack_callback ) = ( shift, shift );
+ }
+ my $set;
+ if ($self->{too_complex}) {
+ $self->trace(title=>"iterate:backtrack") if $TRACE;
+ $set = $self->_function( 'iterate', $callback, @_ );
+ }
+ else
+ {
+ $self->trace(title=>"iterate") if $TRACE;
+ $set = $self->SUPER::iterate( $callback, @_ );
+ }
+ $set->{backtrack_callback} = $backtrack_callback;
+ # warn "set backtrack_callback" if defined $backtrack_callback;
+ return $set;
+}
+
+
+sub intersection {
+ my $a1 = shift;
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ $a1->trace_open(title=>"intersection", arg => $b1) if $TRACE;
+ if (($a1->{too_complex}) or ($b1->{too_complex})) {
+ my $arg0 = $a1->_quantize_span;
+ my $arg1 = $b1->_quantize_span;
+ unless (($arg0->{too_complex}) or ($arg1->{too_complex})) {
+ my $res = $arg0->intersection( $arg1 );
+ $a1->trace_close( arg => $res ) if $TRACE;
+ return $res;
+ }
+ }
+ if ($a1->{too_complex}) {
+ $a1 = $a1->_backtrack('intersection', $b1) unless $b1->{too_complex};
+ } # don't put 'else' here
+ if ($b1->{too_complex}) {
+ $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
+ }
+ if ( $a1->{too_complex} || $b1->{too_complex} ) {
+ $a1->trace_close( ) if $TRACE;
+ return $a1->_function2( 'intersection', $b1 );
+ }
+ return $a1->SUPER::intersection( $b1 );
+}
+
+
+sub intersected_spans {
+ my $a1 = shift;
+ my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
+
+ if ($a1->{too_complex}) {
+ $a1 = $a1->_backtrack('intersection', $b1 ) unless $b1->{too_complex};
+ } # don't put 'else' here
+ if ($b1->{too_complex}) {
+ $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
+ }
+
+ if ( ! $b1->{too_complex} && ! $a1->{too_complex} )
+ {
+ return $a1->SUPER::intersected_spans ( $b1 );
+ }
+
+ return $b1->iterate(
+ sub {
+ my $tmp = $a1->intersection( $_[0] );
+ return $tmp unless defined $tmp->max;
+
+ my $before = $a1->intersection( $neg_inf, $tmp->min )->last;
+ my $after = $a1->intersection( $tmp->max, $inf )->first;
+
+ $before = $tmp->union( $before )->first;
+ $after = $tmp->union( $after )->last;
+
+ $tmp = $tmp->union( $before )
+ if defined $before && $tmp->intersects( $before );
+ $tmp = $tmp->union( $after )
+ if defined $after && $tmp->intersects( $after );
+ return $tmp;
+ }
+ );
+
+}
+
+
+sub complement {
+ my $a1 = shift;
+ # do we have a parameter?
+ if (@_) {
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ $a1->trace_open(title=>"complement", arg => $b1) if $TRACE;
+ $b1 = $b1->complement;
+ my $tmp =$a1->intersection($b1);
+ $a1->trace_close( arg => $tmp ) if $TRACE;
+ return $tmp;
+ }
+ $a1->trace_open(title=>"complement") if $TRACE;
+ if ($a1->{too_complex}) {
+ $a1->trace_close( ) if $TRACE;
+ return $a1->_function( 'complement', @_ );
+ }
+ return $a1->SUPER::complement;
+}
+
+
+sub until {
+ my $a1 = shift;
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ if (($a1->{too_complex}) or ($b1->{too_complex})) {
+ return $a1->_function2( 'until', $b1 );
+ }
+ return $a1->SUPER::until( $b1 );
+}
+
+
+sub union {
+ my $a1 = shift;
+ my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
+
+ $a1->trace_open(title=>"union", arg => $b1) if $TRACE;
+ if (($a1->{too_complex}) or ($b1->{too_complex})) {
+ $a1->trace_close( ) if $TRACE;
+ return $a1 if $b1->is_null;
+ return $b1 if $a1->is_null;
+ return $a1->_function2( 'union', $b1);
+ }
+ return $a1->SUPER::union( $b1 );
+}
+
+
+# there are some ways to process 'contains':
+# A CONTAINS B IF A == ( A UNION B )
+# - faster
+# A CONTAINS B IF B == ( A INTERSECTION B )
+# - can backtrack = works for unbounded sets
+sub contains {
+ my $a1 = shift;
+ $a1->trace_open(title=>"contains") if $TRACE;
+ if ( $a1->{too_complex} ) {
+ # we use intersection because it is better for backtracking
+ my $b0 = (ref $_[0] eq ref $a1) ? shift : $a1->new(@_);
+ my $b1 = $a1->intersection($b0);
+ if ( $b1->{too_complex} ) {
+ $b1->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ $a1->trace_close( arg => ($b1 == $b0 ? 1 : 0) ) if $TRACE;
+ return ($b1 == $b0) ? 1 : 0;
+ }
+ my $b1 = $a1->union(@_);
+ if ( $b1->{too_complex} ) {
+ $b1->trace_close( arg => 'undef' ) if $TRACE;
+ return undef;
+ }
+ $a1->trace_close( arg => ($b1 == $a1 ? 1 : 0) ) if $TRACE;
+ return ($b1 == $a1) ? 1 : 0;
+}
+
+
+sub min_a {
+ my $self = $_[0];
+ return @{$self->{min}} if exists $self->{min};
+ if ($self->{too_complex}) {
+ my @first = $self->first;
+ return @{$self->{min}} = $first[0]->min_a if defined $first[0];
+ return @{$self->{min}} = (undef, 0);
+ }
+ return $self->SUPER::min_a;
+};
+
+
+sub max_a {
+ my $self = $_[0];
+ return @{$self->{max}} if exists $self->{max};
+ if ($self->{too_complex}) {
+ my @last = $self->last;
+ return @{$self->{max}} = $last[0]->max_a if defined $last[0];
+ return @{$self->{max}} = (undef, 0);
+ }
+ return $self->SUPER::max_a;
+};
+
+
+sub count {
+ my $self = $_[0];
+ # NOTE: subclasses may return "undef" if necessary
+ return $inf if $self->{too_complex};
+ return $self->SUPER::count;
+}
+
+
+sub size {
+ my $self = $_[0];
+ if ($self->{too_complex}) {
+ my @min = $self->min_a;
+ my @max = $self->max_a;
+ return undef unless defined $max[0] && defined $min[0];
+ return $max[0] - $min[0];
+ }
+ return $self->SUPER::size;
+};
+
+
+sub spaceship {
+ my ($tmp1, $tmp2, $inverted) = @_;
+ carp "Can't compare unbounded sets"
+ if $tmp1->{too_complex} or $tmp2->{too_complex};
+ return $tmp1->SUPER::spaceship( $tmp2, $inverted );
+}
+
+
+sub _cleanup { @_ } # this subroutine is obsolete
+
+
+sub tolerance {
+ my $self = shift;
+ my $tmp = pop;
+ if (ref($self)) {
+ # local
+ return $self->{tolerance} unless defined $tmp;
+ if ($self->{too_complex}) {
+ my $b1 = $self->_function( 'tolerance', $tmp );
+ $b1->{tolerance} = $tmp; # for max/min processing
+ return $b1;
+ }
+ return $self->SUPER::tolerance( $tmp );
+ }
+ # class method
+ __PACKAGE__->SUPER::tolerance( $tmp ) if defined($tmp);
+ return __PACKAGE__->SUPER::tolerance;
+}
+
+
+sub _pretty_print {
+ my $self = shift;
+ return "$self" unless $self->{too_complex};
+ return $self->{method} . "( " .
+ ( ref($self->{parent}) eq 'ARRAY' ?
+ $self->{parent}[0] . ' ; ' . $self->{parent}[1] :
+ $self->{parent} ) .
+ " )";
+}
+
+
+sub as_string {
+ my $self = shift;
+ return ( $PRETTY_PRINT ? $self->_pretty_print : $too_complex )
+ if $self->{too_complex};
+ return $self->SUPER::as_string;
+}
+
+
+sub DESTROY {}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Set::Infinite - Sets of intervals
+
+
+=head1 SYNOPSIS
+
+ use Set::Infinite;
+
+ $set = Set::Infinite->new(1,2); # [1..2]
+ print $set->union(5,6); # [1..2],[5..6]
+
+
+=head1 DESCRIPTION
+
+Set::Infinite is a Set Theory module for infinite sets.
+
+A set is a collection of objects.
+The objects that belong to a set are called its members, or "elements".
+
+As objects we allow (almost) anything: reals, integers, and objects (such as dates).
+
+We allow sets to be infinite.
+
+There is no account for the order of elements. For example, {1,2} = {2,1}.
+
+There is no account for repetition of elements. For example, {1,2,2} = {1,1,1,2} = {1,2}.
+
+=head1 CONSTRUCTOR
+
+=head2 new
+
+Creates a new set object:
+
+ $set = Set::Infinite->new; # empty set
+ $set = Set::Infinite->new( 10 ); # single element
+ $set = Set::Infinite->new( 10, 20 ); # single range
+ $set = Set::Infinite->new(
+ [ 10, 20 ], [ 50, 70 ] ); # two ranges
+
+=over 4
+
+=item empty set
+
+ $set = Set::Infinite->new;
+
+=item set with a single element
+
+ $set = Set::Infinite->new( 10 );
+
+ $set = Set::Infinite->new( [ 10 ] );
+
+=item set with a single span
+
+ $set = Set::Infinite->new( 10, 20 );
+
+ $set = Set::Infinite->new( [ 10, 20 ] );
+ # 10 <= x <= 20
+
+=item set with a single, open span
+
+ $set = Set::Infinite->new(
+ {
+ a => 10, open_begin => 0,
+ b => 20, open_end => 1,
+ }
+ );
+ # 10 <= x < 20
+
+=item set with multiple spans
+
+ $set = Set::Infinite->new( 10, 20, 100, 200 );
+
+ $set = Set::Infinite->new( [ 10, 20 ], [ 100, 200 ] );
+
+ $set = Set::Infinite->new(
+ {
+ a => 10, open_begin => 0,
+ b => 20, open_end => 0,
+ },
+ {
+ a => 100, open_begin => 0,
+ b => 200, open_end => 0,
+ }
+ );
+
+=back
+
+The C<new()> method expects I<ordered> parameters.
+
+If you have unordered ranges, you can build the set using C<union>:
+
+ @ranges = ( [ 10, 20 ], [ -10, 1 ] );
+ $set = Set::Infinite->new;
+ $set = $set->union( @$_ ) for @ranges;
+
+The data structures passed to C<new> must be I<immutable>.
+So this is not good practice:
+
+ $set = Set::Infinite->new( $object_a, $object_b );
+ $object_a->set_value( 10 );
+
+This is the recommended way to do it:
+
+ $set = Set::Infinite->new( $object_a->clone, $object_b->clone );
+ $object_a->set_value( 10 );
+
+
+=head2 clone / copy
+
+Creates a new object, and copy the object data.
+
+=head2 empty_set
+
+Creates an empty set.
+
+If called from an existing set, the empty set inherits
+the "type" and "density" characteristics.
+
+=head2 universal_set
+
+Creates a set containing "all" possible elements.
+
+If called from an existing set, the universal set inherits
+the "type" and "density" characteristics.
+
+=head1 SET FUNCTIONS
+
+=head2 union
+
+ $set = $set->union($b);
+
+Returns the set of all elements from both sets.
+
+This function behaves like an "OR" operation.
+
+ $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
+ $set2 = new Set::Infinite( [ 7, 20 ] );
+ print $set1->union( $set2 );
+ # output: [1..4],[7..20]
+
+=head2 intersection
+
+ $set = $set->intersection($b);
+
+Returns the set of elements common to both sets.
+
+This function behaves like an "AND" operation.
+
+ $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
+ $set2 = new Set::Infinite( [ 7, 20 ] );
+ print $set1->intersection( $set2 );
+ # output: [8..12]
+
+=head2 complement
+
+=head2 minus
+
+=head2 difference
+
+ $set = $set->complement;
+
+Returns the set of all elements that don't belong to the set.
+
+ $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
+ print $set1->complement;
+ # output: (-inf..1),(4..8),(12..inf)
+
+The complement function might take a parameter:
+
+ $set = $set->minus($b);
+
+Returns the set-difference, that is, the elements that don't
+belong to the given set.
+
+ $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
+ $set2 = new Set::Infinite( [ 7, 20 ] );
+ print $set1->minus( $set2 );
+ # output: [1..4]
+
+=head2 symmetric_difference
+
+Returns a set containing elements that are in either set,
+but not in both. This is the "set" version of "XOR".
+
+=head1 DENSITY METHODS
+
+=head2 real
+
+ $set1 = $set->real;
+
+Returns a set with density "0".
+
+=head2 integer
+
+ $set1 = $set->integer;
+
+Returns a set with density "1".
+
+=head1 LOGIC FUNCTIONS
+
+=head2 intersects
+
+ $logic = $set->intersects($b);
+
+=head2 contains
+
+ $logic = $set->contains($b);
+
+=head2 is_empty
+
+=head2 is_null
+
+ $logic = $set->is_null;
+
+=head2 is_nonempty
+
+This set that has at least 1 element.
+
+=head2 is_span
+
+This set that has a single span or interval.
+
+=head2 is_singleton
+
+This set that has a single element.
+
+=head2 is_subset( $set )
+
+Every element of this set is a member of the given set.
+
+=head2 is_proper_subset( $set )
+
+Every element of this set is a member of the given set.
+Some members of the given set are not elements of this set.
+
+=head2 is_disjoint( $set )
+
+The given set has no elements in common with this set.
+
+=head2 is_too_complex
+
+Sometimes a set might be too complex to enumerate or print.
+
+This happens with sets that represent infinite recurrences, such as
+when you ask for a quantization on a
+set bounded by -inf or inf.
+
+See also: C<count> method.
+
+=head1 SCALAR FUNCTIONS
+
+=head2 min
+
+ $i = $set->min;
+
+=head2 max
+
+ $i = $set->max;
+
+=head2 size
+
+ $i = $set->size;
+
+=head2 count
+
+ $i = $set->count;
+
+=head1 OVERLOADED OPERATORS
+
+=head2 stringification
+
+ print $set;
+
+ $str = "$set";
+
+See also: C<as_string>.
+
+=head2 comparison
+
+ sort
+
+ > < == >= <= <=>
+
+See also: C<spaceship> method.
+
+=head1 CLASS METHODS
+
+ Set::Infinite->separators(@i)
+
+ chooses the interval separators for stringification.
+
+ default are [ ] ( ) '..' ','.
+
+ inf
+
+ returns an 'Infinity' number.
+
+ minus_inf
+
+ returns '-Infinity' number.
+
+=head2 type
+
+ type( "My::Class::Name" )
+
+Chooses a default object data type.
+
+Default is none (a normal Perl SCALAR).
+
+
+=head1 SPECIAL SET FUNCTIONS
+
+=head2 span
+
+ $set1 = $set->span;
+
+Returns the set span.
+
+=head2 until
+
+Extends a set until another:
+
+ 0,5,7 -> until 2,6,10
+
+gives
+
+ [0..2), [5..6), [7..10)
+
+=head2 start_set
+
+=head2 end_set
+
+These methods do the inverse of the "until" method.
+
+Given:
+
+ [0..2), [5..6), [7..10)
+
+start_set is:
+
+ 0,5,7
+
+end_set is:
+
+ 2,6,10
+
+=head2 intersected_spans
+
+ $set = $set1->intersected_spans( $set2 );
+
+The method returns a new set,
+containing all spans that are intersected by the given set.
+
+Unlike the C<intersection> method, the spans are not modified.
+See diagram below:
+
+ set1 [....] [....] [....] [....]
+ set2 [................]
+
+ intersection [.] [....] [.]
+
+ intersected_spans [....] [....] [....]
+
+
+=head2 quantize
+
+ quantize( parameters )
+
+ Makes equal-sized subsets.
+
+ Returns an ordered set of equal-sized subsets.
+
+ Example:
+
+ $set = Set::Infinite->new([1,3]);
+ print join (" ", $set->quantize( quant => 1 ) );
+
+ Gives:
+
+ [1..2) [2..3) [3..4)
+
+=head2 select
+
+ select( parameters )
+
+Selects set spans based on their ordered positions
+
+C<select> has a behaviour similar to an array C<slice>.
+
+ by - default=All
+ count - default=Infinity
+
+ 0 1 2 3 4 5 6 7 8 # original set
+ 0 1 2 # count => 3
+ 1 6 # by => [ -2, 1 ]
+
+=head2 offset
+
+ offset ( parameters )
+
+Offsets the subsets. Parameters:
+
+ value - default=[0,0]
+ mode - default='offset'. Possible values are: 'offset', 'begin', 'end'.
+ unit - type of value. Can be 'days', 'weeks', 'hours', 'minutes', 'seconds'.
+
+=head2 iterate
+
+ iterate ( sub { } , @args )
+
+Iterates on the set spans, over a callback subroutine.
+Returns the union of all partial results.
+
+The callback argument C<$_[0]> is a span. If there are additional arguments they are passed to the callback.
+
+The callback can return a span, a hashref (see C<Set::Infinite::Basic>), a scalar, an object, or C<undef>.
+
+[EXPERIMENTAL]
+C<iterate> accepts an optional C<backtrack_callback> argument.
+The purpose of the C<backtrack_callback> is to I<reverse> the
+iterate() function, overcoming the limitations of the internal
+backtracking algorithm.
+The syntax is:
+
+ iterate ( sub { } , backtrack_callback => sub { }, @args )
+
+The C<backtrack_callback> can return a span, a hashref, a scalar,
+an object, or C<undef>.
+
+For example, the following snippet adds a constant to each
+element of an unbounded set:
+
+ $set1 = $set->iterate(
+ sub { $_[0]->min + 54, $_[0]->max + 54 },
+ backtrack_callback =>
+ sub { $_[0]->min - 54, $_[0]->max - 54 },
+ );
+
+=head2 first / last
+
+ first / last
+
+In scalar context returns the first or last interval of a set.
+
+In list context returns the first or last interval of a set,
+and the remaining set (the 'tail').
+
+See also: C<min>, C<max>, C<min_a>, C<max_a> methods.
+
+=head2 type
+
+ type( "My::Class::Name" )
+
+Chooses a default object data type.
+
+default is none (a normal perl SCALAR).
+
+
+=head1 INTERNAL FUNCTIONS
+
+=head2 _backtrack
+
+ $set->_backtrack( 'intersection', $b );
+
+Internal function to evaluate recurrences.
+
+=head2 numeric
+
+ $set->numeric;
+
+Internal function to ignore the set "type".
+It is used in some internal optimizations, when it is
+possible to use scalar values instead of objects.
+
+=head2 fixtype
+
+ $set->fixtype;
+
+Internal function to fix the result of operations
+that use the numeric() function.
+
+=head2 tolerance
+
+ $set = $set->tolerance(0) # defaults to real sets (default)
+ $set = $set->tolerance(1) # defaults to integer sets
+
+Internal function for changing the set "density".
+
+=head2 min_a
+
+ ($min, $min_is_open) = $set->min_a;
+
+=head2 max_a
+
+ ($max, $max_is_open) = $set->max_a;
+
+
+=head2 as_string
+
+Implements the "stringification" operator.
+
+Stringification of unbounded recurrences is not implemented.
+
+Unbounded recurrences are stringified as "function descriptions",
+if the class variable $PRETTY_PRINT is set.
+
+=head2 spaceship
+
+Implements the "comparison" operator.
+
+Comparison of unbounded recurrences is not implemented.
+
+
+=head1 CAVEATS
+
+=over 4
+
+=item * constructor "span" notation
+
+ $set = Set::Infinite->new(10,1);
+
+Will be interpreted as [1..10]
+
+=item * constructor "multiple-span" notation
+
+ $set = Set::Infinite->new(1,2,3,4);
+
+Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
+You probably want ->new([1],[2],[3],[4]) instead,
+or maybe ->new(1,4)
+
+=item * "range operator"
+
+ $set = Set::Infinite->new(1..3);
+
+Will be interpreted as [1..2],3 instead of [1,2,3].
+You probably want ->new(1,3) instead.
+
+=back
+
+=head1 INTERNALS
+
+The base I<set> object, without recurrences, is a C<Set::Infinite::Basic>.
+
+A I<recurrence-set> is represented by a I<method name>,
+one or two I<parent objects>, and extra arguments.
+The C<list> key is set to an empty array, and the
+C<too_complex> key is set to C<1>.
+
+This is a structure that holds the union of two "complex sets":
+
+ {
+ too_complex => 1, # "this is a recurrence"
+ list => [ ], # not used
+ method => 'union', # function name
+ parent => [ $set1, $set2 ], # "leaves" in the syntax-tree
+ param => [ ] # optional arguments for the function
+ }
+
+This is a structure that holds the complement of a "complex set":
+
+ {
+ too_complex => 1, # "this is a recurrence"
+ list => [ ], # not used
+ method => 'complement', # function name
+ parent => $set, # "leaf" in the syntax-tree
+ param => [ ] # optional arguments for the function
+ }
+
+
+=head1 SEE ALSO
+
+See modules DateTime::Set, DateTime::Event::Recurrence,
+DateTime::Event::ICal, DateTime::Event::Cron
+for up-to-date information on date-sets.
+
+The perl-date-time project <http://datetime.perl.org>
+
+
+=head1 AUTHOR
+
+Flavio S. Glock <fglock@gmail.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file included
+with this module.
+
+=cut
+
--- /dev/null
+package Set::Infinite::Arithmetic;
+# Copyright (c) 2001 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+use strict;
+# use warnings;
+require Exporter;
+use Carp;
+use Time::Local;
+use POSIX qw(floor);
+
+use vars qw( @EXPORT @EXPORT_OK $inf );
+
+@EXPORT = qw();
+@EXPORT_OK = qw();
+# @EXPORT_OK = qw( %subs_offset2 %Offset_to_value %Value_to_offset %Init_quantizer );
+
+$inf = 100**100**100; # $Set::Infinite::inf; doesn't work! (why?)
+
+=head2 NAME
+
+Set::Infinite::Arithmetic - Scalar operations used by quantize() and offset()
+
+=head2 AUTHOR
+
+Flavio Soibelmann Glock - fglock@pucrs.br
+
+=cut
+
+use vars qw( $day_size $hour_size $minute_size $second_size );
+$day_size = timegm(0,0,0,2,3,2001) - timegm(0,0,0,1,3,2001);
+$hour_size = $day_size / 24;
+$minute_size = $hour_size / 60;
+$second_size = $minute_size / 60;
+
+use vars qw( %_MODE %subs_offset2 %Offset_to_value @week_start %Init_quantizer %Value_to_offset %Offset_to_value );
+
+=head2 %_MODE hash of subs
+
+ $a->offset ( value => [1,2], mode => 'offset', unit => 'days' );
+
+ $a->offset ( value => [1,2, -5,-4], mode => 'offset', unit => 'days' );
+
+note: if mode = circle, then "-5" counts from end (like a Perl negative array index).
+
+ $a->offset ( value => [1,2], mode => 'offset', unit => 'days', strict => $a );
+
+option 'strict' will return intersection($a,offset). Default: none.
+
+=cut
+
+# return value = ($this, $next, $cmp)
+%_MODE = (
+ circle => sub {
+ if ($_[3] >= 0) {
+ &{ $_[0] } ($_[1], $_[3], $_[4] )
+ }
+ else {
+ &{ $_[0] } ($_[2], $_[3], $_[4] )
+ }
+ },
+ begin => sub { &{ $_[0] } ($_[1], $_[3], $_[4] ) },
+ end => sub { &{ $_[0] } ($_[2], $_[3], $_[4] ) },
+ offset => sub {
+ my ($this, undef) = &{ $_[0] } ($_[1], $_[3], $_[4] );
+ my (undef, $next) = &{ $_[0] } ($_[2], $_[3], $_[4] );
+ ($this, $next);
+ }
+);
+
+
+=head2 %subs_offset2($object, $offset1, $offset2)
+
+ &{ $subs_offset2{$unit} } ($object, $offset1, $offset2);
+
+A hash of functions that return:
+
+ ($object+$offset1, $object+$offset2)
+
+in $unit context.
+
+Returned $object+$offset1, $object+$offset2 may be scalars or objects.
+
+=cut
+
+%subs_offset2 = (
+ weekdays => sub {
+ # offsets to week-day specified
+ # 0 = first sunday from today (or today if today is sunday)
+ # 1 = first monday from today (or today if today is monday)
+ # 6 = first friday from today (or today if today is friday)
+ # 13 = second friday from today
+ # -1 = last saturday from today (not today, even if today were saturday)
+ # -2 = last friday
+ my ($self, $index1, $index2) = @_;
+ return ($self, $self) if $self == $inf;
+ # my $class = ref($self);
+ my @date = gmtime( $self );
+ my $wday = $date[6];
+ my ($tmp1, $tmp2);
+
+ $tmp1 = $index1 - $wday;
+ if ($index1 >= 0) {
+ $tmp1 += 7 if $tmp1 < 0; # it will only happen next week
+ }
+ else {
+ $tmp1 += 7 if $tmp1 < -7; # if will happen this week
+ }
+
+ $tmp2 = $index2 - $wday;
+ if ($index2 >= 0) {
+ $tmp2 += 7 if $tmp2 < 0; # it will only happen next week
+ }
+ else {
+ $tmp2 += 7 if $tmp2 < -7; # if will happen this week
+ }
+
+ # print " [ OFS:weekday $self $tmp1 $tmp2 ] \n";
+ # $date[3] += $tmp1;
+ $tmp1 = $self + $tmp1 * $day_size;
+ # $date[3] += $tmp2 - $tmp1;
+ $tmp2 = $self + $tmp2 * $day_size;
+
+ ($tmp1, $tmp2);
+ },
+ years => sub {
+ my ($self, $index, $index2) = @_;
+ return ($self, $self) if $self == $inf;
+ # my $class = ref($self);
+ # print " [ofs:year:$self -- $index]\n";
+ my @date = gmtime( $self );
+ $date[5] += 1900 + $index;
+ my $tmp = timegm(@date);
+
+ $date[5] += $index2 - $index;
+ my $tmp2 = timegm(@date);
+
+ ($tmp, $tmp2);
+ },
+ months => sub {
+ my ($self, $index, $index2) = @_;
+ # carp " [ofs:month:$self -- $index -- $inf]";
+ return ($self, $self) if $self == $inf;
+ # my $class = ref($self);
+ my @date = gmtime( $self );
+
+ my $mon = $date[4] + $index;
+ my $year = $date[5] + 1900;
+ # print " [OFS: month: from $year$mon ]\n";
+ if (($mon > 11) or ($mon < 0)) {
+ my $addyear = floor($mon / 12);
+ $mon = $mon - 12 * $addyear;
+ $year += $addyear;
+ }
+
+ my $mon2 = $date[4] + $index2;
+ my $year2 = $date[5] + 1900;
+ if (($mon2 > 11) or ($mon2 < 0)) {
+ my $addyear2 = floor($mon2 / 12);
+ $mon2 = $mon2 - 12 * $addyear2;
+ $year2 += $addyear2;
+ }
+
+ # print " [OFS: month: to $year $mon ]\n";
+
+ $date[4] = $mon;
+ $date[5] = $year;
+ my $tmp = timegm(@date);
+
+ $date[4] = $mon2;
+ $date[5] = $year2;
+ my $tmp2 = timegm(@date);
+
+ ($tmp, $tmp2);
+ },
+ days => sub {
+ ( $_[0] + $_[1] * $day_size,
+ $_[0] + $_[2] * $day_size,
+ )
+ },
+ weeks => sub {
+ ( $_[0] + $_[1] * (7 * $day_size),
+ $_[0] + $_[2] * (7 * $day_size),
+ )
+ },
+ hours => sub {
+ # carp " [ $_[0]+$_[1] hour = ".( $_[0] + $_[1] * $hour_size )." mode=".($_[0]->{mode})." ]";
+ ( $_[0] + $_[1] * $hour_size,
+ $_[0] + $_[2] * $hour_size,
+ )
+ },
+ minutes => sub {
+ ( $_[0] + $_[1] * $minute_size,
+ $_[0] + $_[2] * $minute_size,
+ )
+ },
+ seconds => sub {
+ ( $_[0] + $_[1] * $second_size,
+ $_[0] + $_[2] * $second_size,
+ )
+ },
+ one => sub {
+ ( $_[0] + $_[1],
+ $_[0] + $_[2],
+ )
+ },
+);
+
+
+@week_start = ( 0, -1, -2, -3, 3, 2, 1, 0, -1, -2, -3, 3, 2, 1, 0 );
+
+=head2 %Offset_to_value($object, $offset)
+
+=head2 %Init_quantizer($object)
+
+ $Offset_to_value{$unit} ($object, $offset);
+
+ $Init_quantizer{$unit} ($object);
+
+Maps an 'offset value' to a 'value'
+
+A hash of functions that return ( int($object) + $offset ) in $unit context.
+
+Init_quantizer subroutines must be called before using subs_offset1 functions.
+
+int(object)+offset is a scalar.
+
+Offset_to_value is optimized for calling it multiple times on the same object,
+with different offsets. That's why there is a separate initialization
+subroutine.
+
+$self->{offset} is created on initialization. It is an index used
+by the memoization cache.
+
+=cut
+
+%Offset_to_value = (
+ weekyears => sub {
+ my ($self, $index) = @_;
+ my $epoch = timegm( 0,0,0,
+ 1,0,$self->{offset} + $self->{quant} * $index);
+ my @time = gmtime($epoch);
+ # print " [QT_D:weekyears:$self->{offset} + $self->{quant} * $index]\n";
+ # year modulo week
+ # print " [QT:weekyears: time = ",join(";", @time )," ]\n";
+ $epoch += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size;
+ # print " [QT:weekyears: week=",join(";", gmtime($epoch) )," wkst=$self->{wkst} tbl[",$time[6] + 7 - $self->{wkst},"]=",$week_start[$time[6] + 7 - $self->{wkst}]," ]\n\n";
+
+ my $epoch2 = timegm( 0,0,0,
+ 1,0,$self->{offset} + $self->{quant} * (1 + $index) );
+ @time = gmtime($epoch2);
+ $epoch2 += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size;
+ ( $epoch, $epoch2 );
+ },
+ years => sub {
+ my $index = $_[0]->{offset} + $_[0]->{quant} * $_[1];
+ ( timegm( 0,0,0, 1, 0, $index),
+ timegm( 0,0,0, 1, 0, $index + $_[0]->{quant}) )
+ },
+ months => sub {
+ my $mon = $_[0]->{offset} + $_[0]->{quant} * $_[1];
+ my $year = int($mon / 12);
+ $mon -= $year * 12;
+ my $tmp = timegm( 0,0,0, 1, $mon, $year);
+
+ $mon += $year * 12 + $_[0]->{quant};
+ $year = int($mon / 12);
+ $mon -= $year * 12;
+ ( $tmp, timegm( 0,0,0, 1, $mon, $year) );
+ },
+ weeks => sub {
+ my $tmp = 3 * $day_size + $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ days => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ hours => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ minutes => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ seconds => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+ one => sub {
+ my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
+ ($tmp, $tmp + $_[0]->{quant})
+ },
+);
+
+
+# Maps an 'offset value' to a 'value'
+
+%Value_to_offset = (
+ one => sub { floor( $_[1] / $_[0]{quant} ) },
+ seconds => sub { floor( $_[1] / $_[0]{quant} ) },
+ minutes => sub { floor( $_[1] / $_[0]{quant} ) },
+ hours => sub { floor( $_[1] / $_[0]{quant} ) },
+ days => sub { floor( $_[1] / $_[0]{quant} ) },
+ weeks => sub { floor( ($_[1] - 3 * $day_size) / $_[0]{quant} ) },
+ months => sub {
+ my @date = gmtime( 0 + $_[1] );
+ my $tmp = $date[4] + 12 * (1900 + $date[5]);
+ floor( $tmp / $_[0]{quant} );
+ },
+ years => sub {
+ my @date = gmtime( 0 + $_[1] );
+ my $tmp = $date[5] + 1900;
+ floor( $tmp / $_[0]{quant} );
+ },
+ weekyears => sub {
+
+ my ($self, $value) = @_;
+ my @date;
+
+ # find out YEAR number
+ @date = gmtime( 0 + $value );
+ my $year = floor( $date[5] + 1900 / $self->{quant} );
+
+ # what is the EPOCH for this week-year's begin ?
+ my $begin_epoch = timegm( 0,0,0, 1,0,$year);
+ @date = gmtime($begin_epoch);
+ $begin_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size;
+
+ # what is the EPOCH for this week-year's end ?
+ my $end_epoch = timegm( 0,0,0, 1,0,$year+1);
+ @date = gmtime($end_epoch);
+ $end_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size;
+
+ $year-- if $value < $begin_epoch;
+ $year++ if $value >= $end_epoch;
+
+ # carp " value=$value offset=$year this_epoch=".$begin_epoch;
+ # carp " next_epoch=".$end_epoch;
+
+ $year;
+ },
+);
+
+# Initialize quantizer
+
+%Init_quantizer = (
+ one => sub {},
+ seconds => sub { $_[0]->{quant} *= $second_size },
+ minutes => sub { $_[0]->{quant} *= $minute_size },
+ hours => sub { $_[0]->{quant} *= $hour_size },
+ days => sub { $_[0]->{quant} *= $day_size },
+ weeks => sub { $_[0]->{quant} *= 7 * $day_size },
+ months => sub {},
+ years => sub {},
+ weekyears => sub {
+ $_[0]->{wkst} = 1 unless defined $_[0]->{wkst};
+ # select which 'cache' to use
+ # $_[0]->{memo} .= $_[0]->{wkst};
+ },
+);
+
+
+1;
+
--- /dev/null
+package Set::Infinite::Basic;
+
+# Copyright (c) 2001, 2002, 2003 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+require 5.005_03;
+use strict;
+
+require Exporter;
+use Carp;
+use Data::Dumper;
+use vars qw( @ISA @EXPORT_OK @EXPORT );
+use vars qw( $Type $tolerance $fixtype $inf $minus_inf @Separators $neg_inf );
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw( INFINITY NEG_INFINITY );
+@EXPORT = qw();
+
+use constant INFINITY => 100**100**100;
+use constant NEG_INFINITY => - INFINITY;
+
+$inf = INFINITY;
+$minus_inf = $neg_inf = NEG_INFINITY;
+
+use overload
+ '<=>' => \&spaceship,
+ qw("" as_string),
+;
+
+
+# TODO: make this an object _and_ class method
+# TODO: POD
+sub separators {
+ shift;
+ return $Separators[ $_[0] ] if $#_ == 0;
+ @Separators = @_ if @_;
+ return @Separators;
+}
+
+BEGIN {
+ __PACKAGE__->separators (
+ '[', ']', # a closed interval
+ '(', ')', # an open interval
+ '..', # number separator
+ ',', # list separator
+ '', '', # set delimiter '{' '}'
+ );
+ # global defaults for object private vars
+ $Type = undef;
+ $tolerance = 0;
+ $fixtype = 1;
+}
+
+# _simple_* set of internal methods: basic processing of "spans"
+
+sub _simple_intersects {
+ my $tmp1 = $_[0];
+ my $tmp2 = $_[1];
+ my ($i_beg, $i_end, $open_beg, $open_end);
+ my $cmp = $tmp1->{a} <=> $tmp2->{a};
+ if ($cmp < 0) {
+ $i_beg = $tmp2->{a};
+ $open_beg = $tmp2->{open_begin};
+ }
+ elsif ($cmp > 0) {
+ $i_beg = $tmp1->{a};
+ $open_beg = $tmp1->{open_begin};
+ }
+ else {
+ $i_beg = $tmp1->{a};
+ $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
+ }
+ $cmp = $tmp1->{b} <=> $tmp2->{b};
+ if ($cmp > 0) {
+ $i_end = $tmp2->{b};
+ $open_end = $tmp2->{open_end};
+ }
+ elsif ($cmp < 0) {
+ $i_end = $tmp1->{b};
+ $open_end = $tmp1->{open_end};
+ }
+ else {
+ $i_end = $tmp1->{b};
+ $open_end = ($tmp1->{open_end} || $tmp2->{open_end});
+ }
+ $cmp = $i_beg <=> $i_end;
+ return 0 if
+ ( $cmp > 0 ) ||
+ ( ($cmp == 0) && ($open_beg || $open_end) ) ;
+ return 1;
+}
+
+
+sub _simple_complement {
+ my $self = $_[0];
+ if ($self->{b} == $inf) {
+ return if $self->{a} == $neg_inf;
+ return { a => $neg_inf,
+ b => $self->{a},
+ open_begin => 1,
+ open_end => ! $self->{open_begin} };
+ }
+ if ($self->{a} == $neg_inf) {
+ return { a => $self->{b},
+ b => $inf,
+ open_begin => ! $self->{open_end},
+ open_end => 1 };
+ }
+ ( { a => $neg_inf,
+ b => $self->{a},
+ open_begin => 1,
+ open_end => ! $self->{open_begin}
+ },
+ { a => $self->{b},
+ b => $inf,
+ open_begin => ! $self->{open_end},
+ open_end => 1
+ }
+ );
+}
+
+sub _simple_union {
+ my ($tmp2, $tmp1, $tolerance) = @_;
+ my $cmp;
+ if ($tolerance) {
+ # "integer"
+ my $a1_open = $tmp1->{open_begin} ? -$tolerance : $tolerance ;
+ my $b1_open = $tmp1->{open_end} ? -$tolerance : $tolerance ;
+ my $a2_open = $tmp2->{open_begin} ? -$tolerance : $tolerance ;
+ my $b2_open = $tmp2->{open_end} ? -$tolerance : $tolerance ;
+ # open_end touching?
+ if ((($tmp1->{b}+$tmp1->{b}) + $b1_open ) <
+ (($tmp2->{a}+$tmp2->{a}) - $a2_open)) {
+ # self disjuncts b
+ return ( $tmp1, $tmp2 );
+ }
+ if ((($tmp1->{a}+$tmp1->{a}) - $a1_open ) >
+ (($tmp2->{b}+$tmp2->{b}) + $b2_open)) {
+ # self disjuncts b
+ return ( $tmp2, $tmp1 );
+ }
+ }
+ else {
+ # "real"
+ $cmp = $tmp1->{b} <=> $tmp2->{a};
+ if ( $cmp < 0 ||
+ ( $cmp == 0 && $tmp1->{open_end} && $tmp2->{open_begin} ) ) {
+ return ( $tmp1, $tmp2 );
+ }
+ $cmp = $tmp1->{a} <=> $tmp2->{b};
+ if ( $cmp > 0 ||
+ ( $cmp == 0 && $tmp2->{open_end} && $tmp1->{open_begin} ) ) {
+ return ( $tmp2, $tmp1 );
+ }
+ }
+
+ my $tmp;
+ $cmp = $tmp1->{a} <=> $tmp2->{a};
+ if ($cmp > 0) {
+ $tmp->{a} = $tmp2->{a};
+ $tmp->{open_begin} = $tmp2->{open_begin};
+ }
+ elsif ($cmp == 0) {
+ $tmp->{a} = $tmp1->{a};
+ $tmp->{open_begin} = $tmp1->{open_begin} ? $tmp2->{open_begin} : 0;
+ }
+ else {
+ $tmp->{a} = $tmp1->{a};
+ $tmp->{open_begin} = $tmp1->{open_begin};
+ }
+
+ $cmp = $tmp1->{b} <=> $tmp2->{b};
+ if ($cmp < 0) {
+ $tmp->{b} = $tmp2->{b};
+ $tmp->{open_end} = $tmp2->{open_end};
+ }
+ elsif ($cmp == 0) {
+ $tmp->{b} = $tmp1->{b};
+ $tmp->{open_end} = $tmp1->{open_end} ? $tmp2->{open_end} : 0;
+ }
+ else {
+ $tmp->{b} = $tmp1->{b};
+ $tmp->{open_end} = $tmp1->{open_end};
+ }
+ return $tmp;
+}
+
+
+sub _simple_spaceship {
+ my ($tmp1, $tmp2, $inverted) = @_;
+ my $cmp;
+ if ($inverted) {
+ $cmp = $tmp2->{a} <=> $tmp1->{a};
+ return $cmp if $cmp;
+ $cmp = $tmp1->{open_begin} <=> $tmp2->{open_begin};
+ return $cmp if $cmp;
+ $cmp = $tmp2->{b} <=> $tmp1->{b};
+ return $cmp if $cmp;
+ return $tmp1->{open_end} <=> $tmp2->{open_end};
+ }
+ $cmp = $tmp1->{a} <=> $tmp2->{a};
+ return $cmp if $cmp;
+ $cmp = $tmp2->{open_begin} <=> $tmp1->{open_begin};
+ return $cmp if $cmp;
+ $cmp = $tmp1->{b} <=> $tmp2->{b};
+ return $cmp if $cmp;
+ return $tmp2->{open_end} <=> $tmp1->{open_end};
+}
+
+
+sub _simple_new {
+ my ($tmp, $tmp2, $type) = @_;
+ if ($type) {
+ if ( ref($tmp) ne $type ) {
+ $tmp = new $type $tmp;
+ }
+ if ( ref($tmp2) ne $type ) {
+ $tmp2 = new $type $tmp2;
+ }
+ }
+ if ($tmp > $tmp2) {
+ carp "Invalid interval specification: start value is after end";
+ # ($tmp, $tmp2) = ($tmp2, $tmp);
+ }
+ return { a => $tmp , b => $tmp2 , open_begin => 0 , open_end => 0 };
+}
+
+
+sub _simple_as_string {
+ my $set = shift;
+ my $self = $_[0];
+ my $s;
+ return "" unless defined $self;
+ $self->{open_begin} = 1 if ($self->{a} == -$inf );
+ $self->{open_end} = 1 if ($self->{b} == $inf );
+ my $tmp1 = $self->{a};
+ $tmp1 = $tmp1->datetime if UNIVERSAL::can( $tmp1, 'datetime' );
+ $tmp1 = "$tmp1";
+ my $tmp2 = $self->{b};
+ $tmp2 = $tmp2->datetime if UNIVERSAL::can( $tmp2, 'datetime' );
+ $tmp2 = "$tmp2";
+ return $tmp1 if $tmp1 eq $tmp2;
+ $s = $self->{open_begin} ? $set->separators(2) : $set->separators(0);
+ $s .= $tmp1 . $set->separators(4) . $tmp2;
+ $s .= $self->{open_end} ? $set->separators(3) : $set->separators(1);
+ return $s;
+}
+
+# end of "_simple_" methods
+
+
+sub type {
+ my $self = shift;
+ unless (@_) {
+ return ref($self) ? $self->{type} : $Type;
+ }
+ my $tmp_type = shift;
+ eval "use " . $tmp_type;
+ carp "Warning: can't start $tmp_type : $@" if $@;
+ if (ref($self)) {
+ $self->{type} = $tmp_type;
+ return $self;
+ }
+ else {
+ $Type = $tmp_type;
+ return $Type;
+ }
+}
+
+sub list {
+ my $self = shift;
+ my @b = ();
+ foreach (@{$self->{list}}) {
+ push @b, $self->new($_);
+ }
+ return @b;
+}
+
+sub fixtype {
+ my $self = shift;
+ $self = $self->copy;
+ $self->{fixtype} = 1;
+ my $type = $self->type;
+ return $self unless $type;
+ foreach (@{$self->{list}}) {
+ $_->{a} = $type->new($_->{a}) unless ref($_->{a}) eq $type;
+ $_->{b} = $type->new($_->{b}) unless ref($_->{b}) eq $type;
+ }
+ return $self;
+}
+
+sub numeric {
+ my $self = shift;
+ return $self unless $self->{fixtype};
+ $self = $self->copy;
+ $self->{fixtype} = 0;
+ foreach (@{$self->{list}}) {
+ $_->{a} = 0 + $_->{a};
+ $_->{b} = 0 + $_->{b};
+ }
+ return $self;
+}
+
+sub _no_cleanup { $_[0] } # obsolete
+
+sub first {
+ my $self = $_[0];
+ if (exists $self->{first} ) {
+ return wantarray ? @{$self->{first}} : $self->{first}[0];
+ }
+ unless ( @{$self->{list}} ) {
+ return wantarray ? (undef, 0) : undef;
+ }
+ my $first = $self->new( $self->{list}[0] );
+ return $first unless wantarray;
+ my $res = $self->new;
+ push @{$res->{list}}, @{$self->{list}}[1 .. $#{$self->{list}}];
+ return @{$self->{first}} = ($first) if $res->is_null;
+ return @{$self->{first}} = ($first, $res);
+}
+
+sub last {
+ my $self = $_[0];
+ if (exists $self->{last} ) {
+ return wantarray ? @{$self->{last}} : $self->{last}[0];
+ }
+ unless ( @{$self->{list}} ) {
+ return wantarray ? (undef, 0) : undef;
+ }
+ my $last = $self->new( $self->{list}[-1] );
+ return $last unless wantarray;
+ my $res = $self->new;
+ push @{$res->{list}}, @{$self->{list}}[0 .. $#{$self->{list}}-1];
+ return @{$self->{last}} = ($last) if $res->is_null;
+ return @{$self->{last}} = ($last, $res);
+}
+
+sub is_null {
+ @{$_[0]->{list}} ? 0 : 1;
+}
+
+sub is_empty {
+ $_[0]->is_null;
+}
+
+sub is_nonempty {
+ ! $_[0]->is_null;
+}
+
+sub is_span {
+ ( $#{$_[0]->{list}} == 0 ) ? 1 : 0;
+}
+
+sub is_singleton {
+ ( $#{$_[0]->{list}} == 0 &&
+ $_[0]->{list}[0]{a} == $_[0]->{list}[0]{b} ) ? 1 : 0;
+}
+
+sub is_subset {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+ return $b1->contains( $a1 );
+}
+
+sub is_proper_subset {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+
+ my $contains = $b1->contains( $a1 );
+ return $contains unless $contains;
+
+ my $equal = ( $a1 == $b1 );
+ return $equal if !defined $equal || $equal;
+
+ return 1;
+}
+
+sub is_disjoint {
+ my $intersects = shift->intersects( @_ );
+ return ! $intersects if defined $intersects;
+ return $intersects;
+}
+
+sub iterate {
+ # TODO: options 'no-sort', 'no-merge', 'keep-null' ...
+ my $a1 = shift;
+ my $iterate = $a1->empty_set();
+ my (@tmp, $ia);
+ my $subroutine = shift;
+ foreach $ia (0 .. $#{$a1->{list}}) {
+ @tmp = $subroutine->( $a1->new($a1->{list}[$ia]), @_ );
+ $iterate = $iterate->union(@tmp) if @tmp;
+ }
+ return $iterate;
+}
+
+
+sub intersection {
+ my $a1 = shift;
+ my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
+ return _intersection ( 'intersection', $a1, $b1 );
+}
+
+sub intersects {
+ my $a1 = shift;
+ my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
+ return _intersection ( 'intersects', $a1, $b1 );
+}
+
+sub intersected_spans {
+ my $a1 = shift;
+ my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
+ return _intersection ( 'intersected_spans', $a1, $b1 );
+}
+
+
+sub _intersection {
+ my ( $op, $a1, $b1 ) = @_;
+
+ my $ia;
+ my ( $a0, $na ) = ( 0, $#{$a1->{list}} );
+ my ( $tmp1, $tmp1a, $tmp2a, $tmp1b, $tmp2b, $i_beg, $i_end, $open_beg, $open_end );
+ my ( $cmp1, $cmp2 );
+ my @a;
+
+ # for-loop optimization (makes little difference)
+ # This was kept for backward compatibility with Date::Set tests
+ my $self = $a1;
+ if ($na < $#{ $b1->{list} })
+ {
+ $na = $#{ $b1->{list} };
+ ($a1, $b1) = ($b1, $a1);
+ }
+ # ---
+
+ B: foreach my $tmp2 ( @{ $b1->{list} } ) {
+ $tmp2a = $tmp2->{a};
+ $tmp2b = $tmp2->{b};
+ A: foreach $ia ($a0 .. $na) {
+ $tmp1 = $a1->{list}[$ia];
+ $tmp1b = $tmp1->{b};
+
+ if ($tmp1b < $tmp2a) {
+ $a0++;
+ next A;
+ }
+ $tmp1a = $tmp1->{a};
+ if ($tmp1a > $tmp2b) {
+ next B;
+ }
+
+ $cmp1 = $tmp1a <=> $tmp2a;
+ if ( $cmp1 < 0 ) {
+ $tmp1a = $tmp2a;
+ $open_beg = $tmp2->{open_begin};
+ }
+ elsif ( $cmp1 ) {
+ $open_beg = $tmp1->{open_begin};
+ }
+ else {
+ $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
+ }
+
+ $cmp2 = $tmp1b <=> $tmp2b;
+ if ( $cmp2 > 0 ) {
+ $tmp1b = $tmp2b;
+ $open_end = $tmp2->{open_end};
+ }
+ elsif ( $cmp2 ) {
+ $open_end = $tmp1->{open_end};
+ }
+ else {
+ $open_end = $tmp1->{open_end} || $tmp2->{open_end};
+ }
+
+ if ( ( $tmp1a <= $tmp1b ) &&
+ ( ($tmp1a != $tmp1b) ||
+ (!$open_beg and !$open_end) ||
+ ($tmp1a == $inf) || # XXX
+ ($tmp1a == $neg_inf)
+ )
+ )
+ {
+ if ( $op eq 'intersection' )
+ {
+ push @a, {
+ a => $tmp1a, b => $tmp1b,
+ open_begin => $open_beg, open_end => $open_end } ;
+ }
+ if ( $op eq 'intersects' )
+ {
+ return 1;
+ }
+ if ( $op eq 'intersected_spans' )
+ {
+ push @a, $tmp1;
+ $a0++;
+ next A;
+ }
+ }
+ }
+ }
+
+ return 0 if $op eq 'intersects';
+
+ my $intersection = $self->new();
+ $intersection->{list} = \@a;
+ return $intersection;
+}
+
+
+sub complement {
+ my $self = shift;
+ if (@_) {
+ my $a1;
+ if (ref ($_[0]) eq ref($self) ) {
+ $a1 = shift;
+ }
+ else {
+ $a1 = $self->new(@_);
+ }
+ return $self->intersection( $a1->complement );
+ }
+
+ unless ( @{$self->{list}} ) {
+ return $self->universal_set;
+ }
+ my $complement = $self->empty_set();
+ @{$complement->{list}} = _simple_complement($self->{list}[0]);
+
+ my $tmp = $self->empty_set();
+ foreach my $ia (1 .. $#{$self->{list}}) {
+ @{$tmp->{list}} = _simple_complement($self->{list}[$ia]);
+ $complement = $complement->intersection($tmp);
+ }
+ return $complement;
+}
+
+
+sub until {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+ my @b1_min = $b1->min_a;
+ my @a1_max = $a1->max_a;
+
+ unless (defined $b1_min[0]) {
+ return $a1->until($inf);
+ }
+ unless (defined $a1_max[0]) {
+ return $a1->new(-$inf)->until($b1);
+ }
+
+ my ($ia, $ib, $begin, $end);
+ $ia = 0;
+ $ib = 0;
+
+ my $u = $a1->new;
+ my $last = -$inf;
+ while ( ($ia <= $#{$a1->{list}}) && ($ib <= $#{$b1->{list}})) {
+ $begin = $a1->{list}[$ia]{a};
+ $end = $b1->{list}[$ib]{b};
+ if ( $end <= $begin ) {
+ push @{$u->{list}}, {
+ a => $last ,
+ b => $end ,
+ open_begin => 0 ,
+ open_end => 1 };
+ $ib++;
+ $last = $end;
+ next;
+ }
+ push @{$u->{list}}, {
+ a => $begin ,
+ b => $end ,
+ open_begin => 0 ,
+ open_end => 1 };
+ $ib++;
+ $ia++;
+ $last = $end;
+ }
+ if ($ia <= $#{$a1->{list}} &&
+ $a1->{list}[$ia]{a} >= $last )
+ {
+ push @{$u->{list}}, {
+ a => $a1->{list}[$ia]{a} ,
+ b => $inf ,
+ open_begin => 0 ,
+ open_end => 1 };
+ }
+ return $u;
+}
+
+sub start_set {
+ return $_[0]->iterate(
+ sub { $_[0]->min }
+ );
+}
+
+
+sub end_set {
+ return $_[0]->iterate(
+ sub { $_[0]->max }
+ );
+}
+
+sub union {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+ # test for union with empty set
+ if ( $#{ $a1->{list} } < 0 ) {
+ return $b1;
+ }
+ if ( $#{ $b1->{list} } < 0 ) {
+ return $a1;
+ }
+ my @b1_min = $b1->min_a;
+ my @a1_max = $a1->max_a;
+ unless (defined $b1_min[0]) {
+ return $a1;
+ }
+ unless (defined $a1_max[0]) {
+ return $b1;
+ }
+ my ($ia, $ib);
+ $ia = 0;
+ $ib = 0;
+
+ # size+order matters on speed
+ $a1 = $a1->new($a1); # don't modify ourselves
+ my $b_list = $b1->{list};
+ # -- frequent case - $b1 is after $a1
+ if ($b1_min[0] > $a1_max[0]) {
+ push @{$a1->{list}}, @$b_list;
+ return $a1;
+ }
+
+ my @tmp;
+ my $is_real = !$a1->tolerance && !$b1->tolerance;
+ B: foreach $ib ($ib .. $#{$b_list}) {
+ foreach $ia ($ia .. $#{$a1->{list}}) {
+ @tmp = _simple_union($a1->{list}[$ia], $b_list->[$ib], $a1->{tolerance});
+ if ($#tmp == 0) {
+ $a1->{list}[$ia] = $tmp[0];
+
+ while (1) {
+ last if $ia >= $#{$a1->{list}};
+ last unless _simple_intersects ( $a1->{list}[$ia], $a1->{list}[$ia + 1] )
+ || $is_real
+ && $a1->{list}[$ia]{b} == $a1->{list}[$ia + 1]{a};
+ @tmp = _simple_union($a1->{list}[$ia], $a1->{list}[$ia + 1], $a1->{tolerance});
+ last unless @tmp == 1;
+ $a1->{list}[$ia] = $tmp[0];
+ splice( @{$a1->{list}}, $ia + 1, 1 );
+ }
+
+ next B;
+ }
+ if ($a1->{list}[$ia]{a} >= $b_list->[$ib]{a}) {
+ splice (@{$a1->{list}}, $ia, 0, $b_list->[$ib]);
+ next B;
+ }
+ }
+ push @{$a1->{list}}, $b_list->[$ib];
+ }
+ return $a1;
+}
+
+
+# there are some ways to process 'contains':
+# A CONTAINS B IF A == ( A UNION B )
+# - faster
+# A CONTAINS B IF B == ( A INTERSECTION B )
+# - can backtrack = works for unbounded sets
+sub contains {
+ my $a1 = shift;
+ my $b1 = $a1->union(@_);
+ return ($b1 == $a1) ? 1 : 0;
+}
+
+
+sub copy {
+ my $self = shift;
+ my $copy = $self->empty_set();
+ ## return $copy unless ref($self); # constructor!
+ foreach my $key (keys %{$self}) {
+ if ( ref( $self->{$key} ) eq 'ARRAY' ) {
+ @{ $copy->{$key} } = @{ $self->{$key} };
+ }
+ else {
+ $copy->{$key} = $self->{$key};
+ }
+ }
+ return $copy;
+}
+
+*clone = \©
+
+
+sub new {
+ my $class = shift;
+ my $self;
+ if ( ref $class ) {
+ $self = bless {
+ list => [],
+ tolerance => $class->{tolerance},
+ type => $class->{type},
+ fixtype => $class->{fixtype},
+ }, ref($class);
+ }
+ else {
+ $self = bless {
+ list => [],
+ tolerance => $tolerance ? $tolerance : 0,
+ type => $class->type,
+ fixtype => $fixtype ? $fixtype : 0,
+ }, $class;
+ }
+ my ($tmp, $tmp2, $ref);
+ while (@_) {
+ $tmp = shift;
+ $ref = ref($tmp);
+ if ($ref) {
+ if ($ref eq 'ARRAY') {
+ # allows arrays of arrays
+ $tmp = $class->new(@$tmp); # call new() recursively
+ push @{ $self->{list} }, @{$tmp->{list}};
+ next;
+ }
+ if ($ref eq 'HASH') {
+ push @{ $self->{list} }, $tmp;
+ next;
+ }
+ if ($tmp->isa(__PACKAGE__)) {
+ push @{ $self->{list} }, @{$tmp->{list}};
+ next;
+ }
+ }
+ if ( @_ ) {
+ $tmp2 = shift
+ }
+ else {
+ $tmp2 = $tmp
+ }
+ push @{ $self->{list} }, _simple_new($tmp,$tmp2, $self->{type} )
+ }
+ $self;
+}
+
+sub empty_set {
+ $_[0]->new;
+}
+
+sub universal_set {
+ $_[0]->new( NEG_INFINITY, INFINITY );
+}
+
+*minus = \∁
+
+*difference = \∁
+
+sub symmetric_difference {
+ my $a1 = shift;
+ my $b1;
+ if (ref ($_[0]) eq ref($a1) ) {
+ $b1 = shift;
+ }
+ else {
+ $b1 = $a1->new(@_);
+ }
+
+ return $a1->complement( $b1 )->union(
+ $b1->complement( $a1 ) );
+}
+
+*simmetric_difference = \&symmetric_difference; # bugfix
+
+sub min {
+ ($_[0]->min_a)[0];
+}
+
+sub min_a {
+ my $self = $_[0];
+ return @{$self->{min}} if exists $self->{min};
+ return @{$self->{min}} = (undef, 0) unless @{$self->{list}};
+ my $tmp = $self->{list}[0]{a};
+ my $tmp2 = $self->{list}[0]{open_begin} || 0;
+ if ($tmp2 && $self->{tolerance}) {
+ $tmp2 = 0;
+ $tmp += $self->{tolerance};
+ }
+ return @{$self->{min}} = ($tmp, $tmp2);
+};
+
+sub max {
+ ($_[0]->max_a)[0];
+}
+
+sub max_a {
+ my $self = $_[0];
+ return @{$self->{max}} if exists $self->{max};
+ return @{$self->{max}} = (undef, 0) unless @{$self->{list}};
+ my $tmp = $self->{list}[-1]{b};
+ my $tmp2 = $self->{list}[-1]{open_end} || 0;
+ if ($tmp2 && $self->{tolerance}) {
+ $tmp2 = 0;
+ $tmp -= $self->{tolerance};
+ }
+ return @{$self->{max}} = ($tmp, $tmp2);
+};
+
+sub count {
+ 1 + $#{$_[0]->{list}};
+}
+
+sub size {
+ my $self = $_[0];
+ my $size;
+ foreach( @{$self->{list}} ) {
+ if ( $size ) {
+ $size += $_->{b} - $_->{a};
+ }
+ else {
+ $size = $_->{b} - $_->{a};
+ }
+ if ( $self->{tolerance} ) {
+ $size += $self->{tolerance} unless $_->{open_end};
+ $size -= $self->{tolerance} if $_->{open_begin};
+ $size -= $self->{tolerance} if $_->{open_end};
+ }
+ }
+ return $size;
+};
+
+sub span {
+ my $self = $_[0];
+ my @max = $self->max_a;
+ my @min = $self->min_a;
+ return undef unless defined $min[0] && defined $max[0];
+ my $a1 = $self->new($min[0], $max[0]);
+ $a1->{list}[0]{open_end} = $max[1];
+ $a1->{list}[0]{open_begin} = $min[1];
+ return $a1;
+};
+
+sub spaceship {
+ my ($tmp1, $tmp2, $inverted) = @_;
+ if ($inverted) {
+ ($tmp2, $tmp1) = ($tmp1, $tmp2);
+ }
+ foreach(0 .. $#{$tmp1->{list}}) {
+ my $this = $tmp1->{list}[$_];
+ if ($_ > $#{ $tmp2->{list} } ) {
+ return 1;
+ }
+ my $other = $tmp2->{list}[$_];
+ my $cmp = _simple_spaceship($this, $other);
+ return $cmp if $cmp; # this != $other;
+ }
+ return $#{ $tmp1->{list} } == $#{ $tmp2->{list} } ? 0 : -1;
+}
+
+sub tolerance {
+ my $self = shift;
+ my $tmp = pop;
+ if (ref($self)) {
+ # local
+ return $self->{tolerance} unless defined $tmp;
+ $self = $self->copy;
+ $self->{tolerance} = $tmp;
+ delete $self->{max}; # tolerance may change "max"
+
+ $_ = 1;
+ my @tmp;
+ while ( $_ <= $#{$self->{list}} ) {
+ @tmp = Set::Infinite::Basic::_simple_union($self->{list}->[$_],
+ $self->{list}->[$_ - 1],
+ $self->{tolerance});
+ if ($#tmp == 0) {
+ $self->{list}->[$_ - 1] = $tmp[0];
+ splice (@{$self->{list}}, $_, 1);
+ }
+ else {
+ $_ ++;
+ }
+ }
+
+ return $self;
+ }
+ # global
+ $tolerance = $tmp if defined($tmp);
+ return $tolerance;
+}
+
+sub integer {
+ $_[0]->tolerance (1);
+}
+
+sub real {
+ $_[0]->tolerance (0);
+}
+
+sub as_string {
+ my $self = shift;
+ return $self->separators(6) .
+ join( $self->separators(5),
+ map { $self->_simple_as_string($_) } @{$self->{list}} ) .
+ $self->separators(7),;
+}
+
+
+sub DESTROY {}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Set::Infinite::Basic - Sets of intervals
+6
+=head1 SYNOPSIS
+
+ use Set::Infinite::Basic;
+
+ $set = Set::Infinite::Basic->new(1,2); # [1..2]
+ print $set->union(5,6); # [1..2],[5..6]
+
+=head1 DESCRIPTION
+
+Set::Infinite::Basic is a Set Theory module for infinite sets.
+
+It works on reals, integers, and objects.
+
+This module does not support recurrences. Recurrences are implemented in Set::Infinite.
+
+=head1 METHODS
+
+=head2 empty_set
+
+Creates an empty_set.
+
+If called from an existing set, the empty set inherits
+the "type" and "density" characteristics.
+
+=head2 universal_set
+
+Creates a set containing "all" possible elements.
+
+If called from an existing set, the universal set inherits
+the "type" and "density" characteristics.
+
+=head2 until
+
+Extends a set until another:
+
+ 0,5,7 -> until 2,6,10
+
+gives
+
+ [0..2), [5..6), [7..10)
+
+Note: this function is still experimental.
+
+=head2 copy
+
+=head2 clone
+
+Makes a new object from the object's data.
+
+=head2 Mode functions:
+
+ $set = $set->real;
+
+ $set = $set->integer;
+
+=head2 Logic functions:
+
+ $logic = $set->intersects($b);
+
+ $logic = $set->contains($b);
+
+ $logic = $set->is_null; # also called "is_empty"
+
+=head2 Set functions:
+
+ $set = $set->union($b);
+
+ $set = $set->intersection($b);
+
+ $set = $set->complement;
+ $set = $set->complement($b); # can also be called "minus" or "difference"
+
+ $set = $set->symmetric_difference( $b );
+
+ $set = $set->span;
+
+ result is (min .. max)
+
+=head2 Scalar functions:
+
+ $i = $set->min;
+
+ $i = $set->max;
+
+ $i = $set->size;
+
+ $i = $set->count; # number of spans
+
+=head2 Overloaded Perl functions:
+
+ print
+
+ sort, <=>
+
+=head2 Global functions:
+
+ separators(@i)
+
+ chooses the interval separators.
+
+ default are [ ] ( ) '..' ','.
+
+ INFINITY
+
+ returns an 'Infinity' number.
+
+ NEG_INFINITY
+
+ returns a '-Infinity' number.
+
+ iterate ( sub { } )
+
+ Iterates over a subroutine.
+ Returns the union of partial results.
+
+ first
+
+ In scalar context returns the first interval of a set.
+
+ In list context returns the first interval of a set, and the
+ 'tail'.
+
+ Works in unbounded sets
+
+ type($i)
+
+ chooses an object data type.
+
+ default is none (a normal perl SCALAR).
+
+ examples:
+
+ type('Math::BigFloat');
+ type('Math::BigInt');
+ type('Set::Infinite::Date');
+ See notes on Set::Infinite::Date below.
+
+ tolerance(0) defaults to real sets (default)
+ tolerance(1) defaults to integer sets
+
+ real defaults to real sets (default)
+
+ integer defaults to integer sets
+
+=head2 Internal functions:
+
+ $set->fixtype;
+
+ $set->numeric;
+
+=head1 CAVEATS
+
+ $set = Set::Infinite->new(10,1);
+ Will be interpreted as [1..10]
+
+ $set = Set::Infinite->new(1,2,3,4);
+ Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
+ You probably want ->new([1],[2],[3],[4]) instead,
+ or maybe ->new(1,4)
+
+ $set = Set::Infinite->new(1..3);
+ Will be interpreted as [1..2],3 instead of [1,2,3].
+ You probably want ->new(1,3) instead.
+
+=head1 INTERNALS
+
+The internal representation of a I<span> is a hash:
+
+ { a => start of span,
+ b => end of span,
+ open_begin => '0' the span starts in 'a'
+ '1' the span starts after 'a'
+ open_end => '0' the span ends in 'b'
+ '1' the span ends before 'b'
+ }
+
+For example, this set:
+
+ [100..200),300,(400..infinity)
+
+is represented by the array of hashes:
+
+ list => [
+ { a => 100, b => 200, open_begin => 0, open_end => 1 },
+ { a => 300, b => 300, open_begin => 0, open_end => 0 },
+ { a => 400, b => infinity, open_begin => 0, open_end => 1 },
+ ]
+
+The I<density> of a set is stored in the C<tolerance> variable:
+
+ tolerance => 0; # the set is made of real numbers.
+
+ tolerance => 1; # the set is made of integers.
+
+The C<type> variable stores the I<class> of objects that will be stored in the set.
+
+ type => 'DateTime'; # this is a set of DateTime objects
+
+The I<infinity> value is generated by Perl, when it finds a numerical overflow:
+
+ $inf = 100**100**100;
+
+=head1 SEE ALSO
+
+ Set::Infinite
+
+=head1 AUTHOR
+
+ Flavio S. Glock <fglock@gmail.com>
+
+=cut
+
--- /dev/null
+# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Set::Infinite::_recurrence;
+
+use strict;
+
+use constant INFINITY => 100 ** 100 ** 100 ;
+use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
+
+use vars qw( @ISA $PRETTY_PRINT $max_iterate );
+
+@ISA = qw( Set::Infinite );
+use Set::Infinite 0.5502;
+
+BEGIN {
+ $PRETTY_PRINT = 1; # enable Set::Infinite debug
+ $max_iterate = 20;
+
+ # TODO: inherit %Set::Infinite::_first / _last
+ # in a more "object oriented" way
+
+ $Set::Infinite::_first{_recurrence} =
+ sub {
+ my $self = $_[0];
+ my ($callback_next, $callback_previous) = @{ $self->{param} };
+ my ($min, $min_open) = $self->{parent}->min_a;
+
+ my ( $min1, $min2 );
+ $min1 = $callback_next->( $min );
+ if ( ! $min_open )
+ {
+ $min2 = $callback_previous->( $min1 );
+ $min1 = $min2 if defined $min2 && $min == $min2;
+ }
+
+ my $start = $callback_next->( $min1 );
+ my $end = $self->{parent}->max;
+
+ #print STDERR "set ";
+ #print STDERR $start->datetime
+ # unless $start == INFINITY;
+ #print STDERR " - " ;
+ #print STDERR $end->datetime
+ # unless $end == INFINITY;
+ #print STDERR "\n";
+
+ return ( $self->new( $min1 ), undef )
+ if $start > $end;
+
+ return ( $self->new( $min1 ),
+ $self->new( $start, $end )->
+ _function( '_recurrence', @{ $self->{param} } ) );
+ };
+ $Set::Infinite::_last{_recurrence} =
+ sub {
+ my $self = $_[0];
+ my ($callback_next, $callback_previous) = @{ $self->{param} };
+ my ($max, $max_open) = $self->{parent}->max_a;
+
+ my ( $max1, $max2 );
+ $max1 = $callback_previous->( $max );
+ if ( ! $max_open )
+ {
+ $max2 = $callback_next->( $max1 );
+ $max1 = $max2 if $max == $max2;
+ }
+
+ return ( $self->new( $max1 ),
+ $self->new( $self->{parent}->min,
+ $callback_previous->( $max1 ) )->
+ _function( '_recurrence', @{ $self->{param} } ) );
+ };
+}
+
+# $si->_recurrence(
+# \&callback_next, \&callback_previous )
+#
+# Generates "recurrences" from a callback.
+# These recurrences are simple lists of dates.
+#
+# The recurrence generation is based on an idea from Dave Rolsky.
+#
+
+# use Data::Dumper;
+# use Carp qw(cluck);
+
+sub _recurrence {
+ my $set = shift;
+ my ( $callback_next, $callback_previous, $delta ) = @_;
+
+ $delta->{count} = 0 unless defined $delta->{delta};
+
+ # warn "reusing delta: ". $delta->{count} if defined $delta->{delta};
+ # warn Dumper( $delta );
+
+ if ( $#{ $set->{list} } != 0 || $set->is_too_complex )
+ {
+ return $set->iterate(
+ sub {
+ $_[0]->_recurrence(
+ $callback_next, $callback_previous, $delta )
+ } );
+ }
+ # $set is a span
+ my $result;
+ if ($set->min != NEG_INFINITY && $set->max != INFINITY)
+ {
+ # print STDERR " finite set\n";
+ my ($min, $min_open) = $set->min_a;
+ my ($max, $max_open) = $set->max_a;
+
+ my ( $min1, $min2 );
+ $min1 = $callback_next->( $min );
+ if ( ! $min_open )
+ {
+ $min2 = $callback_previous->( $min1 );
+ $min1 = $min2 if defined $min2 && $min == $min2;
+ }
+
+ $result = $set->new();
+
+ # get "delta" - abort if this will take too much time.
+
+ unless ( defined $delta->{max_delta} )
+ {
+ for ( $delta->{count} .. 10 )
+ {
+ if ( $max_open )
+ {
+ return $result if $min1 >= $max;
+ }
+ else
+ {
+ return $result if $min1 > $max;
+ }
+ push @{ $result->{list} },
+ { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
+ $min2 = $callback_next->( $min1 );
+
+ if ( $delta->{delta} )
+ {
+ $delta->{delta} += $min2 - $min1;
+ }
+ else
+ {
+ $delta->{delta} = $min2 - $min1;
+ }
+ $delta->{count}++;
+ $min1 = $min2;
+ }
+
+ $delta->{max_delta} = $delta->{delta} * 40;
+ }
+
+ if ( $max < $min + $delta->{max_delta} )
+ {
+ for ( 1 .. 200 )
+ {
+ if ( $max_open )
+ {
+ return $result if $min1 >= $max;
+ }
+ else
+ {
+ return $result if $min1 > $max;
+ }
+ push @{ $result->{list} },
+ { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
+ $min1 = $callback_next->( $min1 );
+ }
+ }
+
+ # cluck "give up";
+ }
+
+ # return a "_function", such that we can backtrack later.
+ my $func = $set->_function( '_recurrence', $callback_next, $callback_previous, $delta );
+
+ # removed - returning $result doesn't help on speed
+ ## return $func->_function2( 'union', $result ) if $result;
+
+ return $func;
+}
+
+sub is_forever
+{
+ $#{ $_[0]->{list} } == 0 &&
+ $_[0]->max == INFINITY &&
+ $_[0]->min == NEG_INFINITY
+}
+
+sub _is_recurrence
+{
+ exists $_[0]->{method} &&
+ $_[0]->{method} eq '_recurrence' &&
+ $_[0]->{parent}->is_forever
+}
+
+sub intersection
+{
+ my ($s1, $s2) = (shift,shift);
+
+ if ( exists $s1->{method} && $s1->{method} eq '_recurrence' )
+ {
+ # optimize: recurrence && span
+ return $s1->{parent}->
+ intersection( $s2, @_ )->
+ _recurrence( @{ $s1->{param} } )
+ unless ref($s2) && exists $s2->{method};
+
+ # optimize: recurrence && recurrence
+ if ( $s1->{parent}->is_forever &&
+ ref($s2) && _is_recurrence( $s2 ) )
+ {
+ my ( $next1, $previous1 ) = @{ $s1->{param} };
+ my ( $next2, $previous2 ) = @{ $s2->{param} };
+ return $s1->{parent}->_function( '_recurrence',
+ sub {
+ # intersection of parent 'next' callbacks
+ my ($n1, $n2);
+ my $iterate = 0;
+ $n2 = $next2->( $_[0] );
+ while(1) {
+ $n1 = $next1->( $previous1->( $n2 ) );
+ return $n1 if $n1 == $n2;
+ $n2 = $next2->( $previous2->( $n1 ) );
+ return if $iterate++ == $max_iterate;
+ }
+ },
+ sub {
+ # intersection of parent 'previous' callbacks
+ my ($p1, $p2);
+ my $iterate = 0;
+ $p2 = $previous2->( $_[0] );
+ while(1) {
+ $p1 = $previous1->( $next1->( $p2 ) );
+ return $p1 if $p1 == $p2;
+ $p2 = $previous2->( $next2->( $p1 ) );
+ return if $iterate++ == $max_iterate;
+ }
+ },
+ );
+ }
+ }
+ return $s1->SUPER::intersection( $s2, @_ );
+}
+
+sub union
+{
+ my ($s1, $s2) = (shift,shift);
+ if ( $s1->_is_recurrence &&
+ ref($s2) && _is_recurrence( $s2 ) )
+ {
+ # optimize: recurrence || recurrence
+ my ( $next1, $previous1 ) = @{ $s1->{param} };
+ my ( $next2, $previous2 ) = @{ $s2->{param} };
+ return $s1->{parent}->_function( '_recurrence',
+ sub { # next
+ my $n1 = $next1->( $_[0] );
+ my $n2 = $next2->( $_[0] );
+ return $n1 < $n2 ? $n1 : $n2;
+ },
+ sub { # previous
+ my $p1 = $previous1->( $_[0] );
+ my $p2 = $previous2->( $_[0] );
+ return $p1 > $p2 ? $p1 : $p2;
+ },
+ );
+ }
+ return $s1->SUPER::union( $s2, @_ );
+}
+
+=head1 NAME
+
+Set::Infinite::_recurrence - Extends Set::Infinite with recurrence functions
+
+=head1 SYNOPSIS
+
+ $recurrence = $base_set->_recurrence ( \&next, \&previous );
+
+=head1 DESCRIPTION
+
+This is an internal class used by the DateTime::Set module.
+The API is subject to change.
+
+It provides all functionality provided by Set::Infinite, plus the ability
+to define recurrences with arbitrary objects, such as dates.
+
+=head1 METHODS
+
+=over 4
+
+=item * _recurrence ( \&next, \&previous )
+
+Creates a recurrence set. The set is defined inside a 'base set'.
+
+ $recurrence = $base_set->_recurrence ( \&next, \&previous );
+
+The recurrence functions take one argument, and return the 'next' or
+the 'previous' occurence.
+
+Example: defines the set of all 'integer numbers':
+
+ use strict;
+
+ use Set::Infinite::_recurrence;
+ use POSIX qw(floor);
+
+ # define the recurrence span
+ my $forever = Set::Infinite::_recurrence->new(
+ Set::Infinite::_recurrence::NEG_INFINITY,
+ Set::Infinite::_recurrence::INFINITY
+ );
+
+ my $recurrence = $forever->_recurrence(
+ sub { # next
+ floor( $_[0] + 1 )
+ },
+ sub { # previous
+ my $tmp = floor( $_[0] );
+ $tmp < $_[0] ? $tmp : $_[0] - 1
+ },
+ );
+
+ print "sample recurrence ",
+ $recurrence->intersection( -5, 5 ), "\n";
+ # sample recurrence -5,-4,-3,-2,-1,0,1,2,3,4,5
+
+ {
+ my $x = 234.567;
+ print "next occurence after $x = ",
+ $recurrence->{param}[0]->( $x ), "\n"; # 235
+ print "previous occurence before $x = ",
+ $recurrence->{param}[2]->( $x ), "\n"; # 234
+ }
+
+ {
+ my $x = 234;
+ print "next occurence after $x = ",
+ $recurrence->{param}[0]->( $x ), "\n"; # 235
+ print "previous occurence before $x = ",
+ $recurrence->{param}[2]->( $x ), "\n"; # 233
+ }
+
+=item * is_forever
+
+Returns true if the set is a single span,
+ranging from -Infinity to Infinity.
+
+=item * _is_recurrence
+
+Returns true if the set is an unbounded recurrence,
+ranging from -Infinity to Infinity.
+
+=back
+
+=head1 CONSTANTS
+
+=over 4
+
+=item * INFINITY
+
+The C<Infinity> value.
+
+=item * NEG_INFINITY
+
+The C<-Infinity> value.
+
+=back
+
+=head1 SUPPORT
+
+Support is offered through the C<datetime@perl.org> mailing list.
+
+Please report bugs using rt.cpan.org
+
+=head1 AUTHOR
+
+Flavio Soibelmann Glock <fglock@pucrs.br>
+
+The recurrence generation algorithm is based on an idea from Dave Rolsky.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
+This program is free software; you can distribute it and/or
+modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file
+included with this module.
+
+=head1 SEE ALSO
+
+Set::Infinite
+
+DateTime::Set
+
+For details on the Perl DateTime Suite project please see
+L<http://datetime.perl.org>.
+
+=cut
+
sub process_table {
my @spec = split(/=/, shift, 2);
my $table = $spec[0];
+ my $schema = '';
+ ($schema, $table) = split(m/\./, $table) if $table =~ m/\./;
my $package = ucfirst($spec[1] || $spec[0]);
$package =~ s/_+(.)/uc($1)/ge;
my $meta_file = "${meta_path}/${package}.pm";
my $file = "SL/DB/${package}.pm";
+ $schema = <<CODE if $schema;
+ __PACKAGE__->meta->schema('$schema');
+CODE
+
my $definition = eval <<CODE;
package SL::DB::AUTO::$package;
use SL::DB::Object;
use base qw(SL::DB::Object);
__PACKAGE__->meta->table('$table');
+$schema
__PACKAGE__->meta->auto_initialize;
__PACKAGE__->meta->perl_class_definition(indent => 2); # , braces => 'bsd'
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+
+BEGIN {
+ require Cwd;
+
+ my $dir = $0;
+ $dir = Cwd::getcwd() . '/' . $dir unless $dir =~ m|^/|;
+ $dir =~ s|[^/]+$|..|;
+
+ chdir($dir) || die "Cannot change directory to ${dir}\n";
+
+ unshift @INC, "modules/override"; # Use our own versions of various modules (e.g. YAML).
+ push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version.
+}
+
+use CGI qw( -no_xhtml);
+use Config::Std;
+use Cwd;
+use Daemon::Generic;
+use Data::Dumper;
+use DateTime;
+use English qw(-no_match_vars);
+use POSIX qw(setuid setgid);
+use SL::Auth;
+use SL::DB::BackgroundJob;
+use SL::BackgroundJob::ALL;
+use SL::Form;
+use SL::Helper::DateTime;
+use SL::LXDebug;
+use SL::Locale;
+
+my %config;
+
+# this is a cleaned up version of am.pl
+# it lacks redirection, some html setup and most of the authentication process.
+# it is assumed that anyone with physical access and execution rights on this script
+# won't be hindered by authentication anyway.
+sub lxinit {
+ my $login = $config{task_server}->{login};
+
+ package main;
+
+ { no warnings 'once';
+ $::userspath = "users";
+ $::templates = "templates";
+ $::sendmail = "| /usr/sbin/sendmail -t";
+ }
+
+ eval { require "config/lx-erp.conf"; 1; } or die $EVAL_ERROR;
+ eval { require "config/lx-erp-local.conf"; 1; } or die $EVAL_ERROR if -f "config/lx-erp-local.conf";
+
+ $::lxdebug = LXDebug->new;
+ $::locale = Locale->new($::language);
+ $::cgi = CGI->new qw();
+ $::form = Form->new;
+ $::auth = SL::Auth->new;
+
+ die 'cannot reach auth db' unless $::auth->session_tables_present;
+
+ $::auth->restore_session;
+
+ require "bin/mozilla/common.pl";
+
+ die "cannot find user $login" unless %::myconfig = $::auth->read_user($login);
+ die "cannot find locale for user $login" unless $::locale = Locale->new('de');
+}
+
+sub drop_privileges {
+ my $user = $::emmvee_conf{task_server}->{run_as};
+ return unless $user;
+
+ my ($uid, $gid);
+ while (my @details = getpwent()) {
+ next unless $details[0] eq $user;
+ ($uid, $gid) = @details[2, 3];
+ last;
+ }
+ endpwent();
+
+ if (!$uid) {
+ print "Error: Cannot drop privileges to ${user}: user does not exist\n";
+ exit 1;
+ }
+
+ if (!setgid($gid)) {
+ print "Error: Cannot drop group privileges to ${user} (group ID $gid): $!\n";
+ exit 1;
+ }
+
+ if (!setuid($uid)) {
+ print "Error: Cannot drop user privileges to ${user} (user ID $uid): $!\n";
+ exit 1;
+ }
+}
+
+sub gd_preconfig {
+ my $self = shift;
+
+ read_config $self->{configfile} => %config;
+
+ die "Missing section [task_server] in config file" unless $config{task_server};
+ die "Missing key 'login' in section [task_server] in config file" unless $config{task_server}->{login};
+
+ drop_privileges();
+ lxinit();
+
+ return ();
+}
+
+sub gd_run {
+ while (1) {
+ my $ok = eval {
+ $::lxdebug->message(0, "Retrieving jobs") if $config{task_server}->{debug};
+
+ my $jobs = SL::DB::Manager::BackgroundJob->get_all_need_to_run;
+
+ $::lxdebug->message(0, " Found: " . join(' ', map { $_->package_name } @{ $jobs })) if $config{task_server}->{debug} && @{ $jobs };
+
+ foreach my $job (@{ $jobs }) {
+ # Provide fresh global variables in case legacy code modifies
+ # them somehow.
+ $::locale = Locale->new($::language);
+ $::form = Form->new;
+
+ $job->run;
+ }
+
+ 1;
+ };
+
+ if ($config{task_server}->{debug}) {
+ $::lxdebug->message(0, "Exception during execution: ${EVAL_ERROR}") if !$ok;
+ $::lxdebug->message(0, "Sleeping");
+ }
+
+ my $seconds = 60 - (localtime)[0];
+ sleep($seconds < 30 ? $seconds + 60 : $seconds);
+ }
+}
+
+my $cwd = getcwd();
+my $pidbase = "${cwd}/users/pid";
+
+mkdir($pidbase) if !-d $pidbase;
+
+newdaemon(configfile => "${cwd}/config/task_server.conf",
+ progname => 'lx-office-task-server',
+ pidbase => "${pidbase}/",
+ );
+
+1;
--- /dev/null
+-- @tag: emmvee_background_jobs
+-- @description: Tabellen für Hintergrundjobs
+-- @depends: release_2_6_1
+-- @charset: utf-8
+
+CREATE TABLE background_jobs (
+ id serial NOT NULL,
+ type character varying(255),
+ package_name character varying(255),
+ last_run_at timestamp without time zone,
+ next_run_at timestamp without time zone,
+ data text,
+ active boolean,
+ cron_spec character varying(255),
+
+ PRIMARY KEY (id)
+);
+
+CREATE TABLE background_job_histories (
+ id serial NOT NULL,
+ package_name character varying(255),
+ run_at timestamp without time zone,
+ status character varying(255),
+ result text,
+ error text,
+ data text,
+
+ PRIMARY KEY (id)
+);
--- /dev/null
+#!/usr/bin/perl
+# @tag: emmvee_background_jobs_2
+# @description: Hintergrundjobs einrichten
+# @depends: emmvee_background_jobs
+# @charset: utf-8
+
+use strict;
+
+use SL::BackgroundJob::CleanBackgroundJobHistory;
+
+SL::BackgroundJob::CleanBackgroundJobHistory->create_job;
+
+1;
--- /dev/null
+-- @tag: periodic_invoices
+-- @description: Neue Tabellen und Spalten für Wiederkehrende Rechnungen
+-- @depends: release_2_6_1
+CREATE TABLE periodic_invoices_configs (
+ id integer NOT NULL DEFAULT nextval('id'),
+ oe_id integer NOT NULL,
+ periodicity varchar(10) NOT NULL,
+ print boolean DEFAULT 'f',
+ printer_id integer,
+ copies integer,
+ active boolean DEFAULT 't',
+ terminated boolean DEFAULT 'f',
+ start_date date,
+ end_date date,
+ ar_chart_id integer NOT NULL,
+ extend_automatically_by integer,
+
+ PRIMARY KEY (id),
+ FOREIGN KEY (oe_id) REFERENCES oe (id),
+ FOREIGN KEY (printer_id) REFERENCES printers (id),
+ FOREIGN KEY (ar_chart_id) REFERENCES chart (id)
+);
+
+CREATE TABLE periodic_invoices (
+ id integer NOT NULL DEFAULT nextval('id'),
+ config_id integer NOT NULL,
+ ar_id integer NOT NULL,
+ period_start_date date NOT NULL,
+ itime timestamp DEFAULT now(),
+
+ PRIMARY KEY (id),
+ FOREIGN KEY (config_id) REFERENCES periodic_invoices_configs (id),
+ FOREIGN KEY (ar_id) REFERENCES ar (id)
+);
--- /dev/null
+# @tag: periodic_invoices_background_job
+# @description: Hintergrundjob zum Erzeugen wiederkehrender Rechnungen
+# @depends: periodic_invoices
+# @charset: utf-8
+
+use strict;
+
+use SL::BackgroundJob::CreatePeriodicInvoices;
+
+SL::BackgroundJob::CreatePeriodicInvoices->create_job;
+
+1;
--- /dev/null
+[% USE HTML %]
+[% USE LxERP %]
+[% USE L %]
+<body>
+
+ <div class="listtop">[% title %]</div>
+
+ <form name="Form" action="oe.pl" method="post">
+
+ <p>
+ <table border="0">
+ <tr>
+ <th align="right">[% LxERP.t8('Status') %]</th>
+ <td>[% L.checkbox_tag("active", checked => active, label => LxERP.t8('Active')) %]</td>
+ </tr>
+
+ <tr>
+ <td> </td>
+ <td>
+ [% L.checkbox_tag('terminated', label => LxERP.t8('terminated'), checked => terminated) %]
+ </td>
+ </tr>
+
+ <tr>
+ <th align="right" valign="top">[%- LxERP.t8('Periodicity') %]</th>
+ <td valign="top">
+ [% L.radio_button_tag("periodicity", value => "m", label => LxERP.t8("monthly"), checked => periodicity == 'm') %]
+ <br>
+ [% L.radio_button_tag("periodicity", value => "q", label => LxERP.t8("quarterly"), checked => periodicity == 'q') %]
+ <br>
+ [% L.radio_button_tag("periodicity", value => "y", label => LxERP.t8("yearly"), checked => periodicity == 'y') %]
+ </td>
+ </tr>
+
+ <tr>
+ <th align="right">[%- LxERP.t8('Start date') %]</th>
+ <td valign="top">
+ [% L.date_tag("start_date_as_date", start_date_as_date) %]
+ </td>
+ </tr>
+
+ <tr>
+ <th align="right">[%- LxERP.t8('End date') %]<sup>(1)</sup></th>
+ <td valign="top">
+ [% L.date_tag("end_date_as_date", end_date_as_date) %]
+ </td>
+ </tr>
+
+ <tr>
+ <th align="right">[% LxERP.t8('Extend automatically by n months') %]</th>
+ <td valign="top">
+ [% L.input_tag("extend_automatically_by", extend_automatically_by, size => 10) %]
+ </td>
+ </tr>
+
+ <tr>
+ <th align="right">[%- LxERP.t8('Record in') %]</th>
+ <td valign="top">
+ [% L.select_tag("ar_chart_id", L.options_for_select(AR, title => 'description', default => ar_chart_id)) %]
+ </td>
+ </tr>
+
+ <tr>
+ <th align="right">[%- LxERP.t8('Print automatically') %]</th>
+ <td valign="top">
+ [% L.checkbox_tag("print", onclick => "toggle_printer_id_ctrl()", checked => print) %]
+ </td>
+ </tr>
+
+ <tr>
+ <th align="right">[%- LxERP.t8('Printer') %]</th>
+ <td valign="top">
+ [% L.select_tag("printer_id", L.options_for_select(ALL_PRINTERS, title => 'printer_description', default => printer_id), disabled => !print) %]
+ </td>
+ </tr>
+
+ <tr>
+ <th align="right">[%- LxERP.t8('Copies') %]</th>
+ <td valign="top">[% L.input_tag("copies", copies, size => 6, disabled => !print) %]</td>
+ </tr>
+ </table>
+ </p>
+
+ <hr>
+
+ <p>(1): [%- LxERP.t8('The end date is the last day for which invoices will possibly be created.') %]</p>
+
+ [% L.hidden_tag('action', 'save_periodic_invoices_config') %]
+
+ <p>
+ [% L.submit_tag('', LxERP.t8('Close')) %]
+ [% L.submit_tag('', LxERP.t8('Cancel'), onclick => "self.close(); return false;") %]
+ </p>
+ </form>
+
+ <script type="text/javascript">
+ <!--
+ function toggle_printer_id_ctrl() {
+ var disabled = !$('#print').attr('checked');
+ $('#printer_id').attr('disabled', disabled);
+ $('#copies').attr('disabled', disabled);
+ }
+ -->
+ </script>
+
+</body>
+</html>
[%- USE T8 %]
[%- USE HTML %]
[%- USE LxERP %]
+[%- USE L %]
<tr>
<td>
<table width="100%">
show_empty = 1 -%]
</td>
</tr>
+
+[%- IF is_sales_ord %]
+ <tr>
+ <th align="right">[%- LxERP.t8('Periodic Invoices') %]</th>
+ <td>
+ [% L.button_tag("edit_periodic_invoices_config(); return false;", LxERP.t8('Configure')) %]
+ ([% HTML.escape(periodic_invoices_status) %])
+ [% L.hidden_tag("periodic_invoices_config", periodic_invoices_config) %]
+ </td>
+ </tr>
+[%- END %]
+
[%- IF id && num_follow_ups %]
<tr>
<td colspan="2">[% LxERP.t8('There are #1 unfinished follow-ups of which #2 are due.', num_follow_ups, num_due_follow_ups) %]</td>
[%- USE T8 %]
[%- USE HTML %]
[%- USE LxERP %]
+[%- USE L %]
<body onLoad="[% onload %]">
<form method="post" name="oe" action="[% script %]">
<script type="text/javascript" src="js/calculate_qty.js"></script>
<script type="text/javascript" src="js/customer_or_vendor_selection.js"></script>
<script type="text/javascript" src="js/follow_up.js"></script>
+ [%- IF is_sales_ord %]
+ [% L.javascript_tag("js/edit_periodic_invoices_config") %]
+ [%- END %]
[%- FOREACH row = HIDDENS %]
<input type="hidden" name="[% HTML.escape(row.name) %]" value="[% HTML.escape(row.value) %]" >
--- /dev/null
+Sehr geehrter Benutzer,
+
+die folgenden wiederkehrenden Rechnungen wurden automatisch erzeugt:
+
+[% FOREACH inv = POSTED_INVOICES %][% inv.invnumber %] [% END %]
+
+[% IF PRINTED_INVOICES.size -%]
+Davon wurden die folgenden Rechnungen automatisch ausgedruckt:
+
+[% FOREACH inv = PRINTED_INVOICES %][% inv.invnumber %] [% END %]
+[%- END %]
--- /dev/null
+[% USE HTML %]
+[% USE L %]
+<body onload="copy_values_and_close()">
+
+ <script type="text/javascript">
+ <!--
+ function copy_values_and_close() {
+ window.opener.document.getElementsByName("periodic_invoices_config")[0].value = $("#periodic_invoices_config").attr('value');
+ window.close();
+ }
+ -->
+ </script>
+
+ <form name="Form">
+ [% L.hidden_tag("periodic_invoices_config", periodic_invoices_config) %]
+ </form>
+
+</body>
+</html>
[%- USE HTML %]
[%- USE T8 %]
[%- USE LxERP %]
+[%- USE L %]
[%- SET vclabel = vc == 'customer' ? LxERP.t8('Customer') : LxERP.t8('Vendor') %]
[%- SET vcnumberlabel = vc == 'customer' ? LxERP.t8('Customer Number') : LxERP.t8('Vendor Number') %]
<body>
<label for="delivered">[% 'Delivered' | $T8 %]</label>
</td>
</tr>
+[%- END %]
+[%- IF type == 'sales_order' %]
+ <tr>
+ <td>
+ [% L.checkbox_tag("periodic_invoices_active", label => LxERP.t8("Periodic invoices active")) %]
+ </td>
+ <td>
+ [% L.checkbox_tag("periodic_invoices_inactive", label => LxERP.t8("Periodic invoices inactive")) %]
+ </td>
+ </tr>
[%- END %]
<tr>
<td>
projects / kivitendo-erp.git / commitdiff