crm
/users/datev-export*
/users/templates-cache/
+/users/pid/
+/config/lx_office.conf
set_user_rights() {
chown -R www-data:www-data /usr/lib/lx-office-erp/users
chown -R www-data:www-data /usr/lib/lx-office-erp/templates
- chown www-data:www-data /etc/lx-office-erp/lx-erp.conf
+ chown www-data:www-data /etc/lx-office-erp/lx_office.conf
chown www-data:www-data /usr/lib/lx-office-erp/menu.ini
chown www-data:www-data /etc/lx-office-erp/authentication.pl
- chmod 0600 /etc/lx-office-erp/lx-erp.conf
+ chmod 0600 /etc/lx-office-erp/lx_office.conf
chmod 0600 /etc/lx-office-erp/authentication.pl
}
}
mk_new_menu() {
- if [ -e /usr/lib/lx-office-crm ] ; then
+ if [ -e /usr/lib/lx-office-crm ] ; then
#crm vorhanden, dann die menu.ini mit der höchsten VersNr nehmen
- for i in `ls -1 /usr/lib/lx-office-crm/update/menu*ini` ; do
+ for i in `ls -1 /usr/lib/lx-office-crm/update/menu*ini` ; do
cat $i > /usr/lib/lx-office-erp/menu.ini
done;
cat /usr/lib/lx-office-erp/menu.default >> /usr/lib/lx-office-erp/menu.ini
else
cp /usr/lib/lx-office-erp/menu.default /usr/lib/lx-office-erp/menu.ini
fi
-}
+}
mk_new_config() {
- if ! [ -f /etc/lx-office-erp/lx-erp.conf ] ; then
- cp /etc/lx-office-erp/lx-erp.conf.default /etc/lx-office-erp/lx-erp.conf
- fi
- if ! [ -f /etc/lx-office-erp/console.conf ] ; then
- cp /etc/lx-office-erp/console.conf.default /etc/lx-office-erp/console.conf
+ if ! [ -f /etc/lx-office-erp/lx_office.conf ] ; then
+ cp /etc/lx-office-erp/lx_office.conf.default /etc/lx-office-erp/lx_office.conf
fi
-}
+}
mk_links() {
if ! [ -f /usr/lib/lx-office-erp/config/authentication.pl ] ; then
ln -s /etc/lx-office-erp/authentication.pl /usr/lib/lx-office-erp/config/authentication.pl
fi;
- if ! [ -f /usr/lib/lx-office-erp/config/lx-erp.conf ] ; then
- ln -s /etc/lx-office-erp/lx-erp.conf /usr/lib/lx-office-erp/config/lx-erp.conf
+ if ! [ -f /usr/lib/lx-office-erp/config/lx_office.conf ] ; then
+ ln -s /etc/lx-office-erp/lx_office.conf /usr/lib/lx-office-erp/config/lx_office.conf
fi;
- if ! [ -f /usr/lib/lx-office-erp/config/console.conf ] ; then
- ln -s /etc/lx-office-erp/console.conf /usr/lib/lx-office-erp/config/console.conf
- fi;
- if [ -e /etc/apache2 ] ; then
+ if [ -e /etc/apache2 ] ; then
if ! [ -f /etc/apache2/conf.d/lx-office-erp.apache2.conf ] ; then
ln -s /etc/lx-office-erp/lx-office-erp.apache2.conf /etc/apache2/conf.d/lx-office-erp.apache2.conf
fi;
fi;
- if [ -e /etc/cherokee/sites-available ] ; then
+ if [ -e /etc/cherokee/sites-available ] ; then
if ! [ -f /etc/cherokee/sites-available/lx-office-erp.cherokee ] ; then
cat /etc/lx-office-erp/lx-office-erp.cherokee.handler >> /etc/cherokee/sites-available/default
ln -s /etc/lx-office-erp/lx-office-erp.cherokee /etc/cherokee/sites-available/lx-office-erp.cherokee
fi;
}
reload_web_server() {
- if [ -f /etc/init.d/apache* ] ; then
+ if [ -f /etc/init.d/apache* ] ; then
/etc/init.d/apache* reload
fi
- if [ -f /etc/init.d/cherokee ] ; then
+ if [ -f /etc/init.d/cherokee ] ; then
/etc/init.d/cherokee reload
fi
if [ -f /etc/init.d/lighttpd ] ; then
install|configure)
echo " ! "`date`" $1 !" >> /tmp/lxo-erp.log
-
+
mk_new_menu
mk_new_config
config_postgresql_factory_script
cp -a $SRC/*.pl usr/lib/lx-office-erp
cp $SRC/VERSION usr/lib/lx-office-erp
cp $SRC/index.html usr/lib/lx-office-erp
-cp $SRC/config/lx-erp.conf etc/lx-office-erp/lx-erp.conf.default
-cp $SRC/config/console.conf.default etc/lx-office-erp/
+cp $SRC/config/lx_office.conf.default etc/lx-office-erp/lx_office.conf.default
cp $SRC/config/authentication.pl.default etc/lx-office-erp/
cp $SRC/menu.ini usr/lib/lx-office-erp/menu.default
cp -a $SRC/css var/lib/lx-office-erp
sub save_preferences {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $form, $webdav) = @_;
+ my ($self, $myconfig, $form) = @_;
my $dbh = $form->get_standard_dbh($myconfig);
$myconfig->{$item} = $form->{$item};
}
- $myconfig->save_member($main::memberfile);
+ $myconfig->save_member;
my $auth = $main::auth;
- if ($auth->can_change_password()
- && defined $form->{new_password}
- && ($form->{new_password} ne '********')) {
- $auth->change_password($form->{login}, $form->{new_password});
-
- $form->{password} = $form->{new_password};
- $auth->set_session_value('password', $form->{password});
- $auth->create_or_refresh_session();
- }
-
$main::lxdebug->leave_sub();
return $rc;
sub delete_transaction {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $form, $spool) = @_;
+ my ($self, $myconfig, $form) = @_;
# connect to database
my $dbh = $form->dbconnect_noauto($myconfig);
sub _read_auth_config {
$main::lxdebug->enter_sub();
- my $self = shift;
-
- my $code;
- my $in = IO::File->new('config/authentication.pl', 'r');
-
- if (!$in) {
- my $locale = Locale->new('en');
- $self->mini_error($locale->text('The config file "config/authentication.pl" was not found.'));
- }
-
- while (<$in>) {
- $code .= $_;
- }
- $in->close();
-
- eval $code;
+ my $self = shift;
- if ($@) {
- my $locale = Locale->new('en');
- $self->mini_error($locale->text('The config file "config/authentication.pl" contained invalid Perl code:'), $@);
- }
+ map { $self->{$_} = $::lx_office_conf{authentication}->{$_} } keys %{ $::lx_office_conf{authentication} };
+ $self->{DB_config} = $::lx_office_conf{'authentication/database'};
+ $self->{LDAP_config} = $::lx_office_conf{'authentication/ldap'};
if ($self->{module} eq 'DB') {
$self->{authenticator} = SL::Auth::DB->new($self);
if (!$self->{authenticator}) {
my $locale = Locale->new('en');
- $self->mini_error($locale->text('No or an unknown authenticantion module specified in "config/authentication.pl".'));
+ $self->mini_error($locale->text('No or an unknown authenticantion module specified in "config/lx_office.conf".'));
}
my $cfg = $self->{DB_config};
if (!$cfg) {
my $locale = Locale->new('en');
- $self->mini_error($locale->text('config/authentication.pl: Key "DB_config" is missing.'));
+ $self->mini_error($locale->text('config/lx_office.conf: Key "DB_config" is missing.'));
}
if (!$cfg->{host} || !$cfg->{db} || !$cfg->{user}) {
my $locale = Locale->new('en');
- $self->mini_error($locale->text('config/authentication.pl: Missing parameters in "DB_config". Required parameters are "host", "db" and "user".'));
+ $self->mini_error($locale->text('config/lx_office.conf: Missing parameters in "authentication/database". Required parameters are "host", "db" and "user".'));
}
$self->{authenticator}->verify_config();
$main::lxdebug->message(LXDebug->DEBUG1(), "Auth::create_database DSN: $dsn");
- my $charset = $main::dbcharset;
+ my $charset = $::lx_office_conf{system}->{dbcharset};
$charset ||= Common::DEFAULT_CHARSET;
my $encoding = $Common::charset_to_db_encoding{$charset};
$encoding ||= 'UNICODE';
my $self = shift;
my $dbh = $self->dbconnect();
- my $charset = $main::dbcharset;
+ my $charset = $::lx_office_conf{system}->{dbcharset};
$charset ||= Common::DEFAULT_CHARSET;
$dbh->rollback();
$self->{ldap} = Net::LDAP->new($cfg->{host}, 'port' => $port);
if (!$self->{ldap}) {
- $main::form->error($main::locale->text('The LDAP server "#1:#2" is unreachable. Please check config/authentication.pl.', $cfg->{host}, $port));
+ $main::form->error($main::locale->text('The LDAP server "#1:#2" is unreachable. Please check config/lx_office.conf.', $cfg->{host}, $port));
}
if ($cfg->{tls}) {
my $mesg = $self->{ldap}->start_tls('verify' => 'none');
if ($mesg->is_error()) {
- $main::form->error($main::locale->text('The connection to the LDAP server cannot be encrypted (SSL/TLS startup failure). Please check config/authentication.pl.'));
+ $main::form->error($main::locale->text('The connection to the LDAP server cannot be encrypted (SSL/TLS startup failure). Please check config/lx_office.conf.'));
}
}
if ($cfg->{bind_dn}) {
my $mesg = $self->{ldap}->bind($cfg->{bind_dn}, 'password' => $cfg->{bind_password});
if ($mesg->is_error()) {
- $main::form->error($main::locale->text('Binding to the LDAP server as "#1" failed. Please check config/authentication.pl.', $cfg->{bind_dn}));
+ $main::form->error($main::locale->text('Binding to the LDAP server as "#1" failed. Please check config/lx_office.conf.', $cfg->{bind_dn}));
}
}
my $cfg = $self->{auth}->{LDAP_config};
if (!$cfg) {
- $form->error($locale->text('config/authentication.pl: Key "LDAP_config" is missing.'));
+ $form->error($locale->text('config/lx_office.conf: Key "authentication/ldap" is missing.'));
}
if (!$cfg->{host} || !$cfg->{attribute} || !$cfg->{base_dn}) {
- $form->error($locale->text('config/authentication.pl: Missing parameters in "LDAP_config". Required parameters are "host", "attribute" and "base_dn".'));
+ $form->error($locale->text('config/lx_office.conf: Missing parameters in "authentication/ldap". Required parameters are "host", "attribute" and "base_dn".'));
}
$main::lxdebug->leave_sub();
--- /dev/null
+package SL::Auth::PasswordPolicy;
+
+use strict;
+
+use parent qw(Rose::Object);
+
+use constant OK => 0;
+use constant TOO_SHORT => 1;
+use constant TOO_LONG => 2;
+use constant MISSING_LOWERCASE => 4;
+use constant MISSING_UPPERCASE => 8;
+use constant MISSING_DIGIT => 16;
+use constant MISSING_SPECIAL_CHAR => 32;
+use constant INVALID_CHAR => 64;
+use constant WEAK => 128;
+
+use Rose::Object::MakeMethods::Generic
+(
+ 'scalar --get_set_init' => 'config',
+);
+
+sub verify {
+ my ($self, $password, $is_admin) = @_;
+
+ my $cfg = $self->config;
+ return OK() unless $cfg && %{ $cfg };
+ return OK() if $is_admin && $cfg->{disable_policy_for_admin};
+
+ my $result = OK();
+ $result |= TOO_SHORT() if $cfg->{min_length} && (length($password) < $cfg->{min_length});
+ $result |= TOO_LONG() if $cfg->{max_length} && (length($password) > $cfg->{max_length});
+ $result |= MISSING_LOWERCASE() if $cfg->{require_lowercase} && $password !~ m/[a-z]/;
+ $result |= MISSING_UPPERCASE() if $cfg->{require_uppercase} && $password !~ m/[A-Z]/;
+ $result |= MISSING_DIGIT() if $cfg->{require_digit} && $password !~ m/[0-9]/;
+ $result |= MISSING_SPECIAL_CHAR() if $cfg->{require_special_character} && $password !~ $cfg->{special_characters_re};
+ $result |= INVALID_CHAR() if $cfg->{invalid_characters_re} && $password =~ $cfg->{invalid_characters_re};
+
+ if ($cfg->{use_cracklib}) {
+ require Crypt::Cracklib;
+ $result |= WEAK() if !Crypt::Cracklib::check($password);
+ }
+
+ return $result;
+}
+
+sub errors {
+ my ($self, $result) = @_;
+
+ my @errors;
+
+ push @errors, $::locale->text('The password is too short (minimum length: #1).', $self->config->{min_length}) if $result & TOO_SHORT();
+ push @errors, $::locale->text('The password is too long (maximum length: #1).', $self->config->{max_length}) if $result & TOO_LONG();
+ push @errors, $::locale->text('A lower-case character is required.') if $result & MISSING_LOWERCASE();
+ push @errors, $::locale->text('An upper-case character is required.') if $result & MISSING_UPPERCASE();
+ push @errors, $::locale->text('A digit is required.') if $result & MISSING_DIGIT();
+ push @errors, $::locale->text('The password is weak (e.g. it can be found in a dictionary).') if $result & WEAK();
+
+ if ($result & MISSING_SPECIAL_CHAR()) {
+ my $char_list = join ' ', sort split(m//, $self->config->{special_characters});
+ push @errors, $::locale->text('A special character is required (valid characters: #1).', $char_list);
+ }
+
+ if (($result & INVALID_CHAR())) {
+ my $char_list = join ' ', sort split(m//, $self->config->{ $self->config->{invalid_characters} ? 'invalid_characters' : 'valid_characters' });
+ push @errors, $::locale->text('An invalid character was used (invalid characters: #1).', $char_list) if $self->config->{invalid_characters};
+ push @errors, $::locale->text('An invalid character was used (valid characters: #1).', $char_list) if $self->config->{valid_characters};
+ }
+
+ return @errors;
+}
+
+
+sub init_config {
+ my ($self) = @_;
+
+ my %cfg = %{ $::emmvee_conf{password_policy} || {} };
+
+ $cfg{valid_characters} =~ s/[ \n\r]//g if $cfg{valid_characters};
+ $cfg{invalid_characters} =~ s/[ \n\r]//g if $cfg{invalid_characters};
+ $cfg{invalid_characters_re} = '[^' . quotemeta($cfg{valid_characters}) . ']' if $cfg{valid_characters};
+ $cfg{invalid_characters_re} = '[' . quotemeta($cfg{invalid_characters}) . ']' if $cfg{invalid_characters};
+ $cfg{special_characters} = '!@#$%^&*()_+=[]{}<>\'"|\\,;.:?-';
+ $cfg{special_characters_re} = '[' . quotemeta($cfg{special_characters}) . ']';
+
+ map { $cfg{"require_${_}"} = $cfg{"require_${_}"} =~ m/^(?:1|true|t|yes|y)$/i } qw(lowercase uppercase digit special_char);
+
+ $self->config(\%cfg);
+}
+
+1;
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::Auth::PasswordPolicy - Verify a given password against the policy
+set in the configuration file
+
+=head1 SYNOPSIS
+
+ my $verifier = SL::Auth::PasswordPolicy->new;
+ my $result = $verifier->verify($password);
+ if ($result != SL::Auth::PasswordPolicy->OK()) {
+ print "Errors: " . join(' ', $verifier->errors($result)) . "\n";
+ }
+
+=head1 CONSTANTS
+
+=over 4
+
+=item C<OK>
+
+Password is OK.
+
+=item C<TOO_SHORT>
+
+The password is too short.
+
+=item C<TOO_LONG>
+
+The password is too long.
+
+=item C<MISSING_LOWERCASE>
+
+The password is missing a lower-case character.
+
+=item C<MISSING_UPPERCASE>
+
+The password is missing an upper-case character.
+
+=item C<MISSING_DIGIT>
+
+The password is missing a digit.
+
+=item C<MISSING_SPECIAL_CHAR>
+
+The password is missing a special character. Special characters are
+the following: ! " # $ % & ' ( ) * + , - . : ; E<lt> = E<gt> ? @ [ \ ]
+^ _ { | }
+
+=item C<INVALID_CHAR>
+
+The password contains an invalid character.
+
+=back
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<verify $password, $is_admin>
+
+Checks whether or not the password matches the policy. Returns C<OK()>
+if it does and an error code otherwise (binary or'ed of the error
+constants).
+
+If C<$is_admin> is trueish and the configuration specifies that the
+policy checks are disabled for the administrator then C<verify> will
+always return C<OK()>.
+
+=item C<errors $code>
+
+Returns an array of human-readable strings describing the issues set
+in C<$code> which should be the result of L</verify>.
+
+=back
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
sub delete_spool {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $form, $spool) = @_;
+ my ($self, $myconfig, $form) = @_;
+
+ my $spool = $::lx_office_conf{paths}->{spool};
# connect to database, turn AutoCommit off
my $dbh = $form->dbconnect_noauto($myconfig);
sub print_spool {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $form, $spool, $output) = @_;
+ my ($self, $myconfig, $form, $output) = @_;
+
+ my $spool = $::lx_office_conf{paths}->{spool};
# connect to database
my $dbh = $form->dbconnect($myconfig);
--- /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) = @_;
+
+ my %config = %::lx_office_conf;
+
+ 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);
+ 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;
delete $form->{OUT};
- $form->parse_template($myconfig, $main::userspath);
+ $form->parse_template($myconfig);
$main::lxdebug->leave_sub();
}
my ($form) = @_;
return $main::lxdebug->leave_sub()
- unless ($main::webdav && $form->{id});
+ unless ($::lx_office_conf{system}->{webdav} && $form->{id});
my ($path, $number);
my $content_type = $options->{type} eq 'js' ? 'text/javascript' : 'text/html';
print $::form->create_http_response(content_type => $content_type,
- charset => $::dbcharset || Common::DEFAULT_CHARSET());
+ charset => $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET());
} else {
$::form->{title} = $locals{title} if $locals{title};
AUTH => $::auth,
FORM => $::form,
LOCALE => $::locale,
- LXCONFIG => { dbcharset => $::dbcharset,
- webdav => $::webdav,
- lizenzen => $::lizenzen,
- latex_templates => $::latex,
- opendocument_templates => $::opendocument_templates,
- vertreter => $::vertreter,
- show_best_before => $::show_best_before,
- },
+ LXCONFIG => \%::lx_office_conf,
LXDEBUG => $::lxdebug,
MYCONFIG => \%::myconfig,
SELF => $self,
PLUGIN_BASE => 'SL::Template::Plugin',
INCLUDE_PATH => '.:templates/webpages',
COMPILE_EXT => '.tcc',
- COMPILE_DIR => $::userspath . '/templates-cache',
+ COMPILE_DIR => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
}) || croak;
return $self->{__basepriv_template_obj};
=item * C<LOCALE> -- C<$::locale>
-=item * C<LXCONFIG> -- all parameters from C<config/lx-erp.conf> with
-the same name they appear in the file (e.g. C<dbcharset>, C<webdav>
-etc)
+=item * C<LXCONFIG> -- all parameters from C<config/lx_office.conf>
+with the same name they appear in the file (first level is the
+section, second the actual variable, e.g. C<system.dbcharset>,
+C<features.webdav> etc)
=item * C<LXDEBUG> -- C<$::lxdebug>
my $path;
if ($token =~ m|^(\d+)-(\d+)-(\d+)$|) {
- $path = "${main::userspath}/datev-export-${1}-${2}-${3}";
+ $path = $::lx_office_conf{paths}->{userspath} . "/datev-export-${1}-${2}-${3}";
}
$main::lxdebug->leave_sub();
sub clean_temporary_directories {
$main::lxdebug->enter_sub();
- foreach my $path (glob "${main::userspath}/datev-export-*") {
+ foreach my $path (glob($::lx_office_conf{paths}->{userspath} . "/datev-export-*")) {
next unless (-d $path);
my $mtime = (stat($path))[9];
my (%_db_registered, %_initial_sql_executed);
+sub dbi_connect {
+ shift;
+
+ return DBI->connect(@_) unless $::lx_office_conf{debug} && $::lx_office_conf{debug}->{dbix_log4perl};
+
+ require Log::Log4perl;
+ require DBIx::Log4perl;
+
+ my $filename = $LXDebug::file_name;
+ my $config = $::lx_office_conf{debug}->{dbix_log4perl_config};
+ $config =~ s/LXDEBUGFILE/${filename}/g;
+
+ Log::Log4perl->init(\$config);
+ return DBIx::Log4perl->connect(@_);
+}
+
sub create {
my $domain = shift || SL::DB->default_domain;
my $type = shift || SL::DB->default_type;
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} ? 1 : 0;
+ my $format_notnull = $params{format_amounts} ? 2 : 0;
+ foreach my $item (@{ $self->items }) {
+ next if _has($item, 'assemblyitem');
+
+ $idx++;
+
+ $form->{"id_${idx}"} = $item->parts_id;
+ $form->{"partnumber_${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 marge_total marge_percent lastcost));
+ _copy($item, $form, '', "_${idx}", $format_notnull, qw(discount));
+ _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) = @_;
+
+ @columns = grep { $src->can($_) } @columns;
+
+ map { $form->{"${prefix}${_}${postfix}"} = ref($src->$_) eq 'DateTime' ? $src->$_->to_lxoffice : $src->$_ } @columns if !$format_amounts;
+ map { $form->{"${prefix}${_}${postfix}"} = $::form->format_amount(\%::myconfig, $src->$_ * 1, 2) } @columns if $format_amounts == 1;
+ map { $form->{"${prefix}${_}${postfix}"} = $src->$_ * 1 ? $::form->format_amount(\%::myconfig, $src->$_ * 1, 2) : 0 } @columns if $format_amounts == 2;
+
+ 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
sub get_first {
shift->get_all(
+ @_,
limit => 1,
)->[0];
}
-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;
+ }
+
+ if ($taxkey->tax->chart_id) {
+ $data->{taxes}->{ $taxkey->tax->chart_id } ||= 0;
+ $data->{taxes}->{ $taxkey->tax->chart_id } += $tax_amount;
+ } elsif ($tax_amount) {
+ die "tax_amount != 0 but no chart_id for taxkey " . $taxkey->id . " tax " . $taxkey->tax->id;
+ }
+
+ $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 $::lx_office_conf{system}->{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 $::lx_office_conf{system}->{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(LXDebug->WARN(), "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
+(see config/lx_office.conf, section "system", variable "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 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;
+
+our @PERIODICITIES = qw(m q f b y);
+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;
return 0 if !@unapplied_scripts;
- my $db_charset = $main::dbcharset || Common::DEFAULT_CHARSET;
+ my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
$self->{form}->{login} ||= 'admin';
map { $_->{description} = SL::Iconv::convert($_->{charset}, $db_charset, $_->{description}) } values %{ $self->{all_controls} };
sub save_dunning {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $form, $rows, $userspath, $spool) = @_;
+ my ($self, $myconfig, $form, $rows) = @_;
# connect to database
my $dbh = $form->dbconnect_noauto($myconfig);
$copies *= 1;
$copies = 1 unless $copies;
- my $inputfiles = join " ", map { "${main::spool}/$_ " x $copies } @{ $form->{DUNNING_PDFS} };
+ my $spool = $::lx_office_conf{paths}->{spool};
+ my $inputfiles = join " ", map { "$spool/$_ " x $copies } @{ $form->{DUNNING_PDFS} };
my $dunning_id = $form->{dunning_id};
$dunning_id =~ s|[^\d]||g;
- my $in = IO::File->new("gs -dBATCH -dNOPAUSE -q -sDEVICE=pdfwrite -sOutputFile=- $inputfiles |");
+ my $in = IO::File->new($::lx_office_conf{applications}->{ghostscript} . " -dBATCH -dNOPAUSE -q -sDEVICE=pdfwrite -sOutputFile=- $inputfiles |");
$form->error($main::locale->text('Could not spawn ghostscript.')) unless $in;
if ($form->{media} eq 'printer') {
$in->close();
- map { unlink("${main::spool}/$_") } @{ $form->{DUNNING_PDFS} };
+ map { unlink("$spool/$_") } @{ $form->{DUNNING_PDFS} };
$main::lxdebug->leave_sub();
}
$self->set_template_options($myconfig, $form);
my $filename = "dunning_${dunning_id}_" . Common::unique_id() . ".pdf";
- $form->{OUT} = ">${main::spool}/$filename";
+ my $spool = $::lx_office_conf{paths}->{spool};
+ $form->{OUT} = ">${spool}/$filename";
$form->{keep_tmpfile} = 1;
delete $form->{tmpfile};
push @{ $form->{DUNNING_PDFS} }, $filename;
- push @{ $form->{DUNNING_PDFS_EMAIL} }, { 'filename' => "${main::spool}/$filename",
+ push @{ $form->{DUNNING_PDFS_EMAIL} }, { 'filename' => "${spool}/$filename",
'name' => "dunning_${dunning_id}.pdf" };
- $form->parse_template($myconfig, $main::userspath);
+ $form->parse_template($myconfig);
$dbh->disconnect() unless $provided_dbh;
my $filename = Common::unique_id() . "dunning_invoice_${dunning_id}.pdf";
- $form->{OUT} = ">$main::spool/$filename";
+ my $spool = $::lx_office_conf{paths}->{spool};
+ $form->{OUT} = ">$spool/$filename";
$form->{keep_tmpfile} = 1;
delete $form->{tmpfile};
map { delete $form->{$_} } grep /^[a-z_]+_\d+$/, keys %{ $form };
- $form->parse_template($myconfig, $main::userspath);
+ $form->parse_template($myconfig);
restore_form($saved_form);
push @{ $form->{DUNNING_PDFS} }, $filename;
- push @{ $form->{DUNNING_PDFS_EMAIL} }, { 'filename' => "${main::spool}/$filename",
+ push @{ $form->{DUNNING_PDFS_EMAIL} }, { 'filename' => "${spool}/$filename",
'name' => "dunning_invoice_${dunning_id}.pdf" };
$dbh->disconnect() unless $provided_dbh;
$form->{saved_donumber} = $form->{donumber};
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
$main::lxdebug->leave_sub();
my $myconfig = \%main::myconfig;
my $form = $main::form;
- my $spool = $main::spool;
+ my $spool = $::lx_office_conf{paths}->{spool};
# connect to database
my $dbh = $form->get_standard_dbh($myconfig);
$sth->finish();
}
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
$main::lxdebug->leave_sub();
}
use CGI qw( -no_xhtml);
+use Config::Std;
use DateTime;
+use Encode;
use English qw(-no_match_vars);
use SL::Auth;
use SL::LXDebug;
+use SL::LxOfficeConf;
use SL::Locale;
use SL::Common;
use SL::Form;
my $template = shift;
my $error_type = shift || '';
- $::locale = Locale->new($::language);
+ $::locale = Locale->new($::lx_office_conf{system}->{language});
$::form->{error} = $::locale->text('The session is invalid or has expired.') if ($error_type eq 'session');
$::form->{error} = $::locale->text('Incorrect password!.') if ($error_type eq 'password');
- $::myconfig{countrycode} = $::language;
+ $::myconfig{countrycode} = $::lx_office_conf{system}->{language};
$::form->{stylesheet} = 'css/lx-office-erp.css';
$::form->header;
}
sub pre_startup_setup {
- eval {
- package main;
- require "config/lx-erp.conf";
- };
- eval {
- package main;
- require "config/lx-erp-local.conf";
- } if -f "config/lx-erp-local.conf";
+ SL::LxOfficeConf->read;
+ _init_environment();
eval {
package main;
# canonial globals. if it's not here, chances are it will get refactored someday.
{
no warnings 'once';
- $::userspath = "users";
- $::templates = "templates";
- $::memberfile = "users/members";
- $::menufile = "menu.ini";
- $::sendmail = "| /usr/sbin/sendmail -t";
$::lxdebug = LXDebug->new;
$::auth = SL::Auth->new;
$::form = undef;
$self->unrequire_bin_mozilla;
$::cgi = CGI->new('');
- $::locale = Locale->new($::language);
+ $::locale = Locale->new($::lx_office_conf{system}->{language});
$::form = Form->new;
%::called_subs = ();
my $session_result = $::auth->restore_session;
$::auth->create_or_refresh_session;
- $::form->error($::locale->text('System currently down for maintenance!')) if -e "$::userspath/nologin" && $script ne 'admin';
+ $::form->error($::locale->text('System currently down for maintenance!')) if -e ($::lx_office_conf{paths}->{userspath} . "/nologin") && $script ne 'admin';
if ($script eq 'login' or $script eq 'admin' or $script eq 'kopf') {
$::form->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $::form->{version}";
$::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;
return $self->{interface} =~ m/f(?:ast)cgi/i ? $self->{request}->GetHandles() : (\*STDIN, \*STDOUT, \*STDERR);
}
+sub _init_environment {
+ my %key_map = ( lib => { name => 'PERL5LIB', append_path => 1 },
+ path => { name => 'PATH', append_path => 1 },
+ );
+ my $cfg = $::lx_office_conf{environment} || {};
+
+ while (my ($key, $value) = each %{ $cfg }) {
+ next unless $value;
+
+ my $info = $key_map{$key} || {};
+ $key = $info->{name} || $key;
+
+ if ($info->{append_path}) {
+ $value = ':' . $value unless $value =~ m/^:/ || !$ENV{$key};
+ $value = $ENV{$key} . $value;
+ }
+
+ $ENV{$key} = $value;
+ }
+}
+
package main;
use strict;
sub fix_print_and_internal_encoding_after_0_68 {
return if version->new("$FCGI::VERSION")->numify <= version->new("0.68")->numify;
- return if lc($::dbcharset) !~ m/^(?:utf-?8|unicode)$/;
+ return if lc($::lx_office_conf{system}->{dbcharset}) !~ m/^(?:utf-?8|unicode)$/;
my $encoder = Encode::find_encoding('UTF-8');
my $original_fcgi_print = \&FCGI::Stream::PRINT;
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;
$self->_request_to_hash($content);
}
- my $db_charset = $main::dbcharset;
+ my $db_charset = $::lx_office_conf{system}->{dbcharset};
$db_charset ||= Common::DEFAULT_CHARSET;
my $encoding = $self->{INPUT_ENCODING} || $db_charset;
$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);
# extra code is currently only used by menuv3 and menuv4 to set their css.
# it is strongly deprecated, and will be changed in a future version.
my ($self, $extra_code) = @_;
- my $db_charset = $::dbcharset || Common::DEFAULT_CHARSET;
+ my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
my @header;
$::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
my ($self) = @_;
- my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
+ my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
my $cgi = $main::cgi || CGI->new('');
my $output = $cgi->header('-charset' => $db_charset);
my $language;
if (!%::myconfig || !$::myconfig{"countrycode"}) {
- $language = $main::language;
+ $language = $::lx_office_conf{system}->{language};
} else {
$language = $main::myconfig{"countrycode"};
}
map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
}
- $additional_params->{"conf_dbcharset"} = $::dbcharset;
- $additional_params->{"conf_webdav"} = $::webdav;
- $additional_params->{"conf_lizenzen"} = $::lizenzen;
- $additional_params->{"conf_latex_templates"} = $::latex;
- $additional_params->{"conf_opendocument_templates"} = $::opendocument_templates;
- $additional_params->{"conf_vertreter"} = $::vertreter;
- $additional_params->{"conf_show_best_before"} = $::show_best_before;
- $additional_params->{"conf_parts_image_css"} = $::parts_image_css;
- $additional_params->{"conf_parts_listing_images"} = $::parts_listing_images;
- $additional_params->{"conf_parts_show_image"} = $::parts_show_image;
+ $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset};
+ $additional_params->{"conf_webdav"} = $::lx_office_conf{system}->{webdav};
+ $additional_params->{"conf_lizenzen"} = $::lx_office_conf{system}->{lizenzen};
+ $additional_params->{"conf_latex_templates"} = $::lx_office_conf{print_templates}->{latex};
+ $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
+ $additional_params->{"conf_vertreter"} = $::lx_office_conf{system}->{vertreter};
+ $additional_params->{"conf_show_best_before"} = $::lx_office_conf{system}->{show_best_before};
+ $additional_params->{"conf_parts_image_css"} = $::lx_office_conf{features}->{parts_image_css};
+ $additional_params->{"conf_parts_listing_images"} = $::lx_office_conf{features}->{parts_listing_images};
+ $additional_params->{"conf_parts_show_image"} = $::lx_office_conf{features}->{parts_show_image};
if (%main::debug_options) {
map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
'PLUGIN_BASE' => 'SL::Template::Plugin',
'INCLUDE_PATH' => '.:templates/webpages',
'COMPILE_EXT' => '.tcc',
- 'COMPILE_DIR' => $::userspath . '/templates-cache',
+ 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
})) || die;
}
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,
sub parse_template {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $userspath) = @_;
+ my ($self, $myconfig) = @_;
my $out;
local (*IN, *OUT);
+ my $userspath = $::lx_office_conf{paths}->{userspath};
+
$self->{"cwd"} = getcwd();
$self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
}
map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
+ map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
$self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
$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') {
map { $mail->{$_} = $self->{$_} }
qw(cc bcc subject message version format);
- $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
+ $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
$mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
$mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
$mail->{fileid} = "$fileid.";
close(FH);
}
- if ($self->{tmpfile} && ! $::keep_temp_files) {
+ if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
$self->{tmpfile} =~ s|.*/||g;
# strip extension
$self->{tmpfile} =~ s/\.\w+$//g;
$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
$form->{"qty_$i"} = $form->parse_amount($myconfig, $form->{"qty_$i"});
$form->{"qty_$i"} *= -1 if $form->{storno};
- $form->{"inventory_accno_$i"} = $form->{"expense_accno_$i"} if $main::eur;
+ $form->{"inventory_accno_$i"} = $form->{"expense_accno_$i"} if $::lx_office_conf{system}->{eur};
# get item baseunit
if (!$item_units{$form->{"id_$i"}}) {
# delete zero entries
do_query($form, $dbh, qq|DELETE FROM acc_trans WHERE amount = 0|);
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
# Link this record to the records it was created from.
RecordLinks->create_links('dbh' => $dbh,
}
$sth->finish();
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
$dbh->disconnect();
$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;
# save printed, emailed and queued
$form->save_status($dbh);
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
# Link this record to the records it was created from.
RecordLinks->create_links('dbh' => $dbh,
'table' => 'ar',);
my $rc = 1;
- if (!$provided_dbh) {
- $dbh->commit();
- $dbh->disconnect();
- }
+ $dbh->commit if !$provided_dbh;
$main::lxdebug->leave_sub();
# sellprice is the cost of the item
my $linetotal = $form->round_amount(($ref->{sellprice} * $qty) / ( ($ref->{price_factor} || 1) * ( $basefactor || 1 )), 2);
- if (!$main::eur) {
+ if (!$::lx_office_conf{system}->{eur}) {
$ref->{expense_accno} = ($form->{"expense_accno_$row"}) ? $form->{"expense_accno_$row"} : $ref->{expense_accno};
# add to expense
$form->{amount_cogs}{ $form->{id} }{ $ref->{expense_accno} } += -$linetotal;
sub delete_invoice {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $form, $spool) = @_;
+ my ($self, $myconfig, $form) = @_;
# connect to database
my $dbh = $form->dbconnect_noauto($myconfig);
# 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:
$dbh->disconnect;
if ($rc) {
+ my $spool = $::lx_office_conf{paths}->{spool};
map { unlink "$spool/$_" if -f "$spool/$_"; } @spoolfiles;
}
}
$sth->finish;
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
}
my $rc = $dbh->commit;
# to distinguish case A and B the variable pricegroup_id_$i is used
# for new articles this variable isn't defined, for loaded articles it is
# sellprice can't be used, as it already has 0,00 set
-
+
if ($pkr->{pricegroup_id} eq $form->{"pricegroup_id_$i"} and defined $form->{"pricegroup_id_$i"}) {
# Case A
$pkr->{selected} = ' selected';
- } elsif ($pkr->{pricegroup_id} eq $form->{customer_klass}
- and not defined $form->{"pricegroup_id_$i"}
+ } elsif ($pkr->{pricegroup_id} eq $form->{customer_klass}
+ and not defined $form->{"pricegroup_id_$i"}
and $pkr->{price} != 0 # only use customer pricegroup price if it has a value, else use default_sellprice
# for the case where pricegroup prices haven't been set
) {
{ name => "parent", url => "http://search.cpan.org/~corion/", debian => 'libparent-perl' },
{ name => "Archive::Zip", version => '1.16', url => "http://search.cpan.org/~adamk/", debian => 'libarchive-zip-perl' },
{ name => "Class::Accessor", version => '0.30', url => "http://search.cpan.org/~kasei/", debian => 'libclass-accessor-perl' },
+ { name => "Config::Std", url => "http://search.cpan.org/~dconway/", debian => 'libconfig-std-perl' },
{ name => "CGI::Ajax", version => '0.697', url => "http://search.cpan.org/~bct/" }, # no debian package, ours contains bugfixes
{ name => "DateTime", url => "http://search.cpan.org/~drolsky/", debian => 'libdatetime-perl' },
{ name => "DBI", version => '1.50', url => "http://search.cpan.org/~timb/", debian => 'libdbi-perl' },
{ name => "Email::Address", url => "http://search.cpan.org/~rjbs/", debian => 'libemail-address-perl' },
{ name => "FCGI", url => "http://search.cpan.org/~mstrout/", debian => 'libfcgi-perl' },
{ name => "List::MoreUtils", version => '0.21', url => "http://search.cpan.org/~vparseval/", debian => 'liblist-moreutils-perl' },
+ { name => "Params::Validate", url => "http://search.cpan.org/~drolsky/", debian => 'libparams-validate-perl' },
{ name => "PDF::API2", version => '2.000', url => "http://search.cpan.org/~areibens/", debian => 'libpdf-api2-perl' },
{ name => "Rose::Object", url => "http://search.cpan.org/~jsiracusa/", debian => 'librose-object-perl' },
{ name => "Rose::DB", url => "http://search.cpan.org/~jsiracusa/", debian => 'librose-db-perl' },
{ name => "Rose::DB::Object", url => "http://search.cpan.org/~jsiracusa/", debian => 'librose-db-object-perl' },
+ { name => "Sort::Naturally", url => "http://search.cpan.org/~sburke/", debian => 'libsort-naturally-perl' },
{ name => "Template", version => '2.18', url => "http://search.cpan.org/~abw/", debian => 'libtemplate-perl' },
{ name => "Text::CSV_XS", version => '0.23', url => "http://search.cpan.org/~hmbrand/", debian => 'libtext-csv-xs-perl' },
{ name => "Text::Iconv", version => '1.2', url => "http://search.cpan.org/~mpiotr/", debian => 'libtext-iconv-perl' },
sub check_for_conditional_dependencies {
return if $conditional_dependencies{net_ldap}++;
- my $self = {};
- eval do { local (@ARGV, $/) = 'config/authentication.pl'; <> } or return;
-
push @required_modules, { 'name' => 'Net::LDAP', 'url' => 'http://search.cpan.org/~gbarr/' }
- if $self->{module} && ($self->{module} eq 'LDAP');
+ if $::lx_office_conf{authentication} && ($::lx_office_conf{authentication}->{module} eq 'LDAP');
}
sub test_all_modules {
my $type = shift;
my $self = {};
+ _init_globals_from_config();
+
$self->{"calldepth"} = 0;
$self->{"file"} = $file_name || "/tmp/lx-office-debug.log";
$self->{"target"} = FILE_TARGET;
bless($self, $type);
}
+my $globals_inited_from_config;
+sub _init_globals_from_config {
+ return if $globals_inited_from_config;
+ $globals_inited_from_config = 1;
+
+ my $cfg = $::lx_office_conf{debug} || {};
+
+ $global_level = NONE() if $cfg->{global_level} =~ /NONE/;
+ foreach my $level (grep { $_} split(m/\s+/, $cfg->{global_level})) {
+ $global_level |= eval "${level}()";
+ }
+
+ $watch_form = $cfg->{watch_form};
+ $file_name = $cfg->{file_name} || "/tmp/lx-office-debug.log";
+}
+
sub set_target {
my ($self, $target, $file) = @_;
my ($type, $country) = @_;
- $country ||= $::language;
+ $country ||= $::lx_office_conf{system}->{language};
$country =~ s|.*/||;
$country =~ s|\.||g;
}
}
- my $db_charset = $main::dbcharset || Common::DEFAULT_CHARSET;
- $self->{is_utf8} = (any { lc($::dbcharset || '') eq $_ } qw(utf8 utf-8 unicode)) ? 1 : 0;
+ my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
+ $self->{is_utf8} = (any { lc($::lx_office_conf{system}->{dbcharset} || '') eq $_ } qw(utf8 utf-8 unicode)) ? 1 : 0;
if ($self->{is_utf8}) {
binmode STDOUT, ":utf8";
--- /dev/null
+package SL::LxOfficeConf;
+
+use strict;
+
+use Config::Std;
+use Encode;
+
+sub read {
+ read_config 'config/lx_office.conf.default' => %::lx_office_conf;
+ _decode_recursively(\%::lx_office_conf);
+
+ if (-f 'config/lx_office.conf') {
+ read_config 'config/lx_office.conf' => my %local_conf;
+ _decode_recursively(\%local_conf);
+ _flat_merge(\%::lx_office_conf, \%local_conf);
+ }
+}
+
+sub _decode_recursively {
+ my ($obj) = @_;
+
+ while (my ($key, $value) = each %{ $obj }) {
+ if (ref($value) eq 'HASH') {
+ _decode_recursively($value);
+ } else {
+ $obj->{$key} = decode('UTF-8', $value);
+ }
+ }
+}
+
+sub _flat_merge {
+ my ($dst, $src) = @_;
+
+ while (my ($key, $value) = each %{ $src }) {
+ if (!exists $dst->{$key}) {
+ $dst->{$key} = $value;
+
+ } else {
+ map { $dst->{$key}->{$_} = $value->{$_} } keys %{ $value };
+ }
+ }
+}
+
+1;
my %temp_form = ( %{ $form }, 'myconfig_email' => $email );
my $template = SL::Template::create(type => 'PlainText', form => \%temp_form);
- my $sendmail = $template->parse_block($main::sendmail);
+ my $sendmail = $template->parse_block($::lx_office_conf{applications}->{sendmail});
- if (!open(OUT, $sendmail)) {
+ if (!open(OUT, "|$sendmail")) {
$main::lxdebug->leave_sub();
return "$sendmail : $!";
}
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;
$form->{saved_xyznumber} = $form->{$form->{type} =~ /_quotation$/ ?
"quonumber" : "ordnumber"};
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
my $rc = $dbh->commit;
- $dbh->disconnect;
+
+ $self->save_periodic_invoices_config(dbh => $dbh,
+ oe_id => $form->{id},
+ config_yaml => $form->{periodic_invoices_config})
+ if ($form->{type} eq 'sales_order');
$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();
sub delete {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $form, $spool) = @_;
+ my ($self, $myconfig, $form) = @_;
# connect to database
my $dbh = $form->dbconnect_noauto($myconfig);
# 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 = ?|;
$dbh->disconnect;
if ($rc) {
+ my $spool = $::lx_office_conf{paths}->{spool};
foreach $spoolfile (@spoolfiles) {
unlink "$spool/$spoolfile" if $spoolfile;
}
$form->{exchangerate} = $form->get_exchangerate($dbh, $form->{currency}, $form->{transdate}, ($form->{vc} eq 'customer') ? "buy" : "sell");
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
+
+ $self->load_periodic_invoice_config($form);
my $rc = $dbh->commit;
- $dbh->disconnect;
$main::lxdebug->leave_sub();
my $num_columns = scalar @visible_columns;
my $num_header_rows = 1;
- my $font_encoding = $main::dbcharset || 'ISO-8859-15';
+ my $font_encoding = $::lx_office_conf{system}->{dbcharset} || 'ISO-8859-15';
foreach my $name (@visible_columns) {
push @column_props, { 'justify' => $self->{columns}->{$name}->{align} eq 'right' ? 'right' : 'left' };
my %params = @_;
my $package = "SL::Template::" . $params{type};
- $package->new($params{file_name}, $params{form}, $params{myconfig} || \%::myconfig, $params{userspath} || $::userspath);
+ $package->new($params{file_name}, $params{form}, $params{myconfig} || \%::myconfig, $params{userspath} || $::lx_office_conf{paths}->{userspath});
}
1;
$psfile .= ".ps";
}
- system("html2ps -f html2ps-config < $form->{tmpfile} > $psfile");
+ system($::lx_office_conf{applications}->{html2ps} . " -f html2ps-config < $form->{tmpfile} > $psfile");
if ($?) {
$self->{"error"} = $form->cleanup();
$self->cleanup();
$pdffile .= ".pdf";
}
- system("html2ps -f html2ps-config < $form->{tmpfile} | ps2pdf - $pdffile");
+ system($::lx_office_conf{applications}->{html2ps} . " -f html2ps-config < $form->{tmpfile} | ps2pdf - $pdffile");
if ($?) {
$self->{"error"} = $form->cleanup();
$self->cleanup();
}
sub _get_latex_path {
- return $main::latex_bin || 'pdflatex';
+ return $::lx_office_conf{applications}->{latex} || 'pdflatex';
}
sub get_mime_type() {
my $self = $type->SUPER::new(@_);
$self->{"rnd"} = int(rand(1000000));
- $self->{"iconv"} = SL::Iconv->new($main::dbcharset, "UTF-8");
+ $self->{"iconv"} = SL::Iconv->new($::lx_office_conf{system}->{dbcharset}, "UTF-8");
$self->set_tag_style('<%', '%>');
$self->{quot_re} = '"';
my $pid = fork();
if (0 == $pid) {
$main::lxdebug->message(LXDebug->DEBUG2(), " Child execing\n");
- exec($main::xvfb_bin, $display, "-screen", "0", "640x480x8", "-nolisten", "tcp");
+ exec($::lx_office_conf{applications}->{xvfb}, $display, "-screen", "0", "640x480x8", "-nolisten", "tcp");
}
sleep(3);
$main::lxdebug->message(LXDebug->DEBUG2(), " parent dont sleeping\n");
sub is_openoffice_running {
$main::lxdebug->enter_sub();
- my $output = `./scripts/oo-uno-test-conn.py $main::openofficeorg_daemon_port 2> /dev/null`;
+ my $cmd = "./scripts/oo-uno-test-conn.py " . $::lx_office_conf{print_templates}->{openofficeorg_daemon_port} . " 2> /dev/null";
+ my $output = `$cmd`;
chomp $output;
my $res = ($? == 0) || $output;
exit if ($new_pid);
my $ssres = setsid();
$main::lxdebug->message(LXDebug->DEBUG2(), " Child execing\n");
- my @cmdline = ($main::openofficeorg_writer_bin,
+ my @cmdline = ($::lx_office_conf{applications}->{openofficeorg_writer},
"-minimized", "-norestore", "-nologo", "-nolockcheck",
"-headless",
"-accept=socket,host=localhost,port=" .
- $main::openofficeorg_daemon_port . ";urp;");
+ $::lx_office_conf{print_templates}->{openofficeorg_daemon_port} . ";urp;");
exec(@cmdline);
}
}
my @cmdline;
- if (!$main::openofficeorg_daemon) {
- @cmdline = ($main::openofficeorg_writer_bin,
+ if (!$::lx_office_conf{print_templates}->{openofficeorg_daemon}) {
+ @cmdline = ($::lx_office_conf{applications}->{openofficeorg_writer},
"-minimized", "-norestore", "-nologo", "-nolockcheck",
"-headless",
"file:${filename}.odt",
}
@cmdline = ("./scripts/oo-uno-convert-pdf.py",
- $main::openofficeorg_daemon_port,
+ $::lx_office_conf{print_templates}->{openofficeorg_daemon_port},
"${filename}.odt");
}
my $form = $main::form;
my %filters = $self->_get_filters();
- $self->dbh->begin_work;
+ $self->dbh->begin_work if $self->dbh->{AutoCommit};
do_query($form, $self->dbh, qq|LOCK TABLE defaults|);
do_query($form, $self->dbh, qq|LOCK TABLE business|) if $self->business_id;
}
# update the tables
- if (!open(FH, ">$main::userspath/nologin")) {
+ if (!open(FH, ">" . $::lx_office_conf{paths}->{userspath} . "/nologin")) {
$form->show_generic_error($main::locale->text('A temporary file could not be created. ' .
'Please verify that the directory "#1" is writeable by the webserver.',
- $main::userspath),
+ $::lx_office_conf{paths}->{userspath}),
'back_button' => 1);
}
close(FH);
# remove lock file
- unlink("$main::userspath/nologin");
+ unlink($::lx_office_conf{paths}->{userspath} . "/nologin");
my $menufile =
$self->{"menustyle"} eq "v3" ? "menuv3.pl" :
closedir(SQLDIR);
}
- my $db_charset = $main::dbcharset;
+ my $db_charset = $::lx_office_conf{system}->{dbcharset};
$db_charset ||= Common::DEFAULT_CHARSET;
my $dbupdater = SL::DBUpgrade2->new(form => $form, dbdriver => $form->{dbdriver});
$form->{sid} = $form->{dbdefault};
my $rc = -2;
- my $db_charset = $main::dbcharset || Common::DEFAULT_CHARSET;
+ my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
map { $_->{description} = SL::Iconv::convert($_->{charset}, $db_charset, $_->{description}) } values %{ $dbupdater->{all_controls} };
-2.6.3-unstable
+2.7.0-unstable
use Sys::Hostname;
use SL::Auth;
+use SL::Auth::PasswordPolicy;
use SL::Form;
use SL::Iconv;
use SL::Mailer;
::end_of_request();
}
- if (-f $main::memberfile) {
+ my $memberfile = $::lx_office_conf{paths}->{memberfile};
+ if (-f $memberfile) {
my $memberdir = "";
- if ($main::memberfile =~ m|^.*/|) {
+ if ($memberfile =~ m|^.*/|) {
$memberdir = $&;
}
$form->{title} = $locale->text('User data migration');
$form->header();
- print $form->parse_html_template('admin/user_migration', { 'memberfile' => $main::memberfile,
+ print $form->parse_html_template('admin/user_migration', { 'memberfile' => $memberfile,
'backupdir' => $backupdir });
::end_of_request();
$main::auth->set_session_value('rpw', $form->{rpw});
$main::auth->create_or_refresh_session();
- if (!-f $main::memberfile) {
+ my $memberfile = $::lx_office_conf{paths}->{memberfile};
+ if (!-f $memberfile) {
# New installation -- create a standard group with full access
my %members;
my $group = {
my $memberdir = "";
- if ($main::memberfile =~ m|^.*/|) {
+ my $memberfile = $::lx_office_conf{paths}->{memberfile};
+ if ($memberfile =~ m|^.*/|) {
$memberdir = $&;
}
$form->error(sprintf($locale->text('The directory "%s" could not be created:\n%s'), $backupdir, $!));
}
- copy $main::memberfile, "users/member-file-migration/members";
+ copy $memberfile, "users/member-file-migration/members";
- my $in = IO::File->new($main::memberfile, "r");
+ my $in = IO::File->new($memberfile, "r");
$form->error($locale->text('Could not open the old memberfile.')) if (!$in);
}
}
- unlink $main::memberfile;
+ unlink $memberfile;
my @member_list = sort { lc $a->{login} cmp lc $b->{login} } values %members;
map { $_->{templates} =~ s|.*/||; } values %members;
$form->{title} = "Lx-Office ERP " . $locale->text('Administration');
- $form->{LOCKED} = -e "$main::userspath/nologin";
+ $form->{LOCKED} = -e _nologin_file_name();
$form->{MEMBERS} = [ @members{sort { lc $a cmp lc $b } keys %members} ];
$form->header();
}
# is there a templates basedir
- if (!-d "$main::templates") {
- $form->error(sprintf($locale->text("The directory %s does not exist."), $main::templates));
+ if (!-d $::lx_office_conf{paths}->{templates}) {
+ $form->error(sprintf($locale->text("The directory %s does not exist."), $::lx_office_conf{paths}->{templates}));
}
- opendir TEMPLATEDIR, "$main::templates/." or $form->error("$main::templates : $ERRNO");
+ opendir TEMPLATEDIR, $::lx_office_conf{paths}->{templates} or $form->error($::lx_office_conf{paths}->{templates} . " : $ERRNO");
my @all = readdir(TEMPLATEDIR);
- my @alldir = sort grep { -d "$main::templates/$_" && !/^\.\.?$/ } @all;
- my @allhtml = sort grep { -f "$main::templates/$_" && /\.html$/ } @all;
+ my @alldir = sort grep { -d ($::lx_office_conf{paths}->{templates} . "/$_") && !/^\.\.?$/ } @all;
+ my @allhtml = sort grep { -f ($::lx_office_conf{paths}->{templates} . "/$_") && /\.html$/ } @all;
closedir TEMPLATEDIR;
@alldir = grep !/\.(html|tex|sty|odt|xml|txb)$/, @alldir;
}
# is there a basedir
- if (!-d "$main::templates") {
- $form->error(sprintf($locale->text("The directory %s does not exist."), $main::templates));
+ if (!-d $::lx_office_conf{paths}->{templates}) {
+ $form->error(sprintf($locale->text("The directory %s does not exist."), $::lx_office_conf{paths}->{templates}));
}
# add base directory to $form->{templates}
$form->{templates} =~ s|.*/||;
- $form->{templates} = "$main::templates/$form->{templates}";
+ $form->{templates} = $::lx_office_conf{paths}->{templates} . "/$form->{templates}";
my $myconfig = new User($form->{login});
$myconfig->save_member();
- if ($main::auth->can_change_password()
- && defined $form->{new_password}
- && ($form->{new_password} ne '********')) {
- $main::auth->change_password($form->{login}, $form->{new_password});
- }
-
$form->{templates} =~ s|.*/||;
- $form->{templates} = "$main::templates/$form->{templates}";
+ $form->{templates} = $::lx_office_conf{paths}->{templates} . "/$form->{templates}";
$form->{mastertemplates} =~ s|.*/||;
# create user template directory and copy master files
umask(007);
# copy templates to the directory
- opendir TEMPLATEDIR, "$main::templates/." or $form->error("$main::templates : $ERRNO");
+ opendir TEMPLATEDIR, $::lx_office_conf{paths}->{templates} or $form->error($::lx_office_conf{paths}->{templates} . " : $ERRNO");
my @templates = grep /$form->{mastertemplates}.*?\.(html|tex|sty|odt|xml|txb)$/,
readdir TEMPLATEDIR;
closedir TEMPLATEDIR;
foreach my $file (@templates) {
- open(TEMP, "$main::templates/$file")
- or $form->error("$main::templates/$file : $ERRNO");
+ open(TEMP, $::lx_office_conf{paths}->{templates} . "/$file")
+ or $form->error($::lx_office_conf{paths}->{templates} . "/$file : $ERRNO");
$file =~ s/\Q$form->{mastertemplates}\E-//;
open(NEW, ">$form->{templates}/$file")
}
}
- $form->redirect($locale->text('User saved!'));
+ if ($main::auth->can_change_password()
+ && defined $form->{new_password}
+ && ($form->{new_password} ne '********')) {
+ my $verifier = SL::Auth::PasswordPolicy->new;
+ my $result = $verifier->verify($form->{new_password}, 1);
+
+ if ($result != SL::Auth::PasswordPolicy->OK()) {
+ $form->error($::locale->text('The settings were saved, but the password was not changed.') . ' ' . join(' ', $verifier->errors($result)));
+ }
+ $main::auth->change_password($form->{login}, $form->{new_password});
+ }
+
+ $form->redirect($locale->text('User saved!'));
}
sub save_user_as_new {
}
closedir SQLDIR;
- my $default_charset = $main::dbcharset;
+ my $default_charset = $::lx_office_conf{system}->{dbcharset};
$default_charset ||= Common::DEFAULT_CHARSET;
my $cluster_encoding = User->dbclusterencoding($form);
if ($cluster_encoding && ($cluster_encoding =~ m/^(?:UTF-?8|UNICODE)$/i)) {
- if ($main::dbcharset !~ m/^UTF-?8$/i) {
+ if ($::lx_office_conf{system}->{dbcharset} !~ m/^UTF-?8$/i) {
$form->show_generic_error($locale->text('The selected PostgreSQL installation uses UTF-8 as its encoding. ' .
'Therefore you have to configure Lx-Office to use UTF-8 as well.'),
'back_button' => 1);
$form->{title} = "Lx-Office ERP " . $locale->text('Database Administration') . " / " . $locale->text('Backup Dataset');
- if ("$main::pg_dump_exe" eq "DISABLED") {
- $form->error($locale->text('Database backups and restorations are disabled in lx-erp.conf.'));
+ if ($::lx_office_conf{applications}->{pg_dump} eq "DISABLED") {
+ $form->error($locale->text('Database backups and restorations are disabled in the configuration.'));
}
my @dbsources = sort User->dbsources($form);
$form->{title} = "Lx-Office ERP " . $locale->text('Database Administration') . " / " . $locale->text('Backup Dataset');
- $main::pg_dump_exe ||= "pg_dump";
+ my $pg_dump_exe = $::lx_office_conf{applications}->{pg_dump} || "pg_dump";
- if ("$main::pg_dump_exe" eq "DISABLED") {
- $form->error($locale->text('Database backups and restorations are disabled in lx-erp.conf.'));
+ if ("$pg_dump_exe" eq "DISABLED") {
+ $form->error($locale->text('Database backups and restorations are disabled in the configuration.'));
}
$form->isblank("dbname", $locale->text('The dataset name is missing.'));
push @args, ("-p", $form->{dbport}) if ($form->{dbport});
push @args, $form->{dbname};
- my $cmd = "$main::pg_dump_exe " . join(" ", map { s/\\/\\\\/g; s/\"/\\\"/g; $_ } @args);
+ my $cmd = "$pg_dump_exe " . join(" ", map { s/\\/\\\\/g; s/\"/\\\"/g; $_ } @args);
my $name = "dataset_backup_$form->{dbname}_" . strftime("%Y%m%d", localtime()) . ".tar";
if ($form->{destination} ne "email") {
map { $mail->{$_} = $form->{$_} } qw(from to cc subject message);
- $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
+ $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
$mail->{attachments} = [ { "filename" => $tmp, "name" => $name } ];
$mail->send();
$form->{title} = "Lx-Office ERP " . $locale->text('Database Administration') . " / " . $locale->text('Restore Dataset');
- if ("$main::pg_restore_exe" eq "DISABLED") {
- $form->error($locale->text('Database backups and restorations are disabled in lx-erp.conf.'));
+ if ($::lx_office_conf{applications}->{pg_restore} eq "DISABLED") {
+ $form->error($locale->text('Database backups and restorations are disabled in the configuration.'));
}
- my $default_charset = $main::dbcharset;
+ my $default_charset = $::lx_office_conf{system}->{dbcharset};
$default_charset ||= Common::DEFAULT_CHARSET;
$form->{DBENCODINGS} = [];
$form->{title} = "Lx-Office ERP " . $locale->text('Database Administration') . " / " . $locale->text('Restore Dataset');
- $main::pg_restore_exe ||= "pg_restore";
+ my $pg_restore_exe = $::lx_office_conf{applications}->{pg_restore} || "pg_restore";
- if ("$main::pg_restore_exe" eq "DISABLED") {
- $form->error($locale->text('Database backups and restorations are disabled in lx-erp.conf.'));
+ if ("$pg_restore_exe" eq "DISABLED") {
+ $form->error($locale->text('Database backups and restorations are disabled in the configuration.'));
}
$form->isblank("new_dbname", $locale->text('The dataset name is missing.'));
push @args, ("-p", $form->{dbport}) if ($form->{dbport});
push @args, $tmp;
- my $cmd = "$main::pg_restore_exe " . join(" ", map { s/\\/\\\\/g; s/\"/\\\"/g; $_ } @args);
+ my $cmd = "$pg_restore_exe " . join(" ", map { s/\\/\\\\/g; s/\"/\\\"/g; $_ } @args);
my $in = IO::File->new("$cmd 2>&1 |");
my $form = $main::form;
my $locale = $main::locale;
- unlink "$main::userspath/nologin";
+ unlink _nologin_file_name();;
$form->{callback} = "admin.pl?action=list_users";
my $form = $main::form;
my $locale = $main::locale;
- open(FH, ">$main::userspath/nologin")
+ open(FH, ">" . _nologin_file_name())
or $form->error($locale->text('Cannot create Lock!'));
close(FH);
::end_of_request() if SL::DBUpgrade2->new(form => $::form, dbdriver => 'Pg', auth => 1)->apply_admin_dbupgrade_scripts(1);
}
+sub _nologin_file_name {
+ return $::lx_office_conf{paths}->{userspath} . '/nologin';
+}
+
1;
use utf8;
use SL::Auth;
+use SL::Auth::PasswordPolicy;
use SL::AM;
use SL::CA;
use SL::Form;
$form->{title} = $locale->text('Type of Business');
my @column_index = qw(description discount customernumberinit);
- push @column_index, 'salesman' if $::vertreter;
+ push @column_index, 'salesman' if $::lx_office_conf{system}->{vertreter};
my %column_header;
$column_header{description} =
qq|<th class=listheading width=60%>|
$form->format_amount(\%myconfig, $form->{discount} * 100);
my $salesman_code;
- if ($::vertreter) {
+ if ($::lx_office_conf{system}->{vertreter}) {
$salesman_code = qq|
<tr>
<th align="right">| . $locale->text('Representative') . qq|</th>
}
my $linkaccounts;
- if (!$main::eur) {
+ if (!$::lx_office_conf{system}->{eur}) {
$linkaccounts = qq|
<tr>
<th align=right>| . $locale->text('Inventory') . qq|</th>
_build_cfg_options('numberformat', ('1,000.00', '1000.00', '1.000,00', '1000,00'));
my @formats = ();
- if ($main::opendocument_templates && $main::openofficeorg_writer_bin &&
- $main::xvfb_bin && (-x $main::openofficeorg_writer_bin) && (-x $main::xvfb_bin)) {
+ if ($::lx_office_conf{print_templates}->{opendocument}
+ && $::lx_office_conf{applications}->{openofficeorg_writer} && (-x $::lx_office_conf{applications}->{openofficeorg_writer})
+ && $::lx_office_conf{applications}->{xvfb} && (-x $::lx_office_conf{applications}->{xvfb})) {
push(@formats, { "name" => $locale->text("PDF (OpenDocument/OASIS)"),
"value" => "opendocument_pdf" });
}
- if ($main::latex_templates) {
+ if ($::lx_office_conf{print_templates}->{latex}) {
push(@formats, { "name" => $locale->text("PDF"), "value" => "pdf" });
}
push(@formats, { "name" => "HTML", "value" => "html" });
- if ($main::latex_templates) {
+ if ($::lx_office_conf{print_templates}->{latex}) {
push(@formats, { "name" => $locale->text("Postscript"),
"value" => "postscript" });
}
- if ($main::opendocument_templates) {
+ if ($::lx_office_conf{print_templates}->{opendocument}) {
push(@formats, { "name" => $locale->text("OpenDocument/OASIS"),
"value" => "opendocument" });
}
TODO->save_user_config('login' => $form->{login}, %{ $form->{todo_cfg} || { } });
- $form->redirect($locale->text('Preferences saved!')) if (AM->save_preferences(\%myconfig, \%$form, 0));
+ if (AM->save_preferences(\%myconfig, $form)) {
+ if ($::auth->can_change_password()
+ && defined $form->{new_password}
+ && ($form->{new_password} ne '********')) {
+ my $verifier = SL::Auth::PasswordPolicy->new;
+ my $result = $verifier->verify($form->{new_password});
+
+ if ($result != SL::Auth::PasswordPolicy->OK()) {
+ $form->error($::locale->text('The settings were saved, but the password was not changed.') . ' ' . join(' ', $verifier->errors($result)));
+ }
+
+ $::auth->change_password($form->{login}, $form->{new_password});
+
+ $form->{password} = $form->{new_password};
+ $::auth->set_session_value('password', $form->{password});
+ $::auth->create_or_refresh_session();
+ }
+
+ $form->redirect($locale->text('Preferences saved!'));
+ }
+
$form->error($locale->text('Cannot save preferences!'));
$main::lxdebug->leave_sub();
$main::auth->assert('general_ledger');
- if (AP->delete_transaction(\%myconfig, \%$form, $main::spool)) {
+ if (AP->delete_transaction(\%myconfig, \%$form)) {
# saving the history
if(!exists $form->{addition}) {
$form->{snumbers} = qq|invnumber_| . $form->{invnumber};
$form->{callback} .= "&header=1" if $form->{callback};
$form->redirect($locale->text('Removed spoolfiles!'))
- if (BP->delete_spool(\%myconfig, \%$form, $main::spool));
+ if (BP->delete_spool(\%myconfig, \%$form));
$form->error($locale->text('Cannot remove files!'));
$main::lxdebug->leave_sub();
if ($form->{"checked_$i"}) {
$form->info($locale->text('Printing ... '));
- if (BP->print_spool(\%myconfig, \%$form, $main::spool, "| $selected_printer")) {
+ if (BP->print_spool(\%myconfig, \%$form, "| $selected_printer")) {
print $locale->text('done');
$form->redirect($locale->text('Marked entries printed!'));
}
my $i = 0;
my $j = 0;
my $spoolfile;
+ my $spool = $::lx_office_conf{paths}->{spool};
foreach my $ref (@{ $form->{SPOOL} }) {
"<td><a href=$module?action=edit&id=$ref->{id}&type=$form->{type}&callback=$callback>$ref->{quonumber}</a></td>";
$column_data{name} = "<td>$ref->{name}</td>";
$column_data{spoolfile} =
- qq|<td><a href=$main::spool/$ref->{spoolfile}>$ref->{spoolfile}</a></td>
+ qq|<td><a href=$spool/$ref->{spoolfile}>$ref->{spoolfile}</a></td>
<input type=hidden name="spoolfile_$i" value=$ref->{spoolfile}>
|;
$form->{title} = $locale->text('Chart of Accounts');
- if ($main::eur) {
+ if ($::lx_office_conf{system}->{eur}) {
$form->{method} = "cash";
}
<td colspan=3><select name=department>$form->{selectdepartment}</select></td>
</tr>
| if $form->{selectdepartment};
- my $accrual = ($main::eur) ? "" : "checked";
- my $cash = ($main::eur) ? "checked" : "";
+ my $accrual = $::lx_office_conf{system}->{eur} ? "" : "checked";
+ my $cash = $::lx_office_conf{system}->{eur} ? "checked" : "";
my $name_1 = "fromdate";
my $id_1 = "fromdate";
$form->{description} =~ s/\"/"/g;
+ my $eur = $::lx_office_conf{system}->{eur};
+
print qq|
<body onLoad="$onload">
<input type=hidden name=accno value=$form->{accno}>
<input type=hidden name=description value="$form->{description}">
<input type=hidden name=sort value=transdate>
-<input type=hidden name=eur value=$main::eur>
+<input type=hidden name=eur value=$eur>
<input type=hidden name=accounttype value=$form->{accounttype}>
<table border=0 width=100%>
}
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->reformat_numbers(@_);
}
# -------------------------------------------------------------------------
taxzones => "ALL_TAXZONES");
$form->get_pricegroup(\%myconfig, { all => 1 });
- $form->get_lists(customers => { key => "ALL_SALESMAN_CUSTOMERS", business_is_salesman => 1 }) if $::vertreter;
+ $form->get_lists(customers => { key => "ALL_SALESMAN_CUSTOMERS", business_is_salesman => 1 }) if $::lx_office_conf{system}->{vertreter};
$form->{ALL_SALESMEN} = $form->{ALL_EMPLOYEES};
$form->{taxincluded} = ($form->{taxincluded}) ? "checked" : "";
$::form->isblank("name", $::locale->text("Name missing!"));
- if ($::form->{new_salesman_id} && $::vertreter) {
+ if ($::form->{new_salesman_id} && $::lx_office_conf{system}->{vertreter}) {
$::form->{salesman_id} = $::form->{new_salesman_id};
delete $::form->{new_salesman_id};
}
foreach my $level (values %{ $levels }) {
next unless scalar @{ $level };
- DN->save_dunning(\%myconfig, $form, $level, $main::userspath, $main::spool);
+ DN->save_dunning(\%myconfig, $form, $level);
}
}
"customer_id" => $form->{"customer_id_$i"},
"next_dunning_config_id" => $form->{"next_dunning_config_id_$i"},
"email" => $form->{"email_$i"}, } ];
- DN->save_dunning(\%myconfig, $form, $level, $main::userspath, $main::spool);
+ DN->save_dunning(\%myconfig, $form, $level);
}
}
$form->all_vc(\%myconfig, $form->{vc}, ($form->{vc} eq 'customer') ? "AR" : "AP");
# retrieve order/quotation
- $form->{webdav} = $main::webdav;
+ $form->{webdav} = $::lx_office_conf{system}->{webdav};
$form->{jsscript} = 1;
my $editing = $form->{id};
my $pinfo = $part_info_map{$request->{parts_id}};
my $binfo = $bin_info_map{$request->{bin_id}};
- if ($main::show_best_before) {
+ if ($::lx_office_conf{system}->{show_best_before}) {
push @{ $form->{ERRORS} }, $locale->text("There is not enough available of '#1' at warehouse '#2', bin '#3', #4, #5, for the transfer of #6.",
$pinfo->{description},
$binfo->{warehouse_description},
$auth->assert('part_service_assembly_edit');
- $form->{eur} = $main::eur; # config dumps into namespace - yuck
+ $form->{eur} = $::lx_office_conf{system}->{eur}; # config dumps into namespace - yuck
$form->{pg_keys} = sub { "$_[0]->{partsgroup}--$_[0]->{id}" };
$form->{description_area} = ($form->{rows} = $form->numtextrows($form->{description}, 40)) > 1;
$form->{notes_rows} = max 4, $form->numtextrows($form->{notes}, 40), $form->numtextrows($form->{formel}, 40);
return if (scalar(@missing_modules) == 0);
use SL::Locale;
- my $locale = new Locale($main::language, "installationcheck");
+
+ my $locale = new Locale($::lx_office_conf{system}->{language}, "installationcheck");
print(qq|content-type: text/html
::end_of_request();
}
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
# if ( $form->{print_and_post}
# && $form->{second_run}
qw(bin listprice inventory_accno income_accno expense_accno unit weight
assembly taxaccounts partsgroup formel longdescription not_discountable
part_payment_id partnotes id lastcost price_factor_id price_factor);
- push @new_fields, "lizenzen" if ($main::lizenzen);
+ push @new_fields, "lizenzen" if $::lx_office_conf{system}->{lizenzen};
push @new_fields, grep { m/^ic_cvar_/ } keys %{ $form->{item_list}->[0] };
my $i = 0;
foreach my $ref (@{ $form->{item_list} }) {
my $checked = ($i++) ? "" : "checked";
- if ($main::lizenzen) {
+ if ($::lx_office_conf{system}->{lizenzen}) {
if ($ref->{inventory_accno} > 0) {
$ref->{"lizenzen"} = qq|<option></option>|;
foreach my $item (@{ $form->{LIZENZEN}{ $ref->{"id"} } }) {
$form->{payment_id} = $form->{"part_payment_id_$i"};
}
- if ($main::lizenzen) {
+ if ($::lx_office_conf{system}->{lizenzen}) {
map { $form->{"${_}_$i"} = $form->{"new_${_}_$j"} } qw(lizenzen);
}
my $script = $form->{"script"};
$script =~ s|.*/||;
$script =~ s|.pl$||;
- $locale = new Locale($main::language, $script);
+ $locale = new Locale($::lx_office_conf{system}->{language}, $script);
map { $form->{"select$_"} = "" } ($form->{vc}, "currency");
push @MEDIA, grep $_,
opthash("screen", $form->{OP}{screen}, $locale->text('Screen')),
- ($form->{printers} && scalar @{ $form->{printers} } && $main::latex_templates) ?
+ ($form->{printers} && scalar @{ $form->{printers} } && $::lx_office_conf{print_templates}->{latex}) ?
opthash("printer", $form->{OP}{printer}, $locale->text('Printer')) : undef,
- ($main::latex_templates && !$options{no_queue}) ?
+ ($::lx_office_conf{print_templates}->{latex} && !$options{no_queue}) ?
opthash("queue", $form->{OP}{queue}, $locale->text('Queue')) : undef
if ($form->{media} ne 'email');
push @FORMAT, grep $_,
- ($main::opendocument_templates && $main::openofficeorg_writer_bin && $main::xvfb_bin
- && (-x $main::openofficeorg_writer_bin) && (-x $main::xvfb_bin)
+ ($::lx_office_conf{print_templates}->{opendocument} && $::lx_office_conf{applications}->{openofficeorg_writer} && $::lx_office_conf{applications}->{xvfb}
+ && (-x $::lx_office_conf{applications}->{openofficeorg_writer}) && (-x $::lx_office_conf{applications}->{xvfb})
&& !$options{no_opendocument_pdf}) ?
opthash("opendocument_pdf", $form->{DF}{"opendocument_pdf"}, $locale->text("PDF (OpenDocument/OASIS)")) : undef,
- ($main::latex_templates) ?
+ ($::lx_office_conf{print_templates}->{latex}) ?
opthash("pdf", $form->{DF}{pdf}, $locale->text('PDF')) : undef,
- ($main::latex_templates && !$options{no_postscript}) ?
+ ($::lx_office_conf{print_templates}->{latex} && !$options{no_postscript}) ?
opthash("postscript", $form->{DF}{postscript}, $locale->text('Postscript')) : undef,
(!$options{no_html}) ?
opthash("html", $form->{DF}{html}, "HTML") : undef,
- ($main::opendocument_templates && !$options{no_opendocument}) ?
+ ($::lx_office_conf{print_templates}->{opendocument} && !$options{no_opendocument}) ?
opthash("opendocument", $form->{DF}{opendocument}, $locale->text("OpenDocument/OASIS")) : undef,
- ($main::excel_templates && !$options{no_excel}) ?
+ ($::lx_office_conf{print_templates}->{excel} && !$options{no_excel}) ?
opthash("excel", $form->{DF}{excel}, $locale->text("Excel")) : undef;
push @LANGUAGE_ID,
);
my %template_vars = (
- display_copies => scalar @{ $form->{printers} || [] } && $main::latex_templates && $form->{media} ne 'email',
+ display_copies => scalar @{ $form->{printers} || [] } && $::lx_office_conf{print_templates}->{latex} && $form->{media} ne 'email',
display_remove_draft => (!$form->{id} && $form->{draft_id}),
display_groupitems => !$dont_display_groupitems{$form->{type}},
groupitems_checked => $form->{groupitems} ? "checked" : '',
my $filename;
if ($filename = $queued{ $form->{formname} }) {
$form->{queued} =~ s/\Q$form->{formname} $filename\E//;
- unlink "$main::spool/$filename";
+ unlink $::lx_office_conf{paths}->{spool} . "/$filename";
$filename =~ s/\..*$//g;
} else {
$filename = time;
}
$filename .= ($form->{postscript}) ? '.ps' : '.pdf';
- $form->{OUT} = ">$main::spool/$filename";
+ $form->{OUT} = ">" . $::lx_office_conf{paths}->{spool} . "/$filename";
# add type
$form->{queued} .= " $form->{formname} $filename";
}
# /saving the history
- $form->parse_template(\%myconfig, $main::userspath);
+ $form->parse_template(\%myconfig);
$form->{callback} = "";
$form->{vc} = 'vendor';
# create links
- $form->{webdav} = $main::webdav;
+ $form->{webdav} = $::lx_office_conf{system}->{webdav};
$form->{jsscript} = 1;
$form->create_links("AP", \%myconfig, "vendor");
$form->{vc} = 'customer';
# create links
- $form->{webdav} = $main::webdav;
- $form->{lizenzen} = $main::lizenzen;
+ $form->{webdav} = $::lx_office_conf{system}->{webdav};
+ $form->{lizenzen} = $::lx_office_conf{system}->{lizenzen};
$form->create_links("AR", \%myconfig, "customer");
$form->{"qty_$i"} = $form->format_amount(\%myconfig, $form->{"qty_$i"});
- if ($main::lizenzen) {
+ if ($::lx_office_conf{system}->{lizenzen}) {
if ($form->{"inventory_accno_$i"} ne "") {
$form->{"lizenzen_$i"} = qq|<option></option>|;
foreach my $item (@{ $form->{LIZENZEN}{ $form->{"id_$i"} } }) {
$main::auth->assert('invoice_edit');
- if (IS->delete_invoice(\%myconfig, \%$form, $main::spool)) {
+ if (IS->delete_invoice(\%myconfig, \%$form)) {
# saving the history
if(!exists $form->{addition}) {
$form->{snumbers} = qq|invnumber_| . $form->{invnumber};
$form->{title} = $locale->text('Add License');
- if (!$main::lizenzen) {
+ if (!$::lx_office_conf{system}->{lizenzen}) {
$form->error(
$locale->text(
- 'The licensing module has been deactivated in lx-erp.conf.')
+ 'The licensing module has been deactivated in the configuration.')
);
}
$form->{title} = $locale->text('Licenses');
- if (!$main::lizenzen) {
+ if (!$::lx_office_conf{system}->{lizenzen}) {
$form->error(
$locale->text(
- 'The licensing module has been deactivated in lx-erp.conf.')
+ 'The licensing module has been deactivated in the configuration.')
);
}
sub show_error {
my $template = shift;
my %myconfig = %main::myconfig;
- $myconfig{countrycode} = $main::language;
+ $myconfig{countrycode} = $::lx_office_conf{system}->{language};
$form->{stylesheet} = 'css/lx-office-erp.css';
$form->header();
$::lxdebug->enter_sub;
my $framesize = _calc_framesize() - 2;
- my $menu = Menu->new($::menufile);
+ my $menu = Menu->new("menu.ini");
$mainlevel = $::form->{level};
$::form->{title} = $::locale->text('Lx-Office');
$::form->header;
my $form = $main::form;
my %myconfig = %main::myconfig;
- my $charset = $main::dbcharset || 'ISO-8859-1';
+ my $charset = $::lx_office_conf{system}->{dbcharset} || 'ISO-8859-1';
my $callback = $form->unescape($form->{callback});
$callback = URI->new($callback)->rel($callback) if $callback;
$callback = "login.pl?action=company_logo" if $callback =~ /^(\.\/)?$/;
my $mainlevel = $form->{level};
$mainlevel =~ s/$mainlevel--//g;
- my $menu = Menu->new($::menufile);
+ my $menu = Menu->new("menu.ini");
$| = 1;
my $mainlevel = $form->{level};
$mainlevel =~ s/$mainlevel--//g;
- my $menu = Menu->new($::menufile);
+ my $menu = Menu->new("menu.ini");
$| = 1;
my $mainlevel = $form->{level};
$mainlevel =~ s/\Q$mainlevel\E--//g;
- my $menu = Menu->new($::menufile);
+ my $menu = Menu->new("menu.ini");
$| = 1;
my $mainlevel = $form->{level};
$mainlevel =~ s/\Q$mainlevel\E--//g;
- my $menu = Menu->new($::menufile);
+ my $menu = Menu->new("menu.ini");
$| = 1;
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;
$form->all_vc(\%myconfig, $form->{vc}, ($form->{vc} eq 'customer') ? "AR" : "AP");
# retrieve order/quotation
- $form->{webdav} = $main::webdav;
+ $form->{webdav} = $::lx_office_conf{system}->{webdav};
$form->{jsscript} = 1;
my $editing = $form->{id};
$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>|;
print $form->parse_html_template("oe/form_footer", {
%TMPL_VAR,
- webdav => $main::webdav,
+ webdav => $::lx_office_conf{system}->{webdav},
print_options => print_options(inline => 1),
label_edit => $locale->text("Edit the $form->{type}"),
label_workflow => $locale->text("Workflow $form->{type}"),
"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;
$msg = $locale->text('Quotation deleted!');
$err = $locale->text('Cannot delete quotation!');
}
- if (OE->delete(\%myconfig, \%$form, $main::spool)){
+ if (OE->delete(\%myconfig, \%$form)){
# saving the history
if(!exists $form->{addition}) {
$form->{snumbers} = qq|ordnumber_| . $form->{ordnumber};
$form->language_payment(\%myconfig);
- Common::webdav_folder($form) if ($main::webdav);
+ Common::webdav_folder($form);
&form_header;
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 {
foreach my $action (qw(delete delivery_order e_mail invoice print purchase_order purchase_order quotation
request_for_quotation sales_order sales_order save save_and_close save_as_new ship_to update)) {
$form->{title} = $locale->text($title{ $form->{report} });
- my $accrual = ($main::eur) ? "" : "checked";
- my $cash = ($main::eur) ? "checked" : "";
+ my $accrual = $::lx_office_conf{system}->{eur} ? "" : "checked";
+ my $cash = $::lx_office_conf{system}->{eur} ? "checked" : "";
my $year = (localtime)[5] + 1900;
$form->{attachment_filename} = $locale->quote_special_chars('filenames', $locale->text("Statement") . "_$form->{todate}.$attachment_suffix");
$form->{attachment_filename} =~ s/\s+/_/g;
- $form->parse_template(\%myconfig, $main::userspath);
+ $form->parse_template(\%myconfig);
}
}
} else {
$media = qq|
<option value=screen $form->{OP}{screen}>| . $locale->text('Screen');
- if ($myconfig{printer} && $main::latex_templates) {
+ if ($myconfig{printer} && $::lx_office_conf{print_templates}->{latex}) {
$media .= qq|
<option value=printer $form->{OP}{printer}>| . $locale->text('Printer');
}
}
my $format;
- if ($main::latex_templates) {
+ if ($::lx_office_conf{print_templates}->{latex}) {
$format .= qq|
<option value=html $form->{DF}{html}>| . $locale->text('HTML')
. qq| <option value=pdf $form->{DF}{pdf}>| . $locale->text('PDF')
<td><select name=media>$media</select></td>
|;
- if ($myconfig{printer} && $main::latex_templates && $form->{media} ne 'email') {
+ if ($myconfig{printer} && $::lx_office_conf{print_templates}->{latex} && $form->{media} ne 'email') {
$output .= qq|
<td>| . $locale->text('Copies') . qq|
<input name=copies size=2 value=$form->{copies}></td>
my $sepa_xml = SL::SEPA::XML->new('company' => $myconfig->{company},
'creditor_id' => $myconfig->{sepa_creditor_id},
- 'src_charset' => $main::dbcharset || 'ISO-8859-15',
+ 'src_charset' => $::lx_office_conf{system}->{dbcharset} || 'ISO-8859-15',
'message_id' => $message_id,
'grouped' => 1,
'collection' => $vc eq 'customer',
$form->error($locale->text('The warehouse or the bin is missing.'));
}
- if (!$main::show_best_before) {
+ if (!$::lx_office_conf{system}->{show_best_before}) {
$form->{bestbefore} = '';
}
+++ /dev/null
-#!/usr/bin/perl
-
-# Das Passwort für den Zugang zum Administrationsfrontend im Klartext.
-# Kann nur in dieser Datei geändert werden, nicht im Administrationsfrontend
-# selber.
-$self->{admin_password} = 'admin';
-
-# Welches Modul soll zur Authentifizierung der Logins benutzt werden?
-# Entweder 'DB' oder 'LDAP'.
-#
-# Wenn LDAP-Authentifizierung benutzt wird, dann kann der Benutzer sein
-# Passwort nicht über Lx-Office ändern.
-$self->{module} = 'DB';
-
-# Verbindungsinformationen zur Datenbank mit den Benutzer- und
-# Gruppeninformationen. Wird auch dann benötigt, wenn gegen einen
-# LDAP-Server authentifiziert wird, weil dieser nur zur Passwortüberprüfung
-# benutzt wird. Der Rest der Benutzerdaten ist in der Datenbank hinterlegt.
-#
-# Ist 'module' = 'DB' dann wird diese Datenbank auch für die
-# Passwortüberprüfung benutzt.
-$self->{DB_config} = {
- 'host' => 'localhost',
- 'port' => 5432,
- 'db' => 'lxerp_auth',
- 'user' => 'lxoffice',
- 'password' => '',
-};
-
-# Wird nur benötigt, wenn 'module' = 'LDAP' ist. An diesem LDAP-Server
-# werden die Benutzerpasswörter durch einen LDAP-Bind überprüft.
-#
-# Es müssen mindestens die Parameter host, attribute und base_dn
-# angegeben werden.
-#
-# tls: Verschlüsselung per TLS erzwingen
-# attribute: Das LDAP-Attribut, das den Loginnamen enthält
-# base_dn: Basis-DN, ab der der LDAP-Baum durchsucht wird
-# filter: Ein optionaler LDAP-Filter. Die Zeichenkette '<%login%>' wird
-# innerhalb des Filters durch den Loginnamen ersetzt.
-# bind_dn und bind_password:
-# Wenn zum Durchsuchen des LDAP-Baumes eine Anmeldung erforderlich
-# ist (z.B. beim ActiveDirectory), dann müssen diese beiden
-# Parameter gesetzt sein.
-$self->{LDAP_config} = {
- 'host' => 'localhost',
- 'port' => 389,
- 'tls' => 0,
- 'attribute' => 'uid',
- 'base_dn' => '',
- 'filter' => '',
-
- 'bind_dn' => undef,
- 'bind_password' => undef,
-};
-
-# Der Name des Cookies kann geändert werden, sofern gewünscht.
-# $self->{cookie_name} = 'lx_office_erp_session_id';
-
-# Die Zeitspanne, bis eine inaktive Session ungültig wird, kann
-# hier geändert werden. Der Standardwert ist acht Stunden.
-# Die Angabe ist in Minuten.
-# $self->{session_timeout} = 8 * 60;
-
-1;
+++ /dev/null
-[Console]
-
-# autologin to use if none is given
-login = demo
-
-# autorun lines will be executed after autologin.
-# be warned that loading huge libraries will noticably lengthen startup time.
-#autorun = use SL::Module
-# = use SL::Other::Module
-
-# location of history file for permanent history
-history_file = users/console_history
-
+++ /dev/null
-use Cwd;
-
-our (
- $dbcharset, $eur, $ghostscript_bin, $html2ps_bin, $language, $latex_bin,
- $latex_templates, $lizenzen, $memberfile, $opendocument_templates,
- $openofficeorg_daemon, $openofficeorg_daemon_port, $openofficeorg_writer_bin,
- $parts_image_css, $parts_listing_images, $parts_show_image, $pg_dump_exe,
- $pg_restore_exe, $sendmail, $show_best_before, $sid, $spool, $templates,
- $userspath, $vertreter, $webdav, $xvfb_bin
-);
-
-# path to user configuration files
-$userspath = "users";
-
-# spool directory for batch printing
-$spool = "spool";
-
-# templates base directory
-$templates = "templates";
-
-# member file
-$memberfile = "users/members";
-
-# Wenn Einnahmen-Überschussrechnung, dann auf 1 setzen
-# Wenn Bilanzierung (z.B. GmbH), dann auf 0 setzen
-$eur = 1;
-
-# location of sendmail
-$sendmail = '| /usr/sbin/sendmail -t<%if myconfig_email%> -f <%myconfig_email%><%end%>';
-
-# set language for login and admin
-# currently "de" (German), "de_DE" (new German) and "en" (English, not perfect) are available
-$language = "de";
-
-# Oracle
-$sid = "T80509";
-$ENV{"ORACLE_HOME"} = "/usr/local/oracle";
-
-# if you have latex installed set to 1
-$latex_templates = 1;
-
-# if the server can't find gzip, latex, dvips or pdflatex, add the path
-$ENV{PATH} .= ":/usr/local/bin";
-
-# on mac os X using Fink's Perl libs, add the path
-$ENV{PERL5LIB} .= ":/sw/lib/perl5";
-
-# Aktivierung der verschiedenen Spezialmodule
-$webdav = 0;
-$lizenzen = 1;
-$vertreter = 0;
-$excel_templates = 0; # Minimalunterstützung für Excel-Druckvorlagen
-
-# Zeige Felder für Mindesthaltbarkeitsdatum
-$show_best_before = 0;
-
-## Artikelbilder anzeigen
-# Artikelbild in der Detailansicht anzeigen
-$parts_show_image = 1; # [0|1]
-$parts_image_css = 'border:0;float:left;max-width:250px;margin-top:20px:margin-right:10px;margin-left:10px;'; # [belibige valide css definiton]
-# Artikelbilder per default in den Suchergebnissen anzeigen
-$parts_listing_images = 0; # [0|1]
-
-## Support fuer OpenDocument-Vorlagen
-# Diese Option legt fest, ob OpenDocument-Vorlagen generell verfuegbar sind.
-$opendocument_templates = 1;
-
-# Die folgenden zwei Variablen legen Pfade zu Programmen fest, die benoetigt
-# werden, um OpenDocument-Vorlagen in PDFs umzuwandeln.
-
-# Pfad zu OpenOffice.org writer
-$openofficeorg_writer_bin = "/usr/bin/oowriter";
-
-# Soll OpenOffice dauerhaft gestartet bleiben? Die Konvertierung nachfolgender
-# Dokumente geht dann schneller. Allerdings wird auf dem System ein
-# installiertes Python mit den Python-UNO-Bindings benoetigt, die Bestandteil
-# von OpenOffice sind.
-$openofficeorg_daemon = 1;
-$openofficeorg_daemon_port = 2002;
-
-# Pfad zum "X virtual frame buffer", unter dem OpenOffice gestartet wird.
-# Zusaetzlich muessen die Programme "xauth" und "mcookie" gefunden werden
-# koennen, was eine Aenderung an PATH bedeuten kann.
-$ENV{"PATH"} = $ENV{"PATH"} . ":/usr/X11R6/bin:/usr/X11/bin";
-$xvfb_bin = "/usr/bin/Xvfb";
-
-# Das charset, in dem die Daten in der Datenbank abgelegt sind.
-$dbcharset = 'UTF-8'; # Für UNICODE UTF-8
-# $dbcharset = "ISO-8859-15";
-
-
-# Pfad zu 'html2ps' zum Export von Listenansichten als PDF
-$html2ps_bin = "/usr/bin/html2ps";
-$ghostscript_bin = "/usr/bin/gs";
-
-# Name von bzw. Pfad zu 'pdflatex' oder einer anderen kompatiblen Version
-# wie z.B. 'xetex'
-$latex_bin = 'pdflatex';
-
-# Datenbankbackups werden mit dem externen Programm "pg_dump" erledigt.
-# Wenn es nicht im aktuellen Pfad vorhanden ist, so muss hier der vollständige
-# Pfad eingetragen werden. Wenn die Variable auf "DISABLED" gesetzt wird,
-# so wird der Menüpunkt zum Backup von Datenbanken im Administrationsfrontend
-# nicht angeboten.
-# Das gleiche gilt analog für das Wiederherstellen mittels "pg_restore".
-$pg_dump_exe = "pg_dump";
-$pg_restore_exe = "pg_restore";
-
-# Globale Debug-Ausgaben (de-)aktivieren? Moegliche Werte sind
-# LXDebug::NONE - keine Debugausgaben
-# LXDebug::INFO
-# LXDebug::DEBUG1
-# LXDebug::DEBUG2
-# LXDebug::QUERY - SQL Queries
-# LXDebug::TRACE - Tracing von Funktionsaufrufen
-# LXDebug::BACKTRACE_ON_ERROR - Vollständiger Aufrufpfad, wenn $form->error() aufgerufen wird
-# LXDebug::REQUEST_TIMER - Timing von Requests loggen
-# LXDebug::WARN - warnings
-# LXDebug::ALL - alle Debugausgaben
-#
-# LXDebug::DEVEL - wie INFO | QUERY | TRACE | BACKTRACE_ON_ERROR
-#
-# Beipiel:
-# $LXDebug::global_level = LXDebug::TRACE | LXDebug::QUERY;
-$LXDebug::global_level = LXDebug->NONE;
-
-# Überwachung der Inhalte von $form aktiviert oder nicht? Wenn ja,
-# dann können einzelne Variablen mit
-# $form->{"Watchdog::<variablenname>"} = 1;
-# überwacht werden. Bedeutet aber auch einen Geschwindigkeitsverlust,
-# weshalb sie normalerweise deaktiviert ist.
-$LXDebug::watch_form = 0;
-
-# Zum debuggen von Latexausgaben. Wenn diese Option auf 1 gesetzt wird, werden
-# temporäre Dateien, die bei der Erstellung von PDFs aus Latex erzeugt werden,
-# nach Abschluß der Erstellung oder im Fehlerfall nicht gelöscht, damit man sie
-# untersuchen kann.
-$::keep_temp_files = 0;
-
-1;
+++ /dev/null
-use Cwd;
-
-our (
- $dbcharset, $eur, $ghostscript_bin, $html2ps_bin, $language, $latex_bin,
- $latex_templates, $lizenzen, $memberfile, $opendocument_templates,
- $openofficeorg_daemon, $openofficeorg_daemon_port, $openofficeorg_writer_bin,
- $parts_image_css, $parts_listing_images, $parts_show_image, $pg_dump_exe,
- $pg_restore_exe, $sendmail, $show_best_before, $sid, $spool, $templates,
- $userspath, $vertreter, $webdav, $xvfb_bin
-);
-
-# path to user configuration files
-$userspath = "users";
-
-# spool directory for batch printing
-$spool = "spool";
-
-# templates base directory
-$templates = "templates";
-
-# member file
-$memberfile = "users/members";
-
-# Wenn Einnahmen-Überschussrechnung, dann auf 1 setzen
-# Wenn Bilanzierung (z.B. GmbH), dann auf 0 setzen
-$eur = 1;
-
-# location of sendmail
-$sendmail = '| /usr/sbin/sendmail -t<%if myconfig_email%> -f <%myconfig_email%><%end%>';
-
-# set language for login and admin
-# currently "de" (German), "de_DE" (new German) and "en" (English, not perfect) are available
-$language = "de";
-
-# Oracle
-$sid = "T80509";
-$ENV{"ORACLE_HOME"} = "/usr/local/oracle";
-
-# if you have latex installed set to 1
-$latex_templates = 1;
-
-# if the server can't find gzip, latex, dvips or pdflatex, add the path
-$ENV{PATH} .= ":/usr/local/bin";
-
-# on mac os X using Fink's Perl libs, add the path
-$ENV{PERL5LIB} .= ":/sw/lib/perl5";
-
-# Aktivierung der verschiedenen Spezialmodule
-$webdav = 0;
-$lizenzen = 1;
-$vertreter = 0;
-$excel_templates = 0; # Minimalunterstützung für Excel-Druckvorlagen
-
-# Zeige Felder für Mindesthaltbarkeitsdatum
-$show_best_before = 0;
-
-## Artikelbilder anzeigen
-# Artikelbild in der Detailansicht anzeigen
-$parts_show_image = 1; # [0|1]
-$parts_image_css = 'border:0;float:left;max-width:250px;margin-top:20px:margin-right:10px;margin-left:10px;'; # [belibige valide css definiton]
-# Artikelbilder per default in den Suchergebnissen anzeigen
-$parts_listing_images = 0; # [0|1]
-
-## Support fuer OpenDocument-Vorlagen
-# Diese Option legt fest, ob OpenDocument-Vorlagen generell verfuegbar sind.
-$opendocument_templates = 1;
-
-# Die folgenden zwei Variablen legen Pfade zu Programmen fest, die benoetigt
-# werden, um OpenDocument-Vorlagen in PDFs umzuwandeln.
-
-# Pfad zu OpenOffice.org writer
-$openofficeorg_writer_bin = "/usr/bin/oowriter";
-
-# Soll OpenOffice dauerhaft gestartet bleiben? Die Konvertierung nachfolgender
-# Dokumente geht dann schneller. Allerdings wird auf dem System ein
-# installiertes Python mit den Python-UNO-Bindings benoetigt, die Bestandteil
-# von OpenOffice sind.
-$openofficeorg_daemon = 1;
-$openofficeorg_daemon_port = 2002;
-
-# Pfad zum "X virtual frame buffer", unter dem OpenOffice gestartet wird.
-# Zusaetzlich muessen die Programme "xauth" und "mcookie" gefunden werden
-# koennen, was eine Aenderung an PATH bedeuten kann.
-$ENV{"PATH"} = $ENV{"PATH"} . ":/usr/X11R6/bin:/usr/X11/bin";
-$xvfb_bin = "/usr/bin/Xvfb";
-
-# Das charset, in dem die Daten in der Datenbank abgelegt sind.
-$dbcharset = 'UTF-8'; # Für UNICODE UTF-8
-# $dbcharset = "ISO-8859-15";
-
-
-# Pfad zu 'html2ps' zum Export von Listenansichten als PDF
-$html2ps_bin = "/usr/bin/html2ps";
-$ghostscript_bin = "/usr/bin/gs";
-
-# Name von bzw. Pfad zu 'pdflatex' oder einer anderen kompatiblen Version
-# wie z.B. 'xetex'
-$latex_bin = 'pdflatex';
-
-# Datenbankbackups werden mit dem externen Programm "pg_dump" erledigt.
-# Wenn es nicht im aktuellen Pfad vorhanden ist, so muss hier der vollständige
-# Pfad eingetragen werden. Wenn die Variable auf "DISABLED" gesetzt wird,
-# so wird der Menüpunkt zum Backup von Datenbanken im Administrationsfrontend
-# nicht angeboten.
-# Das gleiche gilt analog für das Wiederherstellen mittels "pg_restore".
-$pg_dump_exe = "pg_dump";
-$pg_restore_exe = "pg_restore";
-
-# Globale Debug-Ausgaben (de-)aktivieren? Moegliche Werte sind
-# LXDebug::NONE - keine Debugausgaben
-# LXDebug::INFO
-# LXDebug::DEBUG1
-# LXDebug::DEBUG2
-# LXDebug::QUERY - SQL Queries
-# LXDebug::TRACE - Tracing von Funktionsaufrufen
-# LXDebug::BACKTRACE_ON_ERROR - Vollständiger Aufrufpfad, wenn $form->error() aufgerufen wird
-# LXDebug::REQUEST_TIMER - Timing von Requests loggen
-# LXDebug::WARN - warnings
-# LXDebug::ALL - alle Debugausgaben
-#
-# LXDebug::DEVEL - wie INFO | QUERY | TRACE | BACKTRACE_ON_ERROR
-#
-# Beipiel:
-# $LXDebug::global_level = LXDebug::TRACE | LXDebug::QUERY;
-$LXDebug::global_level = LXDebug->NONE;
-
-# Überwachung der Inhalte von $form aktiviert oder nicht? Wenn ja,
-# dann können einzelne Variablen mit
-# $form->{"Watchdog::<variablenname>"} = 1;
-# überwacht werden. Bedeutet aber auch einen Geschwindigkeitsverlust,
-# weshalb sie normalerweise deaktiviert ist.
-$LXDebug::watch_form = 0;
-
-# Zum debuggen von Latexausgaben. Wenn diese Option auf 1 gesetzt wird, werden
-# temporäre Dateien, die bei der Erstellung von PDFs aus Latex erzeugt werden,
-# nach Abschluß der Erstellung oder im Fehlerfall nicht gelöscht, damit man sie
-# untersuchen kann.
-$::keep_temp_files = 0;
-
-1;
--- /dev/null
+[authentication]
+# The cleartext password for access to the administrative part. It
+# can only be changed in this file, not via the administrative
+# interface.
+admin_password = admin123
+
+# Which module to use for authentication. Valid values are 'DB' and
+# 'LDAP'. If 'LDAP' is used then users cannot change their password
+# via Lx-Office.
+module = DB
+
+# The cookie name can be changed if desired.
+cookie_name = lx_office_erp_session_id
+
+# The number of minutes a session is valid. The default value is eight
+# hours.
+session_timeout = 480
+
+[authentication/database]
+# Connection information for the database with the user and group
+# inforamtion. This information is always needed, even if LDAP is
+# used for authentication, as the user information is stored in this
+# database while LDAP is only used for password verification.
+#
+# If 'module' is set to 'DB' then this database also contains the
+# users' passwords.
+host = localhost
+port = 5432
+db = lxerp_auth
+user = postgres
+password =
+
+[authentication/ldap]
+# This section is only relevant if 'module' is set to 'LDAP'. It names
+# the LDAP server the passwords are verified against by doing a LDAP
+# bind operation.
+#
+# At least the parameters 'host', 'aatribute' and 'base_dn' have to be
+# specified.
+#
+# tls: Activate encryption via TLS
+# attribute: Name of the LDAP attribute containing the user's login name
+# base_dn: Base DN the LDAP searches start from
+# filter: An optional LDAP filter specification. The string '<%login%>'
+# is replaced by the user's login name before the search is started.
+# bind_dn and bind_password:
+# If searching the LDAP tree requires user credentials
+# (e.g. ActiveDirectory) then these two parameters specify
+# the user name and password to use.
+host = localhost
+port = 389
+tls = 0
+attribute = uid
+base_dn =
+filter =
+bind_dn =
+bind_password =
+
+[system]
+# EUR: Einnahmen-Überschussrechnung (net income method). Set this to 1
+# if your company uses the net income method and to 0 for balacing.
+eur = 1
+
+# Set language for login and admin forms. Currently "de" (German),
+# "de_DE" (new German) and "en" (English, not perfect) are available.
+language = de
+
+# The database charset. Must match the database cluster you want to
+# connect to.
+dbcharset = UTF-8
+
+[features]
+# Activate certain optional features and modules.
+webdav = 0
+lizenzen = 1
+vertreter = 0
+
+# Show fields used for the best before date
+show_best_before = 0
+
+## Pictures for parts
+# Show the picture in the part form
+parts_show_image = 1
+# Style the picture with the following CSS code:
+parts_image_css = border:0;float:left;max-width:250px;margin-top:20px:margin-right:10px;margin-left:10px;
+# Show the picture in the results when you search for parts
+parts_listing_images = 0
+
+[paths]
+# path to temporary files (must be writeable by the web server)
+userspath = users
+# spool directory for batch printing
+spool = spool
+# templates base directory
+templates = templates
+# Path to the old memberfile (ignored on new installations)
+memberfile = users/members
+
+[applications]
+# Location of sendmail
+sendmail = /usr/sbin/sendmail -t<%if myconfig_email%> -f <%myconfig_email%><%end%>
+# Location of OpenOffice.org writer
+openofficeorg_writer = oowriter
+# Location of the X virtual frame buffer used for OpenOffice
+xvfb = Xvfb
+# Location of the html2ps binary
+html2ps = html2ps
+# Location of the Ghostscript binary
+ghostscript = gs
+# Location of the pdflatex (or compatible, e.g. xetex) binary
+latex = pdflatex
+# Location of the two executables "pg_dump" and "pg_restore" used for
+# database backup and restoration from the admin section. If
+# "pg_dump" or "pg_restore" is set to "DISABLED" then the
+# corresponding option (backup/restoration) will be hidden from the
+# admin section.
+pg_dump = pg_dump
+pg_restore = pg_restore
+
+[environment]
+# Add the following paths to the PATH environment variable.
+path = /usr/local/bin:/usr/X11R6/bin:/usr/X11/bin
+# Add the following paths to the PERL5LIB environment variable.
+# "/sw/lib/perl5" is for Mac OS X with Fink's Perl.
+lib = /sw/lib/perl5
+
+[print_templates]
+# If you have LaTeX installed set to 1
+latex = 1
+# Minimal support for Excel print templates
+excel = 0
+# Enable or disable support for OpenDocument print templates
+opendocument = 1
+# Chose whether or not OpenOffice should remain running after a
+# conversion. If yes then the conversion of subsequent documents will
+# be a lot faster. You need to have Python and the Python UNO bindings
+# (part of OpenOffice) installed.
+openofficeorg_daemon = 1
+openofficeorg_daemon_port = 2002
+
+[task_server]
+# User name to use for database access
+login =
+# Set to 1 for debug messages in /tmp/lx-office-debug.log
+debug = 1
+# Chose a system user the daemon should run under when started as root.
+run_as =
+
+[periodic_invoices]
+# The user name a report about the posted and printed invoices is sent
+# to.
+send_email_to = mb
+# 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
+
+[console]
+# autologin to use if none is given
+login =
+
+# autorun lines will be executed after autologin.
+# be warned that loading huge libraries will noticably lengthen startup time.
+#autorun = require "bin/mozilla/common.pl";
+# = use English qw(-no_match_vars);
+# = use List::Util qw(min max);
+# = sub take { my $max = shift; my $r = ref($_[0]) eq 'ARRAY' ? $_[0] : \@_; return @{$r}[0..List::Util::min($max, scalar(@{$r})) - 1]; }
+
+# location of history file for permanent history
+history_file = users/console_history
+
+[debug]
+# Use DBIx::Log4perl for logging DBI calls. The string LXDEBUGFILE
+# will be replaced by the file name configured for $::lxdebug.
+dbix_log4perl = 0
+dbix_log4perl_config = log4perl.logger = FATAL, LOGFILE
+ = log4perl.appender.LOGFILE=Log::Log4perl::Appender::File
+ = log4perl.appender.LOGFILE.filename=LXDEBUGFILE
+ = log4perl.appender.LOGFILE.mode=append
+ = log4perl.appender.LOGFILE.Threshold = ERROR
+ = log4perl.appender.LOGFILE.layout=PatternLayout
+ = log4perl.appender.LOGFILE.layout.ConversionPattern=[%r] %F %L %c - %m%n
+ = log4perl.logger.DBIx.Log4perl=DEBUG, A1
+ = log4perl.appender.A1=Log::Log4perl::Appender::File
+ = log4perl.appender.A1.filename=LXDEBUGFILE
+ = log4perl.appender.A1.mode=append
+ = log4perl.appender.A1.layout=Log::Log4perl::Layout::PatternLayout
+ = log4perl.appender.A1.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
+
+# Activate certain global debug messages. If you want to combine
+# several options then list them seperated by spaces.
+#
+# Possible values include:
+# NONE - no debug output (default)
+# INFO
+# DEBUG1
+# DEBUG2
+# QUERY - Dump SQL queries (only in legacy code; see also "dbix_log4perl" above)
+# TRACE - Track function calls and returns
+# BACKTRACE_ON_ERROR - Print a function call backtrace when $form->error() is called
+# REQUEST_TIMER - Log timing of HTTP requests
+# WARN - warnings
+# ALL - all possible debug messages
+#
+# DEVEL - sames as "INFO QUERY TRACE BACKTRACE_ON_ERROR REQUEST_TIMER"
+#
+# Example:
+# global_level = TRACE QUERY
+global_level = NONE
+
+# Activate monitoring of the content of $form. If it is active then
+# monitoring can be turned on for certain variables with the
+# following:
+# $form->{"Watchdog::<variable>"} = 1;
+# Monitoring has a performance cost and is therefore deactivated by
+# default.
+watch_form = 0
+
+# If you want to debug the creation of LaTeX files then set this to 1.
+# That way the temporary LaTeX files created during PDF creation are
+# not removed and remain in the "users" directory.
+keep_temp_files = 0
+
+# The file name where the debug messages are written to.
+file_name = /tmp/mb-lxdebug.log
@item
CGI::Ajax
@item
+Config::Std
+@item
DateTime
@item
DBI
@item
List::MoreUtils
@item
+Params::Validate
+@item
PDF::API2
@item
Rose::Object
Für Debian oder Ubuntu benötigen Sie diese Pakete:
-@code{apache2 postgresql libparent-perl libarchive-zip-perl libclass-accessor-perl libdatetime-perl libdbi-perl libdbd-pg-perl libpg-perl libemail-address-perl liblist-moreutils-perl libpdf-api2-perl librose-object-perl librose-db-perl librose-db-object-perl libtemplate-perl libtext-csv-xs-perl libtext-iconv-perl liburi-perl libxml-writer-perl libyaml-perl}
+@code{apache2 postgresql libparent-perl libarchive-zip-perl libclass-accessor-perl libdatetime-perl libdbi-perl libdbd-pg-perl libpg-perl libemail-address-perl liblist-moreutils-perl libpdf-api2-perl librose-object-perl librose-db-perl librose-db-object-perl libtemplate-perl libtext-csv-xs-perl libtext-iconv-perl liburi-perl libxml-writer-perl libyaml-perl libconfig-std-perl libparams-validate-perl}
Für Fedora Core benötigen Sie diese Pakete:
Welche Art der Passwortüberprüfung Lx-Office benutzt und wie Lx-Office
die Authentifizierungsdatenbank erreichen kann, wird in der
-Konfigurationsdatei @code{config/authentication.pl} festgelegt. Diese
+Konfigurationsdatei @code{config/lx_office.conf} festgelegt. Diese
muss bei der Installation und bei einem Upgrade von einer Version vor
v2.6.0 angelegt werden. Eine Beispielkonfigurationsdatei
-@code{config/authentication.pl.default} existiert, die als Vorlage
+@code{config/lx_office.conf.default} existiert, die als Vorlage
benutzt werden kann.
@node Administratorpasswort
@node Anlegen der Authentifizierungsdatenbank
@section Anlegen der Authentifizierungsdatenbank
-Nachdem alle Einstellungen in @code{config/authentication.pl}
+Nachdem alle Einstellungen in @code{config/lx_office.conf}
vorgenommen wurden, muss Lx-Office die Authentifizierungsdatenbank
anlegen. Dieses geschieht automatisch, wenn Sie sich im
Administrationsmodul anmelden, das unter der folgenden URL erreichbar
@uref{http://localhost/lx-erp/admin.pl}
Verwenden Sie zur Anmeldung das Password, dass Sie in der Datei
-@code{config/authentication.pl} eingetragen haben.
+@code{config/lx_office.conf} eingetragen haben.
@menu
* Zusammenhänge:: Übersicht über Benutzer, Gruppen, Berechtigungen und Datenbanken
Wenn Sie für die Lx-Office-Installation nicht den europäischen
Schriftsatz ISO-8859-15 sondern UTF-8 (Unicode) benutzen wollen, so
müssen Sie vor dem Anlegen der Datenbank in der Datei
-@code{config/lx-erp.conf} die Variable @code{$dbcharset} auf den Wert
-@samp{UTF-8} setzen. Zusätzlich muss beim Anlegen der Datenbank
-@samp{UTF-8 Unicode} als Schriftsatz ausgewählt werden.
+@code{config/lx_office.conf} die Variable @code{dbcharset} im
+Abschnitt @code{system} auf den Wert @samp{UTF-8} setzen. Zusätzlich
+muss beim Anlegen der Datenbank @samp{UTF-8 Unicode} als Schriftsatz
+ausgewählt werden.
Bitte beachten Sie, dass alle Datenbanken den selben Zeichensatz
verwenden müssen, da diese Einstellungen momentan global in Lx-Office
erzeugt. Lx-Office kann dabei sowohl neue OpenDocument-Dokumente als
auch aus diesen direkt PDF-Dateien erzeugen. Um die Unterstützung von
OpenDocument-Vorlagen zu aktivieren muss in der Datei
-@code{config/lx-erp.conf} die Variable @code{$opendocument_templates}
-auf @samp{1} stehen. Dieses ist die Standardeinstellung.
+@code{config/lx_office.conf} die Variable @code{opendocument} im
+Abschnitt @code{print_templates} auf @samp{1} stehen. Dieses ist die
+Standardeinstellung.
-Weiterhin muss in der Datei @code{config/lx-erp.conf} die Variable
-@code{$dbcharset} auf die Zeichenkodierung gesetzt werden, die auch
-bei der Speicherung der Daten in der Datenbank verwendet wird. Diese
-ist in den meisten Fällen "UTF-8".
+Weiterhin muss in der Datei @code{config/lx_office.conf} die Variable
+@code{dbcharset} im Abschnitt @code{system} auf die Zeichenkodierung
+gesetzt werden, die auch bei der Speicherung der Daten in der
+Datenbank verwendet wird. Diese ist in den meisten Fällen "UTF-8".
Während die Erzeugung von reinen OpenDocument-Dateien keinerlei
weitere Software benötigt, wird zur Umwandlung dieser Dateien in PDF
(xvfb) installiert werden. Bei Debian ist er im Paket ``xvfb''
enthalten. Andere Distributionen enthalten ihn in anderen Paketen.
-Nach der Installation müssen in der Datei @code{config/lx-erp.conf}
-zwei weitere Variablen angepasst werden:
-@code{$openofficeorg_writer_bin} muss den vollständigen Pfad zur
-OpenOffice.org Writer-Anwendung enthalten. @code{$xvfb_bin} muss den
-Pfad zum ``X virtual frame buffer'' enthalten.
+Nach der Installation müssen in der Datei @code{config/lx_config.conf}
+zwei weitere Variablen angepasst werden: @code{openofficeorg_writer}
+muss den vollständigen Pfad zur OpenOffice.org Writer-Anwendung
+enthalten. @code{xvfb} muss den Pfad zum ``X virtual frame buffer''
+enthalten. Beide stehen im Abschnitt @code{applications}.
Zusätzlich gibt es zwei verschiedene Arten, wie Lx-Office mit
OpenOffice kommuniziert. Die erste Variante, die benutzt wird, wenn
* CGI::Ajax
+ * Config::Std
+
* DateTime
* DBI
* List::MoreUtils
+ * Params::Validate
+
* PDF::API2
* Rose::Object
libpg-perl libemail-address-perl liblist-moreutils-perl
libpdf-api2-perl librose-object-perl librose-db-perl
librose-db-object-perl libtemplate-perl libtext-csv-xs-perl
-libtext-iconv-perl liburi-perl libxml-writer-perl libyaml-perl'
+libtext-iconv-perl liburi-perl libxml-writer-perl libyaml-perl
+libconfig-std-perl libparams-validate-perl'
Für Fedora Core benötigen Sie diese Pakete:
Welche Art der Passwortüberprüfung Lx-Office benutzt und wie
Lx-Office die Authentifizierungsdatenbank erreichen kann, wird in der
-Konfigurationsdatei `config/authentication.pl' festgelegt. Diese muss
-bei der Installation und bei einem Upgrade von einer Version vor v2.6.0
+Konfigurationsdatei `config/lx_office.conf' festgelegt. Diese muss bei
+der Installation und bei einem Upgrade von einer Version vor v2.6.0
angelegt werden. Eine Beispielkonfigurationsdatei
-`config/authentication.pl.default' existiert, die als Vorlage benutzt
+`config/lx_office.conf.default' existiert, die als Vorlage benutzt
werden kann.
6.2 Administratorpasswort
6.6 Anlegen der Authentifizierungsdatenbank
===========================================
-Nachdem alle Einstellungen in `config/authentication.pl' vorgenommen
+Nachdem alle Einstellungen in `config/lx_office.conf' vorgenommen
wurden, muss Lx-Office die Authentifizierungsdatenbank anlegen. Dieses
geschieht automatisch, wenn Sie sich im Administrationsmodul anmelden,
das unter der folgenden URL erreichbar sein sollte:
`http://localhost/lx-erp/admin.pl'
Verwenden Sie zur Anmeldung das Password, dass Sie in der Datei
-`config/authentication.pl' eingetragen haben.
+`config/lx_office.conf' eingetragen haben.
7.1 Zusammenhänge
==================
Wenn Sie für die Lx-Office-Installation nicht den europäischen
Schriftsatz ISO-8859-15 sondern UTF-8 (Unicode) benutzen wollen, so
müssen Sie vor dem Anlegen der Datenbank in der Datei
-`config/lx-erp.conf' die Variable `$dbcharset' auf den Wert `UTF-8'
-setzen. Zusätzlich muss beim Anlegen der Datenbank `UTF-8 Unicode' als
-Schriftsatz ausgewählt werden.
+`config/lx_office.conf' die Variable `dbcharset' im Abschnitt `system'
+auf den Wert `UTF-8' setzen. Zusätzlich muss beim Anlegen der Datenbank
+`UTF-8 Unicode' als Schriftsatz ausgewählt werden.
Bitte beachten Sie, dass alle Datenbanken den selben Zeichensatz
verwenden müssen, da diese Einstellungen momentan global in Lx-Office
Lx-Office kann dabei sowohl neue OpenDocument-Dokumente als auch aus
diesen direkt PDF-Dateien erzeugen. Um die Unterstützung von
OpenDocument-Vorlagen zu aktivieren muss in der Datei
-`config/lx-erp.conf' die Variable `$opendocument_templates' auf `1'
-stehen. Dieses ist die Standardeinstellung.
+`config/lx_office.conf' die Variable `opendocument' im Abschnitt
+`print_templates' auf `1' stehen. Dieses ist die Standardeinstellung.
- Weiterhin muss in der Datei `config/lx-erp.conf' die Variable
-`$dbcharset' auf die Zeichenkodierung gesetzt werden, die auch bei der
-Speicherung der Daten in der Datenbank verwendet wird. Diese ist in den
-meisten Fällen "UTF-8".
+ Weiterhin muss in der Datei `config/lx_office.conf' die Variable
+`dbcharset' im Abschnitt `system' auf die Zeichenkodierung gesetzt
+werden, die auch bei der Speicherung der Daten in der Datenbank
+verwendet wird. Diese ist in den meisten Fällen "UTF-8".
Während die Erzeugung von reinen OpenDocument-Dateien keinerlei
weitere Software benötigt, wird zur Umwandlung dieser Dateien in PDF
(xvfb) installiert werden. Bei Debian ist er im Paket "xvfb"
enthalten. Andere Distributionen enthalten ihn in anderen Paketen.
- Nach der Installation müssen in der Datei `config/lx-erp.conf' zwei
-weitere Variablen angepasst werden: `$openofficeorg_writer_bin' muss
+ Nach der Installation müssen in der Datei `config/lx_config.conf'
+zwei weitere Variablen angepasst werden: `openofficeorg_writer' muss
den vollständigen Pfad zur OpenOffice.org Writer-Anwendung enthalten.
-`$xvfb_bin' muss den Pfad zum "X virtual frame buffer" enthalten.
+`xvfb' muss den Pfad zum "X virtual frame buffer" enthalten. Beide
+stehen im Abschnitt `applications'.
Zusätzlich gibt es zwei verschiedene Arten, wie Lx-Office mit
OpenOffice kommuniziert. Die erste Variante, die benutzt wird, wenn die
<title>Administratorpasswort - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort" title="Benutzerauthentifizierung und Administratorpasswort">
<link rel="prev" href="Grundlagen-zur-Benutzerauthentifizierung.html#Grundlagen-zur-Benutzerauthentifizierung" title="Grundlagen zur Benutzerauthentifizierung">
</head>
<body>
<div class="node">
-<p>
<a name="Administratorpasswort"></a>
-nächstes: <a rel="next" accesskey="n" href="Authentifizierungsdatenbank.html#Authentifizierungsdatenbank">Authentifizierungsdatenbank</a>,
-voriges: <a rel="previous" accesskey="p" href="Grundlagen-zur-Benutzerauthentifizierung.html#Grundlagen-zur-Benutzerauthentifizierung">Grundlagen zur Benutzerauthentifizierung</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Authentifizierungsdatenbank.html#Authentifizierungsdatenbank">Authentifizierungsdatenbank</a>,
+Previous: <a rel="previous" accesskey="p" href="Grundlagen-zur-Benutzerauthentifizierung.html#Grundlagen-zur-Benutzerauthentifizierung">Grundlagen zur Benutzerauthentifizierung</a>,
+Up: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
<hr>
</div>
<title>Aktuelle Hinweise - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="index.html#Top" title="Top">
<link rel="next" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete" title="Benötigte Software und Pakete">
</head>
<body>
<div class="node">
-<p>
<a name="Aktuelle-Hinweise"></a>
-nächstes: <a rel="next" accesskey="n" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete">Benötigte Software und Pakete</a>,
-voriges: <a rel="previous" accesskey="p" href="index.html#Top">Top</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete">Benötigte Software und Pakete</a>,
+Previous: <a rel="previous" accesskey="p" href="index.html#Top">Top</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
<title>Anlegen der Authentifizierungsdatenbank - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort" title="Benutzerauthentifizierung und Administratorpasswort">
<link rel="prev" href="Name-des-Session_002dCookies.html#Name-des-Session_002dCookies" title="Name des Session-Cookies">
</head>
<body>
<div class="node">
-<p>
<a name="Anlegen-der-Authentifizierungsdatenbank"></a>
-voriges: <a rel="previous" accesskey="p" href="Name-des-Session_002dCookies.html#Name-des-Session_002dCookies">Name des Session-Cookies</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
+<p>
+Previous: <a rel="previous" accesskey="p" href="Name-des-Session_002dCookies.html#Name-des-Session_002dCookies">Name des Session-Cookies</a>,
+Up: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
<hr>
</div>
<h3 class="section">6.6 Anlegen der Authentifizierungsdatenbank</h3>
-<p>Nachdem alle Einstellungen in <code>config/authentication.pl</code>
+<p>Nachdem alle Einstellungen in <code>config/lx_office.conf</code>
vorgenommen wurden, muss Lx-Office die Authentifizierungsdatenbank
anlegen. Dieses geschieht automatisch, wenn Sie sich im
Administrationsmodul anmelden, das unter der folgenden URL erreichbar
<title>Anpassung der PostgreSQL-Konfiguration - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes" title="Manuelle Installation des Programmpaketes">
<link rel="next" href="Apache_002dKonfiguration.html#Apache_002dKonfiguration" title="Apache-Konfiguration">
</head>
<body>
<div class="node">
-<p>
<a name="Anpassung-der-PostgreSQL-Konfiguration"></a>
<a name="Anpassung-der-PostgreSQL_002dKonfiguration"></a>
-nächstes: <a rel="next" accesskey="n" href="Apache_002dKonfiguration.html#Apache_002dKonfiguration">Apache-Konfiguration</a>,
-voriges: <a rel="previous" accesskey="p" href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes">Manuelle Installation des Programmpaketes</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Apache_002dKonfiguration.html#Apache_002dKonfiguration">Apache-Konfiguration</a>,
+Previous: <a rel="previous" accesskey="p" href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes">Manuelle Installation des Programmpaketes</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
<title>Apache-Konfiguration - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration" title="Anpassung der PostgreSQL-Konfiguration">
<link rel="next" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort" title="Benutzerauthentifizierung und Administratorpasswort">
</head>
<body>
<div class="node">
-<p>
<a name="Apache-Konfiguration"></a>
<a name="Apache_002dKonfiguration"></a>
-nächstes: <a rel="next" accesskey="n" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>,
-voriges: <a rel="previous" accesskey="p" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>,
+Previous: <a rel="previous" accesskey="p" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
<title>Authentifizierungsdatenbank - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort" title="Benutzerauthentifizierung und Administratorpasswort">
<link rel="prev" href="Administratorpasswort.html#Administratorpasswort" title="Administratorpasswort">
</head>
<body>
<div class="node">
-<p>
<a name="Authentifizierungsdatenbank"></a>
-nächstes: <a rel="next" accesskey="n" href="Passwort_00c3_00bcberpr_00c3_00bcfung.html#Passwort_00c3_00bcberpr_00c3_00bcfung">Passwortüberprüfung</a>,
-voriges: <a rel="previous" accesskey="p" href="Administratorpasswort.html#Administratorpasswort">Administratorpasswort</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Passwort_00c3_00bcberpr_00c3_00bcfung.html#Passwort_00c3_00bcberpr_00c3_00bcfung">Passwortüberprüfung</a>,
+Previous: <a rel="previous" accesskey="p" href="Administratorpasswort.html#Administratorpasswort">Administratorpasswort</a>,
+Up: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
<hr>
</div>
<title>Benötigte Software und Pakete - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="Aktuelle-Hinweise.html#Aktuelle-Hinweise" title="Aktuelle Hinweise">
<link rel="next" href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes" title="Manuelle Installation des Programmpaketes">
</head>
<body>
<div class="node">
-<p>
<a name="Ben%c3%b6tigte-Software-und-Pakete"></a>
<a name="Ben_00c3_00b6tigte-Software-und-Pakete"></a>
-nächstes: <a rel="next" accesskey="n" href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes">Manuelle Installation des Programmpaketes</a>,
-voriges: <a rel="previous" accesskey="p" href="Aktuelle-Hinweise.html#Aktuelle-Hinweise">Aktuelle Hinweise</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes">Manuelle Installation des Programmpaketes</a>,
+Previous: <a rel="previous" accesskey="p" href="Aktuelle-Hinweise.html#Aktuelle-Hinweise">Aktuelle Hinweise</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
<title>Benutzer anlegen - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung" title="Benutzer- und Gruppenverwaltung">
<link rel="prev" href="Gruppen-anlegen.html#Gruppen-anlegen" title="Gruppen anlegen">
</head>
<body>
<div class="node">
-<p>
<a name="Benutzer-anlegen"></a>
-nächstes: <a rel="next" accesskey="n" href="Gruppenmitgliedschaften-verwalten.html#Gruppenmitgliedschaften-verwalten">Gruppenmitgliedschaften verwalten</a>,
-voriges: <a rel="previous" accesskey="p" href="Gruppen-anlegen.html#Gruppen-anlegen">Gruppen anlegen</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Gruppenmitgliedschaften-verwalten.html#Gruppenmitgliedschaften-verwalten">Gruppenmitgliedschaften verwalten</a>,
+Previous: <a rel="previous" accesskey="p" href="Gruppen-anlegen.html#Gruppen-anlegen">Gruppen anlegen</a>,
+Up: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
<hr>
</div>
<title>Benutzer- und Gruppenverwaltung - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort" title="Benutzerauthentifizierung und Administratorpasswort">
<link rel="next" href="OpenDocument_002dVorlagen.html#OpenDocument_002dVorlagen" title="OpenDocument-Vorlagen">
</head>
<body>
<div class="node">
-<p>
<a name="Benutzer--und-Gruppenverwaltung"></a>
<a name="Benutzer_002d-und-Gruppenverwaltung"></a>
-nächstes: <a rel="next" accesskey="n" href="OpenDocument_002dVorlagen.html#OpenDocument_002dVorlagen">OpenDocument-Vorlagen</a>,
-voriges: <a rel="previous" accesskey="p" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Next: <a rel="next" accesskey="n" href="OpenDocument_002dVorlagen.html#OpenDocument_002dVorlagen">OpenDocument-Vorlagen</a>,
+Previous: <a rel="previous" accesskey="p" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
<p><a href="http://localhost/lx-erp/admin.pl">http://localhost/lx-erp/admin.pl</a>
<p>Verwenden Sie zur Anmeldung das Password, dass Sie in der Datei
-<code>config/authentication.pl</code> eingetragen haben.
+<code>config/lx_office.conf</code> eingetragen haben.
<ul class="menu">
<li><a accesskey="1" href="Zusammenh_00c3_00a4nge.html#Zusammenh_00c3_00a4nge">Zusammenhänge</a>: Übersicht über Benutzer, Gruppen, Berechtigungen und Datenbanken
<title>Benutzerauthentifizierung und Administratorpasswort - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="Apache_002dKonfiguration.html#Apache_002dKonfiguration" title="Apache-Konfiguration">
<link rel="next" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung" title="Benutzer- und Gruppenverwaltung">
</head>
<body>
<div class="node">
-<p>
<a name="Benutzerauthentifizierung-und-Administratorpasswort"></a>
-nächstes: <a rel="next" accesskey="n" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>,
-voriges: <a rel="previous" accesskey="p" href="Apache_002dKonfiguration.html#Apache_002dKonfiguration">Apache-Konfiguration</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>,
+Previous: <a rel="previous" accesskey="p" href="Apache_002dKonfiguration.html#Apache_002dKonfiguration">Apache-Konfiguration</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
<title>Betriebssystem - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete" title="Benötigte Software und Pakete">
<link rel="next" href="Pakete.html#Pakete" title="Pakete">
</head>
<body>
<div class="node">
-<p>
<a name="Betriebssystem"></a>
-nächstes: <a rel="next" accesskey="n" href="Pakete.html#Pakete">Pakete</a>,
-aufwärts: <a rel="up" accesskey="u" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete">Benötigte Software und Pakete</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Pakete.html#Pakete">Pakete</a>,
+Up: <a rel="up" accesskey="u" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete">Benötigte Software und Pakete</a>
<hr>
</div>
geben.
<p>Alternativ dazu kann die normale Installation durchgeführt werden
-(s
iehe <a href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes">Manuelle Installation des Programmpaketes</a>), wenn vorher ein
+(s
ee <a href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes">Manuelle Installation des Programmpaketes</a>), wenn vorher ein
Kompatibilitätspaket installiert wird, das die fehlenden Pakete bereitstellt.
Das Paket ist auf <a href="https://sourceforge.net/projects/lx-office/files/Lx-Office%20ERP/2.6.2/">Sourceforge</a> unter dem Namen <code>lx-erp-perl-libs-compat-v2.tar.gz</code> hinterlegt.
<p><code>libbit-vector-perl libsub-exporter-perl libclone-perl libclass-factory-util-perl</code>
- <p>Danach sollte der Installationscheck (s
iehe <a href="Pakete.html#Pakete">Pakete</a>) die enthaltenen Pakete erkennen.
+ <p>Danach sollte der Installationscheck (s
ee <a href="Pakete.html#Pakete">Pakete</a>) die enthaltenen Pakete erkennen.
</body></html>
<title>Datenbankbenutzer anlegen - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration" title="Anpassung der PostgreSQL-Konfiguration">
<link rel="prev" href="Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren.html#Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren" title="Erweiterung für servergespeicherte Prozeduren">
</head>
<body>
<div class="node">
-<p>
<a name="Datenbankbenutzer-anlegen"></a>
-voriges: <a rel="previous" accesskey="p" href="Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren.html#Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren">Erweiterung für servergespeicherte Prozeduren</a>,
-aufwärts: <a rel="up" accesskey="u" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>
+<p>
+Previous: <a rel="previous" accesskey="p" href="Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren.html#Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren">Erweiterung für servergespeicherte Prozeduren</a>,
+Up: <a rel="up" accesskey="u" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>
<hr>
</div>
<title>Datenbanken anlegen - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung" title="Benutzer- und Gruppenverwaltung">
<link rel="prev" href="Zusammenh_00c3_00a4nge.html#Zusammenh_00c3_00a4nge" title="Zusammenhänge">
</head>
<body>
<div class="node">
-<p>
<a name="Datenbanken-anlegen"></a>
-nächstes: <a rel="next" accesskey="n" href="Gruppen-anlegen.html#Gruppen-anlegen">Gruppen anlegen</a>,
-voriges: <a rel="previous" accesskey="p" href="Zusammenh_00c3_00a4nge.html#Zusammenh_00c3_00a4nge">Zusammenhänge</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Gruppen-anlegen.html#Gruppen-anlegen">Gruppen anlegen</a>,
+Previous: <a rel="previous" accesskey="p" href="Zusammenh_00c3_00a4nge.html#Zusammenh_00c3_00a4nge">Zusammenhänge</a>,
+Up: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
<hr>
</div>
<p>Wenn Sie für die Lx-Office-Installation nicht den europäischen
Schriftsatz ISO-8859-15 sondern UTF-8 (Unicode) benutzen wollen, so
müssen Sie vor dem Anlegen der Datenbank in der Datei
-<code>config/lx-erp.conf</code> die Variable <code>$dbcharset</code> auf den Wert
-‘<samp><span class="samp">UTF-8</span></samp>’ setzen. Zusätzlich muss beim Anlegen der Datenbank
-‘<samp><span class="samp">UTF-8 Unicode</span></samp>’ als Schriftsatz ausgewählt werden.
+<code>config/lx_office.conf</code> die Variable <code>dbcharset</code> im
+Abschnitt <code>system</code> auf den Wert ‘<samp><span class="samp">UTF-8</span></samp>’ setzen. Zusätzlich
+muss beim Anlegen der Datenbank ‘<samp><span class="samp">UTF-8 Unicode</span></samp>’ als Schriftsatz
+ausgewählt werden.
<p>Bitte beachten Sie, dass alle Datenbanken den selben Zeichensatz
verwenden müssen, da diese Einstellungen momentan global in Lx-Office
<title>Erweiterung für servergespeicherte Prozeduren - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration" title="Anpassung der PostgreSQL-Konfiguration">
<link rel="prev" href="_00c3_0084nderungen-an-Konfigurationsdateien.html#g_t_00c3_0084nderungen-an-Konfigurationsdateien" title="Änderungen an Konfigurationsdateien">
</head>
<body>
<div class="node">
-<p>
<a name="Erweiterung-f%c3%bcr-servergespeicherte-Prozeduren"></a>
<a name="Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren"></a>
-nächstes: <a rel="next" accesskey="n" href="Datenbankbenutzer-anlegen.html#Datenbankbenutzer-anlegen">Datenbankbenutzer anlegen</a>,
-voriges: <a rel="previous" accesskey="p" href="_00c3_0084nderungen-an-Konfigurationsdateien.html#g_t_00c3_0084nderungen-an-Konfigurationsdateien">Änderungen an Konfigurationsdateien</a>,
-aufwärts: <a rel="up" accesskey="u" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Datenbankbenutzer-anlegen.html#Datenbankbenutzer-anlegen">Datenbankbenutzer anlegen</a>,
+Previous: <a rel="previous" accesskey="p" href="_00c3_0084nderungen-an-Konfigurationsdateien.html#g_t_00c3_0084nderungen-an-Konfigurationsdateien">Änderungen an Konfigurationsdateien</a>,
+Up: <a rel="up" accesskey="u" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>
<hr>
</div>
<title>Grundlagen zur Benutzerauthentifizierung - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort" title="Benutzerauthentifizierung und Administratorpasswort">
<link rel="next" href="Administratorpasswort.html#Administratorpasswort" title="Administratorpasswort">
</head>
<body>
<div class="node">
-<p>
<a name="Grundlagen-zur-Benutzerauthentifizierung"></a>
-nächstes: <a rel="next" accesskey="n" href="Administratorpasswort.html#Administratorpasswort">Administratorpasswort</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Administratorpasswort.html#Administratorpasswort">Administratorpasswort</a>,
+Up: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
<hr>
</div>
<p>Welche Art der Passwortüberprüfung Lx-Office benutzt und wie Lx-Office
die Authentifizierungsdatenbank erreichen kann, wird in der
-Konfigurationsdatei <code>config/authentication.pl</code> festgelegt. Diese
+Konfigurationsdatei <code>config/lx_office.conf</code> festgelegt. Diese
muss bei der Installation und bei einem Upgrade von einer Version vor
v2.6.0 angelegt werden. Eine Beispielkonfigurationsdatei
-<code>config/authentication.pl.default</code> existiert, die als Vorlage
+<code>config/lx_office.conf.default</code> existiert, die als Vorlage
benutzt werden kann.
</body></html>
<title>Gruppen anlegen - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung" title="Benutzer- und Gruppenverwaltung">
<link rel="prev" href="Datenbanken-anlegen.html#Datenbanken-anlegen" title="Datenbanken anlegen">
</head>
<body>
<div class="node">
-<p>
<a name="Gruppen-anlegen"></a>
-nächstes: <a rel="next" accesskey="n" href="Benutzer-anlegen.html#Benutzer-anlegen">Benutzer anlegen</a>,
-voriges: <a rel="previous" accesskey="p" href="Datenbanken-anlegen.html#Datenbanken-anlegen">Datenbanken anlegen</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Benutzer-anlegen.html#Benutzer-anlegen">Benutzer anlegen</a>,
+Previous: <a rel="previous" accesskey="p" href="Datenbanken-anlegen.html#Datenbanken-anlegen">Datenbanken anlegen</a>,
+Up: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
<hr>
</div>
<title>Gruppenmitgliedschaften verwalten - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung" title="Benutzer- und Gruppenverwaltung">
<link rel="prev" href="Benutzer-anlegen.html#Benutzer-anlegen" title="Benutzer anlegen">
</head>
<body>
<div class="node">
-<p>
<a name="Gruppenmitgliedschaften-verwalten"></a>
-nächstes: <a rel="next" accesskey="n" href="Migration-alter-Installationen.html#Migration-alter-Installationen">Migration alter Installationen</a>,
-voriges: <a rel="previous" accesskey="p" href="Benutzer-anlegen.html#Benutzer-anlegen">Benutzer anlegen</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Migration-alter-Installationen.html#Migration-alter-Installationen">Migration alter Installationen</a>,
+Previous: <a rel="previous" accesskey="p" href="Benutzer-anlegen.html#Benutzer-anlegen">Benutzer anlegen</a>,
+Up: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
<hr>
</div>
<title>Lx-Office ERP verwenden - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="OpenDocument_002dVorlagen.html#OpenDocument_002dVorlagen" title="OpenDocument-Vorlagen">
<link href="http://www.gnu.org/software/texinfo/" rel="generator-home" title="Texinfo Homepage">
</head>
<body>
<div class="node">
-<p>
<a name="Lx-Office-ERP-verwenden"></a>
<a name="Lx_002dOffice-ERP-verwenden"></a>
-voriges: <a rel="previous" accesskey="p" href="OpenDocument_002dVorlagen.html#OpenDocument_002dVorlagen">OpenDocument-Vorlagen</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Previous: <a rel="previous" accesskey="p" href="OpenDocument_002dVorlagen.html#OpenDocument_002dVorlagen">OpenDocument-Vorlagen</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
<title>Manuelle Installation des Programmpaketes - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete" title="Benötigte Software und Pakete">
<link rel="next" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration" title="Anpassung der PostgreSQL-Konfiguration">
</head>
<body>
<div class="node">
-<p>
<a name="Manuelle-Installation-des-Programmpaketes"></a>
-nächstes: <a rel="next" accesskey="n" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>,
-voriges: <a rel="previous" accesskey="p" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete">Benötigte Software und Pakete</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>,
+Previous: <a rel="previous" accesskey="p" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete">Benötigte Software und Pakete</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
<title>Migration alter Installationen - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung" title="Benutzer- und Gruppenverwaltung">
<link rel="prev" href="Gruppenmitgliedschaften-verwalten.html#Gruppenmitgliedschaften-verwalten" title="Gruppenmitgliedschaften verwalten">
</head>
<body>
<div class="node">
-<p>
<a name="Migration-alter-Installationen"></a>
-voriges: <a rel="previous" accesskey="p" href="Gruppenmitgliedschaften-verwalten.html#Gruppenmitgliedschaften-verwalten">Gruppenmitgliedschaften verwalten</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
+<p>
+Previous: <a rel="previous" accesskey="p" href="Gruppenmitgliedschaften-verwalten.html#Gruppenmitgliedschaften-verwalten">Gruppenmitgliedschaften verwalten</a>,
+Up: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
<hr>
</div>
<title>Name des Session-Cookies - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort" title="Benutzerauthentifizierung und Administratorpasswort">
<link rel="prev" href="Passwort_00c3_00bcberpr_00c3_00bcfung.html#Passwort_00c3_00bcberpr_00c3_00bcfung" title="Passwortüberprüfung">
</head>
<body>
<div class="node">
-<p>
<a name="Name-des-Session-Cookies"></a>
<a name="Name-des-Session_002dCookies"></a>
-nächstes: <a rel="next" accesskey="n" href="Anlegen-der-Authentifizierungsdatenbank.html#Anlegen-der-Authentifizierungsdatenbank">Anlegen der Authentifizierungsdatenbank</a>,
-voriges: <a rel="previous" accesskey="p" href="Passwort_00c3_00bcberpr_00c3_00bcfung.html#Passwort_00c3_00bcberpr_00c3_00bcfung">Passwortüberprüfung</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Anlegen-der-Authentifizierungsdatenbank.html#Anlegen-der-Authentifizierungsdatenbank">Anlegen der Authentifizierungsdatenbank</a>,
+Previous: <a rel="previous" accesskey="p" href="Passwort_00c3_00bcberpr_00c3_00bcfung.html#Passwort_00c3_00bcberpr_00c3_00bcfung">Passwortüberprüfung</a>,
+Up: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
<hr>
</div>
<title>OpenDocument-Vorlagen - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="prev" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung" title="Benutzer- und Gruppenverwaltung">
<link rel="next" href="Lx_002dOffice-ERP-verwenden.html#Lx_002dOffice-ERP-verwenden" title="Lx-Office ERP verwenden">
</head>
<body>
<div class="node">
-<p>
<a name="OpenDocument-Vorlagen"></a>
<a name="OpenDocument_002dVorlagen"></a>
-nächstes: <a rel="next" accesskey="n" href="Lx_002dOffice-ERP-verwenden.html#Lx_002dOffice-ERP-verwenden">Lx-Office ERP verwenden</a>,
-voriges: <a rel="previous" accesskey="p" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>,
-aufwärts: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Lx_002dOffice-ERP-verwenden.html#Lx_002dOffice-ERP-verwenden">Lx-Office ERP verwenden</a>,
+Previous: <a rel="previous" accesskey="p" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<hr>
</div>
erzeugt. Lx-Office kann dabei sowohl neue OpenDocument-Dokumente als
auch aus diesen direkt PDF-Dateien erzeugen. Um die Unterstützung von
OpenDocument-Vorlagen zu aktivieren muss in der Datei
-<code>config/lx-erp.conf</code> die Variable <code>$opendocument_templates</code>
-auf ‘<samp><span class="samp">1</span></samp>’ stehen. Dieses ist die Standardeinstellung.
+<code>config/lx_office.conf</code> die Variable <code>opendocument</code> im
+Abschnitt <code>print_templates</code> auf ‘<samp><span class="samp">1</span></samp>’ stehen. Dieses ist die
+Standardeinstellung.
- <p>Weiterhin muss in der Datei <code>config/lx-erp.conf</code> die Variable
-<code>$dbcharset</code> auf die Zeichenkodierung gesetzt werden, die auch
-bei der Speicherung der Daten in der Datenbank verwendet wird. Diese
-ist in den meisten Fällen "UTF-8".
+ <p>Weiterhin muss in der Datei <code>config/lx_office.conf</code> die Variable
+<code>dbcharset</code> im Abschnitt <code>system</code> auf die Zeichenkodierung
+gesetzt werden, die auch bei der Speicherung der Daten in der
+Datenbank verwendet wird. Diese ist in den meisten Fällen "UTF-8".
<p>Während die Erzeugung von reinen OpenDocument-Dateien keinerlei
weitere Software benötigt, wird zur Umwandlung dieser Dateien in PDF
(xvfb) installiert werden. Bei Debian ist er im Paket “xvfb”
enthalten. Andere Distributionen enthalten ihn in anderen Paketen.
- <p>Nach der Installation müssen in der Datei <code>config/lx-erp.conf</code>
-zwei weitere Variablen angepasst werden:
-<code>$openofficeorg_writer_bin</code> muss den vollständigen Pfad zur
-OpenOffice.org Writer-Anwendung enthalten. <code>$xvfb_bin</code> muss den
-Pfad zum “X virtual frame buffer” enthalten.
+ <p>Nach der Installation müssen in der Datei <code>config/lx_config.conf</code>
+zwei weitere Variablen angepasst werden: <code>openofficeorg_writer</code>
+muss den vollständigen Pfad zur OpenOffice.org Writer-Anwendung
+enthalten. <code>xvfb</code> muss den Pfad zum “X virtual frame buffer”
+enthalten. Beide stehen im Abschnitt <code>applications</code>.
<p>Zusätzlich gibt es zwei verschiedene Arten, wie Lx-Office mit
OpenOffice kommuniziert. Die erste Variante, die benutzt wird, wenn
<p>Dieses Verzeichnis, wie auch das komplette <code>users</code>-Verzeichnis, muss vom
Webserver beschreibbar sein. Dieses wurde bereits erledigt
-(s
iehe <a href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes">Manuelle Installation des Programmpaketes</a>), kann aber erneut überprüft
+(s
ee <a href="Manuelle-Installation-des-Programmpaketes.html#Manuelle-Installation-des-Programmpaketes">Manuelle Installation des Programmpaketes</a>), kann aber erneut überprüft
werden, wenn die Konvertierung nach PDF fehlschlägt.
<!-- -->
<title>Pakete - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete" title="Benötigte Software und Pakete">
<link rel="prev" href="Betriebssystem.html#Betriebssystem" title="Betriebssystem">
</head>
<body>
<div class="node">
-<p>
<a name="Pakete"></a>
-voriges: <a rel="previous" accesskey="p" href="Betriebssystem.html#Betriebssystem">Betriebssystem</a>,
-aufwärts: <a rel="up" accesskey="u" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete">Benötigte Software und Pakete</a>
+<p>
+Previous: <a rel="previous" accesskey="p" href="Betriebssystem.html#Betriebssystem">Betriebssystem</a>,
+Up: <a rel="up" accesskey="u" href="Ben_00c3_00b6tigte-Software-und-Pakete.html#Ben_00c3_00b6tigte-Software-und-Pakete">Benötigte Software und Pakete</a>
<hr>
</div>
<li>Archive::Zip
<li>Class::Accessor
<li>CGI::Ajax
+<li>Config::Std
<li>DateTime
<li>DBI
<li>DBD::Pg
<li>Email::Address
<li>List::MoreUtils
+<li>Params::Validate
<li>PDF::API2
<li>Rose::Object
<li>Rose::DB
<p>Für Debian oder Ubuntu benötigen Sie diese Pakete:
- <p><code>apache2 postgresql libparent-perl libarchive-zip-perl libclass-accessor-perl libdatetime-perl libdbi-perl libdbd-pg-perl libpg-perl libemail-address-perl liblist-moreutils-perl libpdf-api2-perl librose-object-perl librose-db-perl librose-db-object-perl libtemplate-perl libtext-csv-xs-perl libtext-iconv-perl liburi-perl libxml-writer-perl libyaml-perl</code>
+ <p><code>apache2 postgresql libparent-perl libarchive-zip-perl libclass-accessor-perl libdatetime-perl libdbi-perl libdbd-pg-perl libpg-perl libemail-address-perl liblist-moreutils-perl libpdf-api2-perl librose-object-perl librose-db-perl librose-db-object-perl libtemplate-perl libtext-csv-xs-perl libtext-iconv-perl liburi-perl libxml-writer-perl libyaml-perl libconfig-std-perl libparams-validate-perl</code>
<p>Für Fedora Core benötigen Sie diese Pakete:
<title>Passwortüberprüfung - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort" title="Benutzerauthentifizierung und Administratorpasswort">
<link rel="prev" href="Authentifizierungsdatenbank.html#Authentifizierungsdatenbank" title="Authentifizierungsdatenbank">
</head>
<body>
<div class="node">
-<p>
<a name="Passwort%c3%bcberpr%c3%bcfung"></a>
<a name="Passwort_00c3_00bcberpr_00c3_00bcfung"></a>
-nächstes: <a rel="next" accesskey="n" href="Name-des-Session_002dCookies.html#Name-des-Session_002dCookies">Name des Session-Cookies</a>,
-voriges: <a rel="previous" accesskey="p" href="Authentifizierungsdatenbank.html#Authentifizierungsdatenbank">Authentifizierungsdatenbank</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Name-des-Session_002dCookies.html#Name-des-Session_002dCookies">Name des Session-Cookies</a>,
+Previous: <a rel="previous" accesskey="p" href="Authentifizierungsdatenbank.html#Authentifizierungsdatenbank">Authentifizierungsdatenbank</a>,
+Up: <a rel="up" accesskey="u" href="Benutzerauthentifizierung-und-Administratorpasswort.html#Benutzerauthentifizierung-und-Administratorpasswort">Benutzerauthentifizierung und Administratorpasswort</a>
<hr>
</div>
<title>Zeichensätze/die Verwendung von UTF-8 - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration" title="Anpassung der PostgreSQL-Konfiguration">
<link rel="next" href="_00c3_0084nderungen-an-Konfigurationsdateien.html#g_t_00c3_0084nderungen-an-Konfigurationsdateien" title="Änderungen an Konfigurationsdateien">
</head>
<body>
<div class="node">
-<p>
<a name="Zeichens%c3%a4tze%2fdie-Verwendung-von-UTF-8"></a>
<a name="Zeichens_00c3_00a4tze_002fdie-Verwendung-von-UTF_002d8"></a>
-nächstes: <a rel="next" accesskey="n" href="_00c3_0084nderungen-an-Konfigurationsdateien.html#g_t_00c3_0084nderungen-an-Konfigurationsdateien">Änderungen an Konfigurationsdateien</a>,
-aufwärts: <a rel="up" accesskey="u" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>
+<p>
+Next: <a rel="next" accesskey="n" href="_00c3_0084nderungen-an-Konfigurationsdateien.html#g_t_00c3_0084nderungen-an-Konfigurationsdateien">Änderungen an Konfigurationsdateien</a>,
+Up: <a rel="up" accesskey="u" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>
<hr>
</div>
<title>Zusammenhänge - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung" title="Benutzer- und Gruppenverwaltung">
<link rel="next" href="Datenbanken-anlegen.html#Datenbanken-anlegen" title="Datenbanken anlegen">
</head>
<body>
<div class="node">
-<p>
<a name="Zusammenh%c3%a4nge"></a>
<a name="Zusammenh_00c3_00a4nge"></a>
-nächstes: <a rel="next" accesskey="n" href="Datenbanken-anlegen.html#Datenbanken-anlegen">Datenbanken anlegen</a>,
-aufwärts: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Datenbanken-anlegen.html#Datenbanken-anlegen">Datenbanken anlegen</a>,
+Up: <a rel="up" accesskey="u" href="Benutzer_002d-und-Gruppenverwaltung.html#Benutzer_002d-und-Gruppenverwaltung">Benutzer- und Gruppenverwaltung</a>
<hr>
</div>
<title>Änderungen an Konfigurationsdateien - Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="index.html#Top">
<link rel="up" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration" title="Anpassung der PostgreSQL-Konfiguration">
<link rel="prev" href="Zeichens_00c3_00a4tze_002fdie-Verwendung-von-UTF_002d8.html#Zeichens_00c3_00a4tze_002fdie-Verwendung-von-UTF_002d8" title="Zeichensätze/die Verwendung von UTF-8">
</head>
<body>
<div class="node">
-<p>
<a name="%c3%84nderungen-an-Konfigurationsdateien"></a>
<a name="g_t_00c3_0084nderungen-an-Konfigurationsdateien"></a>
-nächstes: <a rel="next" accesskey="n" href="Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren.html#Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren">Erweiterung für servergespeicherte Prozeduren</a>,
-voriges: <a rel="previous" accesskey="p" href="Zeichens_00c3_00a4tze_002fdie-Verwendung-von-UTF_002d8.html#Zeichens_00c3_00a4tze_002fdie-Verwendung-von-UTF_002d8">Zeichensätze/die Verwendung von UTF-8</a>,
-aufwärts: <a rel="up" accesskey="u" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren.html#Erweiterung-f_00c3_00bcr-servergespeicherte-Prozeduren">Erweiterung für servergespeicherte Prozeduren</a>,
+Previous: <a rel="previous" accesskey="p" href="Zeichens_00c3_00a4tze_002fdie-Verwendung-von-UTF_002d8.html#Zeichens_00c3_00a4tze_002fdie-Verwendung-von-UTF_002d8">Zeichensätze/die Verwendung von UTF-8</a>,
+Up: <a rel="up" accesskey="u" href="Anpassung-der-PostgreSQL_002dKonfiguration.html#Anpassung-der-PostgreSQL_002dKonfiguration">Anpassung der PostgreSQL-Konfiguration</a>
<hr>
</div>
<title>Lx-Office Installationsanleitung</title>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
<meta name="description" content="Lx-Office Installationsanleitung">
-<meta name="generator" content="makeinfo 4.11">
+<meta name="generator" content="makeinfo 4.13">
<link title="Top" rel="start" href="#Top">
<link href="http://www.gnu.org/software/texinfo/" rel="generator-home" title="Texinfo Homepage">
<meta http-equiv="Content-Style-Type" content="text/css">
<div class="node">
-<p>
<a name="Top"></a>
-nächstes: <a rel="next" accesskey="n" href="Aktuelle-Hinweise.html#Aktuelle-Hinweise">Aktuelle Hinweise</a>,
-aufwärts: <a rel="up" accesskey="u" href="../index.html#dir">(dir)</a>
+<p>
+Next: <a rel="next" accesskey="n" href="Aktuelle-Hinweise.html#Aktuelle-Hinweise">Aktuelle Hinweise</a>,
+Up: <a rel="up" accesskey="u" href="../index.html#dir">(dir)</a>
<hr>
</div>
--- /dev/null
+File::Slurp.pm version 0.04
+===========================
+
+This module provides subroutines to read or write entire files with a
+simple call. It also has a subroutine for reading the list of filenames
+in a directory.
+
+In the extras/ directory you can read an article (slurp_article.pod)
+about file slurping and also run a benchmark (slurp_bench.pl) that
+compares many ways of slurping/spewing files.
+
+This module was first written and owned by David Muir Sharnoff (MUIR on
+CPAN). I checked out his module and decided to write a new version
+which would be faster, and with many more features. To that end, David
+graciously transfered the namespace to me.
+
+Since then, I discovered and fixed a bug in the original module's test
+script (which had only 7 tests), which is included now as t/original.t.
+This module now has 164 tests in 7 test scripts, and passes on Windows,
+Linux, Solaris and Mac OS X.
+
+There have been some comments about the somewhat unusual version number.
+The problem was that David used a future date (2004.0904) in his version
+number, and the only way I could get CPAN to index my new module was to
+make it have a version number higher than the old one, so I chose the
+9999 prefix and appended the real revision number to it.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2003 Uri Guttman <uri@stemsystems.com>
+
+Licensed the same as Perl.
--- /dev/null
+README for Sort::Naturally
+ Time-stamp: "2001-05-25 21:17:33 MDT"
+
+ Sort::Naturally
+
+[extracted from the Pod...]
+
+NAME
+ Sort::Naturally -- sort lexically, but sort numeral parts
+ numerically
+
+SYNOPSIS
+ @them = nsort(qw(
+ foo12a foo12z foo13a foo 14 9x foo12 fooa foolio Foolio Foo12a
+ ));
+ print join(' ', @them), "\n";
+
+ Prints:
+
+ 9x 14 foo fooa foolio Foolio foo12 foo12a Foo12a foo12z foo13a
+
+ (Or "foo12a" + "Foo12a" and "foolio" + "Foolio" and might be
+ switched, depending on your locale.)
+
+DESCRIPTION
+ This module exports two functions, nsort and ncmp; they are
+ used in implementing my idea of a "natural sorting"
+ algorithm. Under natural sorting, numeric substrings are
+ compared numerically, and other word-characters are compared
+ lexically.
+
+ This is the way I define natural sorting:
+
+ o Non-numeric word-character substrings are sorted
+ lexically, case-insensitively: "Foo" comes between
+ "fish" and "fowl".
+
+ o Numeric substrings are sorted numerically: "100" comes
+ after "20", not before.
+
+ o \W substrings (neither words-characters nor digits) are
+ ignored.
+
+ o Our use of \w, \d, \D, and \W is locale-sensitive:
+ Sort::Naturally uses a use locale statement.
+
+ o When comparing two strings, where a numeric substring
+ in one place is not up against a numeric substring in
+ another, the non-numeric always comes first. This is
+ fudged by reading pretending that the lack of a number
+ substring has the value -1, like so:
+
+ foo => "foo", -1
+ foobar => "foo", -1, "bar"
+ foo13 => "foo", 13,
+ foo13xyz => "foo", 13, "xyz"
+
+ That's so that "foo" will come before "foo13", which
+ will come before "foobar".
+
+ o The start of a string is exceptional: leading non-\W
+ (non-word, non-digit) components are are ignored, and
+ numbers come before letters.
+
+ o I define "numeric substring" just as sequences matching
+ m/\d+/ -- scientific notation, commas, decimals, etc.,
+ are not seen. If your data has thousands separators in
+ numbers ("20,000 Leagues Under The Sea" or "20.000
+ lieues sous les mers"), consider stripping them before
+ feeding them to nsort or ncmp.
+
+[end Pod extract]
+
+
+INSTALLATION
+
+You install Sort::Naturally, as you would install any perl module
+library, by running these commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+If you want to install a private copy of Sort::Naturally in your home
+directory, then you should try to produce the initial Makefile with
+something like this command:
+
+ perl Makefile.PL LIB=~/perl
+
+See perldoc perlmodinstall for more information on installing modules.
+
+
+DOCUMENTATION
+
+POD-format documentation is included in Naturally.pm. POD is readable
+with the 'perldoc' utility. See ChangeLog for recent changes.
+
+
+SUPPORT
+
+Questions, bug reports, useful code bits, and suggestions for
+Sort::Naturally should just be sent to me at sburke@cpan.org
+
+
+AVAILABILITY
+
+The latest version of Sort::Naturally is available from the
+Comprehensive Perl Archive Network (CPAN). Visit
+<http://www.perl.com/CPAN/> to find a CPAN site near you.
+
+
+COPYRIGHT
+
+Copyright 2001, Sean M. Burke <sburke@cpan.org>, all rights
+reserved.
+
+The programs and documentation in this dist are distributed in
+the hope that they will be useful, but without any warranty; without
+even the implied warranty of merchantability or fitness for a
+particular purpose.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
--- /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);
+}
'4. Quarter' => '4. Quartal',
'<b>What</b> do you want to look for?' => '<b>Wonach</b> wollen Sie suchen?',
'A Buchungsgruppe consists of a descriptive name and the account numbers for the income and expense accounts for those four tax zones as well as the inventory account number.' => 'Eine Buchungsgruppe besteht aus einem deskriptiven Namen, den Erlös- und Aufwandskonten für diese vier Steuerzonen sowie aus einem Inventarkonto.',
+ 'A digit is required.' => 'Eine Ziffer ist vorgeschrieben.',
'A group named "Full Access" has been created.' => 'Eine Gruppe namens "Vollzugriff" wurde angelegt.',
'A group with that name does already exist.' => 'Eine Gruppe mit diesem Namen gibt es bereits.',
'A lot of the usability of Lx-Office has been enhanced with javascript. Although it is currently possible to use every aspect of Lx-Office without javascript, we strongly recommend it. In a future version this may change and javascript may be necessary to access advanced features.' => 'Die Bedienung von Lx-Office wurde an vielen Stellen mit Javascript verbessert. Obwohl es derzeit möglich ist, jeden Aspekt von Lx-Office auch ohne Javascript zu benutzen, empfehlen wir es. In einer zukünftigen Version wird Javascript eventuell notwendig sein um weitergehende Features zu benutzen.',
+ 'A lower-case character is required.' => 'Ein Kleinbuchstabe ist vorgeschrieben.',
+ 'A special character is required (valid characters: #1).' => 'Ein Sonderzeichen ist vorgeschrieben (gültige Zeichen: #1).',
'A temporary directory could not be created:' => 'Ein temporäres Verzeichnis konnte nicht erstellt werden:',
'A temporary file could not be created. Please verify that the directory "#1" is writeable by the webserver.' => 'Eine temporäre Datei konnte nicht angelegt werden. Bitte stellen Sie sicher, dass das Verzeichnis "#1" vom Webserver beschrieben werden darf.',
'A temporary file could not be created:' => 'Eine temporäre Datei konnte nicht erstellt werden:',
'Amount' => 'Betrag',
'Amount Due' => 'Betrag fällig',
'Amount has to be greater then zero! Wrong row number: ' => 'Leere Eingabe oder Werte kleiner, gleich null eingegeben. Fehler in Reihe Nummer: ',
+ 'An invalid character was used (invalid characters: #1).' => 'Ein ungültiges Zeichen wurde benutzt (ungültige Zeichen: #1).',
+ 'An invalid character was used (valid characters: #1).' => 'Ein ungültiges Zeichen wurde benutzt (gültige Zeichen: #1).',
+ 'An upper-case character is required.' => 'Ein Großbuchstabe ist vorgeschrieben.',
'Annotations' => 'Anmerkungen',
'Another user with the login #1 does already exist.' => 'Es existiert bereits ein anderer Benutzer mit diesem Login.',
'Ap aging on %s' => 'Offene Verbindlichkeiten zum %s',
'Bin From' => 'Quelllagerplatz',
'Bin List' => 'Lagerliste',
'Bin To' => 'Ziellagerplatz',
- 'Binding to the LDAP server as "#1" failed. Please check config/authentication.pl.' => 'Die Anmeldung am LDAP-Server als "#1" schlug fehl. Bitte überprüfen Sie die Angaben in config/authentication.pl.',
+ 'Binding to the LDAP server as "#1" failed. Please check config/lx_office.conf.' => 'Die Anmeldung am LDAP-Server als "#1" schlug fehl. Bitte überprüfen Sie die Angaben in config/lx_office.conf.',
'Bins saved.' => 'Lagerplätze gespeichert.',
'Bins that have been used in the past cannot be deleted anymore. For these bins there\'s no checkbox in the "Delete" column.' => 'Lagerplätze, die bereits benutzt wurden, können nicht mehr gelöscht werden. Deswegen fehlt bei ihnen die Checkbox in der Spalte "Löschen".',
'Birthday' => 'Geburtstag',
'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',
'Database Host' => 'Datenbankcomputer',
'Database User' => 'Datenbankbenutzer',
'Database User missing!' => 'Datenbankbenutzer fehlt!',
- 'Database backups and restorations are disabled in lx-erp.conf.' => 'Datenbanksicherungen und -wiederherstellungen sind in der lx-erp.conf deaktiviert.',
+ 'Database backups and restorations are disabled in the configuration.' => 'Datenbanksicherungen und -wiederherstellungen sind in der Konfiguration deaktiviert.',
'Database name' => 'Datenbankname',
'Database template' => 'Datenbankvorlage',
'Database update error:' => 'Fehler beim Datenbankupgrade:',
'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',
'Help Template Variables' => 'Hilfe zu Dokumenten-Variablen',
'Here\'s an example command line:' => 'Hier ist eine Kommandozeile, die als Beispiel dient:',
'Hide by default' => 'Standardmäßig verstecken',
- 'History' => 'Historie',
'History Search' => 'Historien Suche',
'History Search Engine' => 'Historien Suchmaschine',
'Homepage' => 'Homepage',
'If you chose to let Lx-Office do the migration then Lx-Office will also remove the old member file after creating a backup copy of it in the directory "#1".' => 'Falls Sie sich entscheiden, Lx-Office die Migration durchführen zu lassen, so wird Lx-Office ein Backup der alten Dateien im Verzeichnis "#1" erstellen und die Dateien anschließend löschen.',
'If you enter values for the part number and / or part description then only those bins containing parts whose part number or part description match your input will be shown.' => 'Wenn Sie für die Artikelnummer und / oder die Beschreibung etwas eingeben, so werden nur die Lagerplätze angezeigt, in denen Waren eingelagert sind, die Ihre Suchbegriffe enthalten.',
'If you see this message, you most likely just setup your LX-Office and haven\'t added any entry types. If this is the case, the option is accessible for administrators in the System menu.' => 'Wenn Sie diese Meldung sehen haben Sie wahrscheinlich ein frisches LX-Office Setup und noch keine Buchungsgruppen eingerichtet. Ein Administrator kann dies im Systemmenü erledigen.',
- 'If you want to change any of these parameters then press the "Back" button, edit the file "config/authentication.pl" and login into the admin module again.' => 'Wenn Sie einen der Parameter ändern wollen, so drücken Sie auf den "Zurück"-Button, bearbeiten Sie die Datei "config/authentication.pl", und melden Sie sich erneut im Administrationsbereich an.',
+ 'If you want to change any of these parameters then press the "Back" button, edit the file "config/lx_office.conf" and login into the admin module again.' => 'Wenn Sie einen der Parameter ändern wollen, so drücken Sie auf den "Zurück"-Button, bearbeiten Sie die Datei "config/lx_office.conf", und melden Sie sich erneut im Administrationsbereich an.',
'If you want to delete such a dataset you have to edit the user(s) that are using the dataset in question and have them use another dataset.' => 'Wenn Sie eine solche Datenbank löschen wollen, so müssen Sie zuerst die Benutzer bearbeiten, die die fragliche Datenbank benutzen, und sie so ändern, dass sie eine andere Datenbank benutzen.',
'If you want to set up the authentication database yourself then log in to the administration panel. Lx-Office will then create the database and tables for you.' => 'Wenn Sie die Authentifizierungsdatenbank selber einrichten wollen, so melden Sie sich an der Administrationsoberfläche an. Lx-Office wird dann die Datenbank und die Tabellen für Sie anlegen.',
'If you yourself want to upgrade the installation then please read the file "doc/UPGRADE" and follow the steps outlined in this file.' => 'Wenn Sie selber die Aktualisierung bzw. Einrichtung übernehmen wollen, so lesen Sie bitte die Datei "doc/UPGRADE" und folgen Sie den dort beschriebenen Schritten.',
'No group has been selected, or the group does not exist anymore.' => 'Es wurde keine Gruppe ausgewählt, oder die Gruppe wurde in der Zwischenzeit gelöscht.',
'No groups have been added yet.' => 'Es wurden noch keine Gruppen angelegt.',
'No licenses were found that match the search criteria.' => 'Es wurden keine Lizenzen gefunden, auf die die Suchkriterien zutreffen.',
- 'No or an unknown authenticantion module specified in "config/authentication.pl".' => 'Es wurde kein oder ein unbekanntes Authentifizierungsmodul in "config/authentication.pl" angegeben.',
+ 'No or an unknown authenticantion module specified in "config/lx_office.conf".' => 'Es wurde kein oder ein unbekanntes Authentifizierungsmodul in "config/lx_office.conf" angegeben.',
'No part was found matching the search parameters.' => 'Es wurde kein Artikel gefunden, auf den die Suchparameter zutreffen.',
'No prices will be updated because no prices have been entered.' => 'Es werden keine Preise aktualisiert, weil keine gültigen Preisänderungen eingegeben wurden.',
'No problems were recognized.' => 'Es wurden keine Probleme gefunden.',
'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 AP transaction #1 has been deleted.' => 'Die Kreditorenbuchung #1 wurde gelöscht.',
'The AR transaction #1 has been deleted.' => 'Die Debitorenbuchung #1 wurde gelöscht.',
'The GL transaction #1 has been deleted.' => 'Die Dialogbuchung #1 wurde gelöscht.',
- 'The LDAP server "#1:#2" is unreachable. Please check config/authentication.pl.' => 'Der LDAP-Server "#1:#2" ist nicht erreichbar. Bitte überprüfen Sie die Angaben in config/authentication.pl.',
+ 'The LDAP server "#1:#2" is unreachable. Please check config/lx_office.conf.' => 'Der LDAP-Server "#1:#2" ist nicht erreichbar. Bitte überprüfen Sie die Angaben in config/lx_office.conf.',
'The SEPA export has been created.' => 'Der SEPA-Export wurde erstellt',
'The SEPA strings have been saved.' => 'Die bei SEPA-Überweisungen verwendeten Begriffe wurden gespeichert.',
'The access rights have been saved.' => 'Die Zugriffsrechte wurden gespeichert.',
'The account 3804 will not be added automatically.' => 'Das Konto 3804 wird nicht automatisch hinzugefügt.',
'The assembly has been created.' => 'Das Erzeugnis wurde hergestellt.',
'The assistant could not find anything wrong with #1. Maybe the problem has been solved in the meantime.' => 'Der Korrekturassistent konnte kein Problem bei #1 feststellen. Eventuell wurde das Problem in der Zwischenzeit bereits behoben.',
- 'The authentication configuration file "config/authentication.pl" does not exist. This Lx-Office installation has probably not been updated correctly yet. Please contact your administrator.' => 'Die Konfigurationsdatei für die Authentifizierung "config/authentication.pl" wurde nicht gefunden. Diese Lx-Office-Installation wurde vermutlich noch nicht vollständig aktualisiert oder eingerichtet. Bitte wenden Sie sich an Ihren Administrator.',
+ 'The authentication configuration file "config/lx_office.conf" does not exist. This Lx-Office installation has probably not been updated correctly yet. Please contact your administrator.' => 'Die Konfigurationsdatei für die Authentifizierung "config/lx_office.conf" wurde nicht gefunden. Diese Lx-Office-Installation wurde vermutlich noch nicht vollständig aktualisiert oder eingerichtet. Bitte wenden Sie sich an Ihren Administrator.',
'The authentication database is not reachable at the moment. Either it hasn\'t been set up yet or the database server might be down. Please contact your administrator.' => 'Die Authentifizierungsdatenbank kann momentan nicht erreicht werden. Entweder wurde sie noch nicht eingerichtet, oder der Datenbankserver antwortet nicht. Bitte wenden Sie sich an Ihren Administrator.',
'The available options depend on the varibale type:' => 'Die verfügbaren Optionen hängen vom Variablentypen ab:',
'The backup you upload here has to be a file created with "pg_dump -o -Ft".' => 'Die von Ihnen hochzuladende Sicherungsdatei muss mit dem Programm und den Parametern "pg_dump -o -Ft" erstellt worden sein.',
'The base unit does not exist.' => 'Die Basiseinheit existiert nicht.',
'The base unit relations must not contain loops (e.g. by saying that unit A\'s base unit is B, B\'s base unit is C and C\'s base unit is A) in row %d.' => 'Die Beziehungen der Einheiten dürfen keine Schleifen beinhalten (z.B. wenn gesagt wird, dass Einheit As Basiseinheit B, Bs Basiseinheit C und Cs Basiseinheit A ist) in Zeile %d.',
'The columns "Dunning Duedate", "Total Fees" and "Interest" show data for the previous dunning created for this invoice.' => 'Die Spalten "Zahlbar bis", "Kumulierte Gebühren" und "Zinsen" zeigen Daten der letzten für diese Rechnung erzeugten Mahnung.',
- 'The config file "config/authentication.pl" contained invalid Perl code:' => 'Die Konfigurationsdatei "config/authentication.pl" enthielt ungütigen Perl-Code:',
- 'The config file "config/authentication.pl" was not found.' => 'Die Konfigurationsdatei "config/authentication.pl" wurde nicht gefunden.',
- 'The connection to the LDAP server cannot be encrypted (SSL/TLS startup failure). Please check config/authentication.pl.' => 'Die Verbindung zum LDAP-Server kann nicht verschlüsselt werden (Fehler bei SSL/TLS-Initialisierung). Bitte überprüfen Sie die Angaben in config/authentication.pl.',
+ 'The connection to the LDAP server cannot be encrypted (SSL/TLS startup failure). Please check config/lx_office.conf.' => 'Die Verbindung zum LDAP-Server kann nicht verschlüsselt werden (Fehler bei SSL/TLS-Initialisierung). Bitte überprüfen Sie die Angaben in config/lx_office.conf.',
'The connection to the authentication database failed:' => 'Die Verbindung zur Authentifizierungsdatenbank schlug fehl:',
'The connection to the database could not be established.' => 'Die Verbindung zur Datenbank konnte nicht hergestellt werden.',
'The connection to the template database failed:' => 'Die Verbindung zur Vorlagendatenbank schlug fehl:',
'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 group has been saved.' => 'Die Gruppe wurde gespeichert.',
'The group memberships have been saved.' => 'Die Gruppenmitgliedschaften wurden gespeichert.',
'The group name is missing.' => 'Der Gruppenname fehlt.',
- 'The licensing module has been deactivated in lx-erp.conf.' => 'Das Lizenzverwaltungsmodul wurde in lx-erp.conf deaktiviert.',
+ 'The licensing module has been deactivated in the configuration.' => 'Das Lizenzverwaltungsmodul wurde in der Konfiguration deaktiviert.',
'The list has been printed.' => 'Die Liste wurde ausgedruckt.',
'The login is missing.' => 'Das Login fehlt.',
'The name in row %d has already been used before.' => 'Der Name in Zeile %d wurde vorher bereits benutzt.',
'The parts have been removed.' => 'Die Waren wurden aus dem Lager entnommen.',
'The parts have been stocked.' => 'Die Artikel wurden eingelagert.',
'The parts have been transferred.' => 'Die Waren wurden umgelagert.',
+ 'The password is too long (maximum length: #1).' => 'Das Passwort ist zu lang (maximale Länge: #1).',
+ 'The password is too short (minimum length: #1).' => 'Das Password ist zu kurz (minimale Länge: #1).',
+ 'The password is weak (e.g. it can be found in a dictionary).' => 'Das Passwort ist schwach (z.B. wenn es in einem Wörterbuch steht).',
'The payments have been posted.' => 'Die Zahlungen wurden gebucht.',
'The pg_dump process could not be started.' => 'Der pg_dump-Prozess konnte nicht gestartet werden.',
'The pg_restore process could not be started.' => 'Der pg_restore-Prozess konnte nicht gestartet werden.',
'The selected warehouse does not exist.' => 'Das ausgewählte Lager existiert nicht.',
'The selected warehouse is empty, or no stocked items where found that match the filter settings.' => 'Das ausgewählte Lager ist leer, oder in ihm wurden keine zu den Sucheinstellungen passenden eingelagerten Artikel gefunden.',
'The session is invalid or has expired.' => 'Sie sind von Lx-Office abgemeldet.',
+ 'The settings were saved, but the password was not changed.' => 'Die Einstellungen wurden gespeichert, aber das Passwort wurde nicht geändert.',
'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',
'close' => 'schließen',
'closed' => 'geschlossen',
'companylogo_subtitle' => 'Lizenziert für',
- 'config/authentication.pl: Key "DB_config" is missing.' => 'config/authentication.pl: Das Schlüsselwort "DB_config" fehlt.',
- 'config/authentication.pl: Key "LDAP_config" is missing.' => 'config/authentication.pl: Der Schlüssel "LDAP_config" fehlt.',
- 'config/authentication.pl: Missing parameters in "DB_config". Required parameters are "host", "db" and "user".' => 'config/authentication.pl: Fehlende Parameter in "DB_config". Benötigte Parameter sind "host", "db" und "user".',
- 'config/authentication.pl: Missing parameters in "LDAP_config". Required parameters are "host", "attribute" and "base_dn".' => 'config/authentication.pl: Fehlende Parameter in "LDAP_config". Benötigt werden "host", "attribute" und "base_dn".',
+ 'config/lx_office.conf: Key "DB_config" is missing.' => 'config/lx_office.conf: Das Schlüsselwort "DB_config" fehlt.',
+ 'config/lx_office.conf: Key "authentication/ldap" is missing.' => 'config/lx_office.conf: Der Schlüssel "authentication/ldap" fehlt.',
+ 'config/lx_office.conf: Missing parameters in "authentication/database". Required parameters are "host", "db" and "user".' => 'config/lx_office.conf: Fehlende Parameter in "authentication/database". Benötigte Parameter sind "host", "db" und "user".',
+ 'config/lx_office.conf: Missing parameters in "authentication/ldap". Required parameters are "host", "attribute" and "base_dn".' => 'config/lx_office.conf: Fehlende Parameter in "authentication/ldap". Benötigt werden "host", "attribute" und "base_dn".',
'continue' => 'weiter',
'correction' => 'Korrektur',
'cp_greeting to cp_gender migration' => 'Datenumwandlung von Titel nach Geschlecht (cp_greeting to cp_gender)',
'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',
};
'4. Quarter' => '4. Quartal',
'<b>What</b> do you want to look for?' => '<b>Wonach</b> wollen Sie suchen?',
'A Buchungsgruppe consists of a descriptive name and the account numbers for the income and expense accounts for those four tax zones as well as the inventory account number.' => 'Eine Buchungsgruppe besteht aus einem deskriptiven Namen, den Erlös- und Aufwandskonten für diese vier Steuerzonen sowie aus einem Inventarkonto.',
+ 'A digit is required.' => '',
'A group named "Full Access" has been created.' => 'Eine Gruppe namens "Vollzugriff" wurde angelegt.',
'A group with that name does already exist.' => 'Eine Gruppe mit diesem Namen gibt es bereits.',
'A lot of the usability of Lx-Office has been enhanced with javascript. Although it is currently possible to use every aspect of Lx-Office without javascript, we strongly recommend it. In a future version this may change and javascript may be necessary to access advanced features.' => 'Die Bedienung von Lx-Office wurde an vielen Stellen mit Javascript verbessert. Obwohl es derzeit möglich ist, jeden Aspekt von Lx-Office auch ohne Javascript zu benutzen, empfehlen wir es. In einer zukünftigen Version wird Javascript eventuell notwendig sein um weitergehende Features zu benutzen.',
+ 'A lower-case character is required.' => '',
+ 'A special character is required (valid characters: #1).' => '',
'A temporary directory could not be created:' => 'Ein temporäres Verzeichnis konnte nicht erstellt werden:',
'A temporary file could not be created. Please verify that the directory "#1" is writeable by the webserver.' => 'Eine temporäre Datei konnte nicht angelegt werden. Bitte stellen Sie sicher, dass das Verzeichnis "#1" vom Webserver beschrieben werden darf.',
'A temporary file could not be created:' => 'Eine temporäre Datei konnte nicht erstellt werden:',
'Amount' => 'Betrag',
'Amount Due' => 'Betrag fällig',
'Amount has to be greater then zero! Wrong row number: ' => '"Betrag" muss größer Null sein. Fehlerhafte Zeile: ',
+ 'An invalid character was used (invalid characters: #1).' => '',
+ 'An invalid character was used (valid characters: #1).' => '',
+ 'An upper-case character is required.' => '',
'Annotations' => 'Hilfe',
'Another user with the login #1 does already exist.' => 'Es existiert bereits ein anderer Benutzer mit diesem Login.',
'Ap aging on %s' => 'Offene Verbindlichkeiten zum %s',
'Company Name' => 'Firmenname',
'Compare to' => 'Gegenüberstellen zu',
'Configuration of individual TODO items' => 'Konfiguration für die einzelnen Aufgabenlistenpunkte',
+ 'Configure' => '',
'Confirm' => 'Bestätigen',
'Confirm!' => 'Bestätigen Sie!',
'Confirmation' => 'Auftragsbestätigung',
'Database Host' => 'Datenbankcomputer',
'Database User' => 'Datenbankbenutzer',
'Database User missing!' => 'Datenbankbenutzer fehlt!',
- 'Database backups and restorations are disabled in lx-erp.conf.' => 'Datenbanksicherungen und -wiederherstellungen sind in der lx-erp.conf deaktiviert.',
+ 'Database backups and restorations are disabled in the configuration.' => 'Datenbanksicherungen und -wiederherstellungen sind in der Konfiguration deaktiviert.',
'Database name' => 'Datenbankname',
'Database template' => 'Datenbankvorlage',
'Database update error:' => 'Fehler beim Datenbankupgrade:',
'Edit rights' => 'Rechte bearbeiten',
'Edit templates' => 'Vorlagen bearbeiten',
'Edit the Delivery Order' => 'Lieferschein bearbeiten',
+ 'Edit the configuration for periodic invoices' => '',
'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' => '',
'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' => '',
'Extended' => 'Gesamt',
'Extension Of Time' => 'Dauerfristverlängerung',
'Factor' => 'Faktor',
'Help Template Variables' => 'Hilfe zu Dokumenten-Variablen',
'Here\'s an example command line:' => 'Hier ist eine Kommandozeile, die als Beispiel dient:',
'Hide by default' => 'Standardmäßig verstecken',
- 'History' => 'Historie',
'History Search' => 'Historien Suche',
'History Search Engine' => 'Historien Suchmaschine',
'Homepage' => 'Homepage',
'Payment posted!' => 'Zahlung gebucht!',
'Payment terms deleted!' => 'Zahlungskonditionen gelöscht!',
'Payments' => 'Zahlungsausgänge',
+ 'Per. Inv.' => '',
'Period' => 'Zeitraum',
'Period:' => 'Zeitraum:',
+ 'Periodic Invoices' => '',
+ 'Periodic invoices active' => '',
+ 'Periodic invoices inactive' => '',
+ 'Periodicity' => '',
'Personal settings' => 'Meine Daten',
'Pg Database Administration' => 'Datenbankadministration',
'Phone' => 'Telefon',
'Pricegroups' => 'Preisgruppen',
'Print' => 'Drucken',
'Print and Post' => 'Drucken und Buchen',
+ 'Print automatically' => '',
'Print dunnings' => 'Mahnungen drucken',
'Print list' => 'Liste ausdrucken',
'Print options' => 'Drucken',
'Spoolfile' => 'Druckdatei',
'Start Dunning Process' => 'Neue Mahnung',
'Start analysis' => 'Analyse beginnen',
+ 'Start date' => '',
'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' => '',
'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.' => '',
'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 group has been saved.' => 'Die Gruppe wurde gespeichert.',
'The group memberships have been saved.' => 'Die Gruppenmitgliedschaften wurden gespeichert.',
'The group name is missing.' => 'Der Gruppenname fehlt.',
- 'The licensing module has been deactivated in lx-erp.conf.' => 'Das Lizenzverwaltungsmodul wurde in lx-erp.conf deaktiviert.',
+ 'The licensing module has been deactivated in the configuration.' => 'Das Lizenzverwaltungsmodul wurde in der Konfiguration deaktiviert.',
'The list has been printed.' => 'Die Liste wurde ausgedruckt.',
'The login is missing.' => 'Das Login fehlt.',
'The name in row %d has already been used before.' => 'Der Name in Zeile %d wurde vorher bereits benutzt.',
'The parts have been removed.' => 'Die Waren wurden aus dem Lager entnommen.',
'The parts have been stocked.' => 'Die Artikel wurden eingelagert.',
'The parts have been transferred.' => 'Die Waren wurden umgelagert.',
+ 'The password is too long (maximum length: #1).' => '',
+ 'The password is too short (minimum length: #1).' => '',
+ 'The password is weak (e.g. it can be found in a dictionary).' => '',
'The payments have been posted.' => 'Die Zahlungen wurden gebucht.',
'The pg_dump process could not be started.' => 'Der pg_dump-Prozess konnte nicht gestartet werden.',
'The pg_restore process could not be started.' => 'Der pg_restore-Prozess konnte nicht gestartet werden.',
'The selected warehouse does not exist.' => 'Das ausgewählte Lager existiert nicht.',
'The selected warehouse is empty, or no stocked items where found that match the filter settings.' => 'Das ausgewählte Lager ist leer, oder die Suche ergab keine Übereinstimmungen.',
'The session is invalid or has expired.' => 'Sie sind von Lx-Office abgemeldet.',
+ 'The settings were saved, but the password was not changed.' => '',
'The source warehouse does not contain any bins.' => 'Das Quelllager enthält keine Lagerplätze.',
+ 'The start date is missing.' => '',
'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' => '',
'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' => '',
'invoice' => 'Rechnung',
'invoice_list' => 'debitorenbuchungsliste',
'lead deleted!' => 'Kundenquelle gelöscht',
'mark as paid' => 'als bezahlt markieren',
'missing' => 'Fehlbestand',
'month' => 'Monatliche Abgabe',
+ 'monthly' => '',
'new Window' => 'neues Fenster',
'no' => 'nein',
'no bestbefore' => 'keine Mindesthaltbarkeit',
'no chargenumber' => 'keine Chargennummer',
'none (pricegroup)' => 'keine',
+ 'not configured' => '',
'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' => '',
'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' => '',
'to (date)' => 'bis',
'to (time)' => 'bis',
'transfer' => 'Umlagerung',
'warehouse_journal_list' => 'lagerbuchungsliste',
'warehouse_report_list' => 'lagerbestandsliste',
'wrongformat' => 'Falsches Format',
+ 'yearly' => '',
'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
+package File::Slurp;
+
+use strict;
+
+use Carp ;
+use POSIX qw( :fcntl_h ) ;
+use Fcntl qw( :DEFAULT ) ;
+use Symbol ;
+
+my $is_win32 = $^O =~ /win32/i ;
+
+# Install subs for various constants that aren't set in older perls
+# (< 5.005). Fcntl on old perls uses Exporter to define subs without a
+# () prototype These can't be overridden with the constant pragma or
+# we get a prototype mismatch. Hence this less than aesthetically
+# appealing BEGIN block:
+
+BEGIN {
+ unless( eval { defined SEEK_SET() } ) {
+ *SEEK_SET = sub { 0 };
+ *SEEK_CUR = sub { 1 };
+ *SEEK_END = sub { 2 };
+ }
+
+ unless( eval { defined O_BINARY() } ) {
+ *O_BINARY = sub { 0 };
+ *O_RDONLY = sub { 0 };
+ *O_WRONLY = sub { 1 };
+ }
+
+ unless ( eval { defined O_APPEND() } ) {
+
+ if ( $^O =~ /olaris/ ) {
+ *O_APPEND = sub { 8 };
+ *O_CREAT = sub { 256 };
+ *O_EXCL = sub { 1024 };
+ }
+ elsif ( $^O =~ /inux/ ) {
+ *O_APPEND = sub { 1024 };
+ *O_CREAT = sub { 64 };
+ *O_EXCL = sub { 128 };
+ }
+ elsif ( $^O =~ /BSD/i ) {
+ *O_APPEND = sub { 8 };
+ *O_CREAT = sub { 512 };
+ *O_EXCL = sub { 2048 };
+ }
+ }
+}
+
+# print "OS [$^O]\n" ;
+
+# print "O_BINARY = ", O_BINARY(), "\n" ;
+# print "O_RDONLY = ", O_RDONLY(), "\n" ;
+# print "O_WRONLY = ", O_WRONLY(), "\n" ;
+# print "O_APPEND = ", O_APPEND(), "\n" ;
+# print "O_CREAT ", O_CREAT(), "\n" ;
+# print "O_EXCL ", O_EXCL(), "\n" ;
+
+use base 'Exporter' ;
+use vars qw( %EXPORT_TAGS @EXPORT_OK $VERSION @EXPORT ) ;
+
+%EXPORT_TAGS = ( 'all' => [
+ qw( read_file write_file overwrite_file append_file read_dir ) ] ) ;
+
+@EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
+@EXPORT_OK = qw( slurp ) ;
+
+$VERSION = '9999.13';
+
+*slurp = \&read_file ;
+
+sub read_file {
+
+ my( $file_name, %args ) = @_ ;
+
+# set the buffer to either the passed in one or ours and init it to the null
+# string
+
+ my $buf ;
+ my $buf_ref = $args{'buf_ref'} || \$buf ;
+ ${$buf_ref} = '' ;
+
+ my( $read_fh, $size_left, $blk_size ) ;
+
+# check if we are reading from a handle (glob ref or IO:: object)
+
+ if ( ref $file_name ) {
+
+# slurping a handle so use it and don't open anything.
+# set the block size so we know it is a handle and read that amount
+
+ $read_fh = $file_name ;
+ $blk_size = $args{'blk_size'} || 1024 * 1024 ;
+ $size_left = $blk_size ;
+
+# DEEP DARK MAGIC. this checks the UNTAINT IO flag of a
+# glob/handle. only the DATA handle is untainted (since it is from
+# trusted data in the source file). this allows us to test if this is
+# the DATA handle and then to do a sysseek to make sure it gets
+# slurped correctly. on some systems, the buffered i/o pointer is not
+# left at the same place as the fd pointer. this sysseek makes them
+# the same so slurping with sysread will work.
+
+ eval{ require B } ;
+
+ if ( $@ ) {
+
+ @_ = ( \%args, <<ERR ) ;
+Can't find B.pm with this Perl: $!.
+That module is needed to slurp the DATA handle.
+ERR
+ goto &_error ;
+ }
+
+ if ( B::svref_2object( $read_fh )->IO->IoFLAGS & 16 ) {
+
+# set the seek position to the current tell.
+
+ sysseek( $read_fh, tell( $read_fh ), SEEK_SET ) ||
+ croak "sysseek $!" ;
+ }
+ }
+ else {
+
+# a regular file. set the sysopen mode
+
+ my $mode = O_RDONLY ;
+
+#printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ;
+
+# open the file and handle any error
+
+ $read_fh = gensym ;
+ unless ( sysopen( $read_fh, $file_name, $mode ) ) {
+ @_ = ( \%args, "read_file '$file_name' - sysopen: $!");
+ goto &_error ;
+ }
+
+ binmode($read_fh, $args{'binmode'}) if $args{'binmode'};
+
+# get the size of the file for use in the read loop
+
+ $size_left = -s $read_fh ;
+
+ unless( $size_left ) {
+
+ $blk_size = $args{'blk_size'} || 1024 * 1024 ;
+ $size_left = $blk_size ;
+ }
+ }
+
+# infinite read loop. we exit when we are done slurping
+
+ while( 1 ) {
+
+# do the read and see how much we got
+
+ my $read_cnt = sysread( $read_fh, ${$buf_ref},
+ $size_left, length ${$buf_ref} ) ;
+
+ if ( defined $read_cnt ) {
+
+# good read. see if we hit EOF (nothing left to read)
+
+ last if $read_cnt == 0 ;
+
+# loop if we are slurping a handle. we don't track $size_left then.
+
+ next if $blk_size ;
+
+# count down how much we read and loop if we have more to read.
+ $size_left -= $read_cnt ;
+ last if $size_left <= 0 ;
+ next ;
+ }
+
+# handle the read error
+
+ @_ = ( \%args, "read_file '$file_name' - sysread: $!");
+ goto &_error ;
+ }
+
+# fix up cr/lf to be a newline if this is a windows text file
+
+ ${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$args{'binmode'} ;
+
+# this is the 5 returns in a row. each handles one possible
+# combination of caller context and requested return type
+
+ my $sep = $/ ;
+ $sep = '\n\n+' if defined $sep && $sep eq '' ;
+
+# caller wants to get an array ref of lines
+
+# this split doesn't work since it tries to use variable length lookbehind
+# the m// line works.
+# return [ split( m|(?<=$sep)|, ${$buf_ref} ) ] if $args{'array_ref'} ;
+ return [ length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : () ]
+ if $args{'array_ref'} ;
+
+# caller wants a list of lines (normal list context)
+
+# same problem with this split as before.
+# return split( m|(?<=$sep)|, ${$buf_ref} ) if wantarray ;
+ return length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : ()
+ if wantarray ;
+
+# caller wants a scalar ref to the slurped text
+
+ return $buf_ref if $args{'scalar_ref'} ;
+
+# caller wants a scalar with the slurped text (normal scalar context)
+
+ return ${$buf_ref} if defined wantarray ;
+
+# caller passed in an i/o buffer by reference (normal void context)
+
+ return ;
+}
+
+sub write_file {
+
+ my $file_name = shift ;
+
+# get the optional argument hash ref from @_ or an empty hash ref.
+
+ my $args = ( ref $_[0] eq 'HASH' ) ? shift : {} ;
+
+ my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ;
+
+# get the buffer ref - it depends on how the data is passed into write_file
+# after this if/else $buf_ref will have a scalar ref to the data.
+
+ if ( ref $args->{'buf_ref'} eq 'SCALAR' ) {
+
+# a scalar ref passed in %args has the data
+# note that the data was passed by ref
+
+ $buf_ref = $args->{'buf_ref'} ;
+ $data_is_ref = 1 ;
+ }
+ elsif ( ref $_[0] eq 'SCALAR' ) {
+
+# the first value in @_ is the scalar ref to the data
+# note that the data was passed by ref
+
+ $buf_ref = shift ;
+ $data_is_ref = 1 ;
+ }
+ elsif ( ref $_[0] eq 'ARRAY' ) {
+
+# the first value in @_ is the array ref to the data so join it.
+
+ ${$buf_ref} = join '', @{$_[0]} ;
+ }
+ else {
+
+# good old @_ has all the data so join it.
+
+ ${$buf_ref} = join '', @_ ;
+ }
+
+# see if we were passed a open handle to spew to.
+
+ if ( ref $file_name ) {
+
+# we have a handle. make sure we don't call truncate on it.
+
+ $write_fh = $file_name ;
+ $no_truncate = 1 ;
+ }
+ else {
+
+# spew to regular file.
+
+ if ( $args->{'atomic'} ) {
+
+# in atomic mode, we spew to a temp file so make one and save the original
+# file name.
+ $orig_file_name = $file_name ;
+ $file_name .= ".$$" ;
+ }
+
+# set the mode for the sysopen
+
+ my $mode = O_WRONLY | O_CREAT ;
+ $mode |= O_APPEND if $args->{'append'} ;
+ $mode |= O_EXCL if $args->{'no_clobber'} ;
+
+#printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ;
+
+# open the file and handle any error.
+
+ $write_fh = gensym ;
+ unless ( sysopen( $write_fh, $file_name, $mode ) ) {
+ @_ = ( $args, "write_file '$file_name' - sysopen: $!");
+ goto &_error ;
+ }
+
+ binmode($write_fh, $args->{'binmode'}) if $args->{'binmode'};
+ }
+
+ sysseek( $write_fh, 0, SEEK_END ) if $args->{'append'} ;
+
+
+#print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ;
+
+# fix up newline to write cr/lf if this is a windows text file
+
+ if ( $is_win32 && !$args->{'binmode'} ) {
+
+# copy the write data if it was passed by ref so we don't clobber the
+# caller's data
+ $buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ;
+ ${$buf_ref} =~ s/\n/\015\012/g ;
+ }
+
+#print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ;
+
+# get the size of how much we are writing and init the offset into that buffer
+
+ my $size_left = length( ${$buf_ref} ) ;
+ my $offset = 0 ;
+
+# loop until we have no more data left to write
+
+ do {
+
+# do the write and track how much we just wrote
+
+ my $write_cnt = syswrite( $write_fh, ${$buf_ref},
+ $size_left, $offset ) ;
+
+ unless ( defined $write_cnt ) {
+
+# the write failed
+ @_ = ( $args, "write_file '$file_name' - syswrite: $!");
+ goto &_error ;
+ }
+
+# track much left to write and where to write from in the buffer
+
+ $size_left -= $write_cnt ;
+ $offset += $write_cnt ;
+
+ } while( $size_left > 0 ) ;
+
+# we truncate regular files in case we overwrite a long file with a shorter file
+# so seek to the current position to get it (same as tell()).
+
+ truncate( $write_fh,
+ sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ;
+
+ close( $write_fh ) ;
+
+# handle the atomic mode - move the temp file to the original filename.
+
+ rename( $file_name, $orig_file_name ) if $args->{'atomic'} ;
+
+ return 1 ;
+}
+
+# this is for backwards compatibility with the previous File::Slurp module.
+# write_file always overwrites an existing file
+
+*overwrite_file = \&write_file ;
+
+# the current write_file has an append mode so we use that. this
+# supports the same API with an optional second argument which is a
+# hash ref of options.
+
+sub append_file {
+
+# get the optional args hash ref
+ my $args = $_[1] ;
+ if ( ref $args eq 'HASH' ) {
+
+# we were passed an args ref so just mark the append mode
+
+ $args->{append} = 1 ;
+ }
+ else {
+
+# no args hash so insert one with the append mode
+
+ splice( @_, 1, 0, { append => 1 } ) ;
+ }
+
+# magic goto the main write_file sub. this overlays the sub without touching
+# the stack or @_
+
+ goto &write_file
+}
+
+# basic wrapper around opendir/readdir
+
+sub read_dir {
+
+ my ($dir, %args ) = @_;
+
+# this handle will be destroyed upon return
+
+ local(*DIRH);
+
+# open the dir and handle any errors
+
+ unless ( opendir( DIRH, $dir ) ) {
+
+ @_ = ( \%args, "read_dir '$dir' - opendir: $!" ) ;
+ goto &_error ;
+ }
+
+ my @dir_entries = readdir(DIRH) ;
+
+ @dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries )
+ unless $args{'keep_dot_dot'} ;
+
+ return @dir_entries if wantarray ;
+ return \@dir_entries ;
+}
+
+# error handling section
+#
+# all the error handling uses magic goto so the caller will get the
+# error message as if from their code and not this module. if we just
+# did a call on the error code, the carp/croak would report it from
+# this module since the error sub is one level down on the call stack
+# from read_file/write_file/read_dir.
+
+
+my %err_func = (
+ 'carp' => \&carp,
+ 'croak' => \&croak,
+) ;
+
+sub _error {
+
+ my( $args, $err_msg ) = @_ ;
+
+# get the error function to use
+
+ my $func = $err_func{ $args->{'err_mode'} || 'croak' } ;
+
+# if we didn't find it in our error function hash, they must have set
+# it to quiet and we don't do anything.
+
+ return unless $func ;
+
+# call the carp/croak function
+
+ $func->($err_msg) ;
+
+# return a hard undef (in list context this will be a single value of
+# undef which is not a legal in-band value)
+
+ return undef ;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::Slurp - Efficient Reading/Writing of Complete Files
+
+=head1 SYNOPSIS
+
+ use File::Slurp;
+
+ my $text = read_file( 'filename' ) ;
+ my @lines = read_file( 'filename' ) ;
+
+ write_file( 'filename', @lines ) ;
+
+ use File::Slurp qw( slurp ) ;
+
+ my $text = slurp( 'filename' ) ;
+
+
+=head1 DESCRIPTION
+
+This module provides subs that allow you to read or write entire files
+with one simple call. They are designed to be simple to use, have
+flexible ways to pass in or get the file contents and to be very
+efficient. There is also a sub to read in all the files in a
+directory other than C<.> and C<..>
+
+These slurp/spew subs work for files, pipes and
+sockets, and stdio, pseudo-files, and DATA.
+
+=head2 B<read_file>
+
+This sub reads in an entire file and returns its contents to the
+caller. In list context it will return a list of lines (using the
+current value of $/ as the separator including support for paragraph
+mode when it is set to ''). In scalar context it returns the entire
+file as a single scalar.
+
+ my $text = read_file( 'filename' ) ;
+ my @lines = read_file( 'filename' ) ;
+
+The first argument to C<read_file> is the filename and the rest of the
+arguments are key/value pairs which are optional and which modify the
+behavior of the call. Other than binmode the options all control how
+the slurped file is returned to the caller.
+
+If the first argument is a file handle reference or I/O object (if ref
+is true), then that handle is slurped in. This mode is supported so
+you slurp handles such as C<DATA>, C<STDIN>. See the test handle.t
+for an example that does C<open( '-|' )> and child process spews data
+to the parant which slurps it in. All of the options that control how
+the data is returned to the caller still work in this case.
+
+NOTE: as of version 9999.06, read_file works correctly on the C<DATA>
+handle. It used to need a sysseek workaround but that is now handled
+when needed by the module itself.
+
+You can optionally request that C<slurp()> is exported to your code. This
+is an alias for read_file and is meant to be forward compatible with
+Perl 6 (which will have slurp() built-in).
+
+The options are:
+
+=head3 binmode
+
+If you set the binmode option, then the file will be slurped in binary
+mode.
+
+ my $bin_data = read_file( $bin_file, binmode => ':raw' ) ;
+ # Or
+ my $bin_data = read_file( $bin_file, binmode => ':utf8' ) ;
+
+=head3 array_ref
+
+If this boolean option is set, the return value (only in scalar
+context) will be an array reference which contains the lines of the
+slurped file. The following two calls are equivalent:
+
+ my $lines_ref = read_file( $bin_file, array_ref => 1 ) ;
+ my $lines_ref = [ read_file( $bin_file ) ] ;
+
+=head3 scalar_ref
+
+If this boolean option is set, the return value (only in scalar
+context) will be an scalar reference to a string which is the contents
+of the slurped file. This will usually be faster than returning the
+plain scalar.
+
+ my $text_ref = read_file( $bin_file, scalar_ref => 1 ) ;
+
+=head3 buf_ref
+
+You can use this option to pass in a scalar reference and the slurped
+file contents will be stored in the scalar. This can be used in
+conjunction with any of the other options.
+
+ my $text_ref = read_file( $bin_file, buf_ref => \$buffer,
+ array_ref => 1 ) ;
+ my @lines = read_file( $bin_file, buf_ref => \$buffer ) ;
+
+=head3 blk_size
+
+You can use this option to set the block size used when slurping from an already open handle (like \*STDIN). It defaults to 1MB.
+
+ my $text_ref = read_file( $bin_file, blk_size => 10_000_000,
+ array_ref => 1 ) ;
+
+=head3 err_mode
+
+You can use this option to control how read_file behaves when an error
+occurs. This option defaults to 'croak'. You can set it to 'carp' or
+to 'quiet to have no error handling. This code wants to carp and then
+read abother file if it fails.
+
+ my $text_ref = read_file( $file, err_mode => 'carp' ) ;
+ unless ( $text_ref ) {
+
+ # read a different file but croak if not found
+ $text_ref = read_file( $another_file ) ;
+ }
+
+ # process ${$text_ref}
+
+=head2 B<write_file>
+
+This sub writes out an entire file in one call.
+
+ write_file( 'filename', @data ) ;
+
+The first argument to C<write_file> is the filename. The next argument
+is an optional hash reference and it contains key/values that can
+modify the behavior of C<write_file>. The rest of the argument list is
+the data to be written to the file.
+
+ write_file( 'filename', {append => 1 }, @data ) ;
+ write_file( 'filename', {binmode => ':raw' }, $buffer ) ;
+
+As a shortcut if the first data argument is a scalar or array
+reference, it is used as the only data to be written to the file. Any
+following arguments in @_ are ignored. This is a faster way to pass in
+the output to be written to the file and is equivilent to the
+C<buf_ref> option. These following pairs are equivilent but the pass
+by reference call will be faster in most cases (especially with larger
+files).
+
+ write_file( 'filename', \$buffer ) ;
+ write_file( 'filename', $buffer ) ;
+
+ write_file( 'filename', \@lines ) ;
+ write_file( 'filename', @lines ) ;
+
+If the first argument is a file handle reference or I/O object (if ref
+is true), then that handle is slurped in. This mode is supported so
+you spew to handles such as \*STDOUT. See the test handle.t for an
+example that does C<open( '-|' )> and child process spews data to the
+parant which slurps it in. All of the options that control how the
+data is passes into C<write_file> still work in this case.
+
+C<write_file> returns 1 upon successfully writing the file or undef if
+it encountered an error.
+
+The options are:
+
+=head3 binmode
+
+If you set the binmode option, then the file will be written in binary
+mode.
+
+ write_file( $bin_file, {binmode => ':raw'}, @data ) ;
+ # Or
+ write_file( $bin_file, {binmode => ':utf8'}, @data ) ;
+
+=head3 buf_ref
+
+You can use this option to pass in a scalar reference which has the
+data to be written. If this is set then any data arguments (including
+the scalar reference shortcut) in @_ will be ignored. These are
+equivilent:
+
+ write_file( $bin_file, { buf_ref => \$buffer } ) ;
+ write_file( $bin_file, \$buffer ) ;
+ write_file( $bin_file, $buffer ) ;
+
+=head3 atomic
+
+If you set this boolean option, the file will be written to in an
+atomic fashion. A temporary file name is created by appending the pid
+($$) to the file name argument and that file is spewed to. After the
+file is closed it is renamed to the original file name (and rename is
+an atomic operation on most OS's). If the program using this were to
+crash in the middle of this, then the file with the pid suffix could
+be left behind.
+
+=head3 append
+
+If you set this boolean option, the data will be written at the end of
+the current file.
+
+ write_file( $file, {append => 1}, @data ) ;
+
+C<write_file> croaks if it cannot open the file. It returns true if it
+succeeded in writing out the file and undef if there was an
+error. (Yes, I know if it croaks it can't return anything but that is
+for when I add the options to select the error handling mode).
+
+=head3 no_clobber
+
+If you set this boolean option, an existing file will not be overwritten.
+
+ write_file( $file, {no_clobber => 1}, @data ) ;
+
+=head3 err_mode
+
+You can use this option to control how C<write_file> behaves when an
+error occurs. This option defaults to 'croak'. You can set it to
+'carp' or to 'quiet' to have no error handling other than the return
+value. If the first call to C<write_file> fails it will carp and then
+write to another file. If the second call to C<write_file> fails, it
+will croak.
+
+ unless ( write_file( $file, { err_mode => 'carp', \$data ) ;
+
+ # write a different file but croak if not found
+ write_file( $other_file, \$data ) ;
+ }
+
+=head2 overwrite_file
+
+This sub is just a typeglob alias to write_file since write_file
+always overwrites an existing file. This sub is supported for
+backwards compatibility with the original version of this module. See
+write_file for its API and behavior.
+
+=head2 append_file
+
+This sub will write its data to the end of the file. It is a wrapper
+around write_file and it has the same API so see that for the full
+documentation. These calls are equivilent:
+
+ append_file( $file, @data ) ;
+ write_file( $file, {append => 1}, @data ) ;
+
+=head2 read_dir
+
+This sub reads all the file names from directory and returns them to
+the caller but C<.> and C<..> are removed by default.
+
+ my @files = read_dir( '/path/to/dir' ) ;
+
+It croaks if it cannot open the directory.
+
+In a list context C<read_dir> returns a list of the entries in the
+directory. In a scalar context it returns an array reference which has
+the entries.
+
+=head3 keep_dot_dot
+
+If this boolean option is set, C<.> and C<..> are not removed from the
+list of files.
+
+ my @all_files = read_dir( '/path/to/dir', keep_dot_dot => 1 ) ;
+
+=head2 EXPORT
+
+ read_file write_file overwrite_file append_file read_dir
+
+=head2 SEE ALSO
+
+An article on file slurping in extras/slurp_article.pod. There is
+also a benchmarking script in extras/slurp_bench.pl.
+
+=head2 BUGS
+
+If run under Perl 5.004, slurping from the DATA handle will fail as
+that requires B.pm which didn't get into core until 5.005.
+
+=head1 AUTHOR
+
+Uri Guttman, E<lt>uri@stemsystems.comE<gt>
+
+=cut
require Exporter;
require DynaLoader;
+
+
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter DynaLoader);
all => [ qw(any all none notall true false firstidx first_index lastidx
last_index insert_after insert_after_string apply after after_incl before
before_incl indexes firstval first_value lastval last_value each_array
- each_arrayref pairwise natatime mesh zip uniq minmax part) ],
+ each_arrayref pairwise natatime mesh zip uniq minmax part bsearch) ],
);
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
-$VERSION = '0.22';
+$VERSION = '0.25_02';
eval {
local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
eval <<'EOP' if not defined &any;
+require POSIX;
+
sub any (&@) {
my $f = shift;
return if ! @_;
sub none (&@) {
my $f = shift;
- return if ! @_;
+ return 1 if ! @_;
for (@_) {
return 0 if $f->();
}
sub uniq (@) {
my %h;
- map { $h{$_}++ == 0 ? $_ : () } @_;
+ my $ref = \1;
+ map { $h{defined $_ ? $_ : $ref}++ == 0 ? $_ : () } @_;
}
sub minmax (@) {
return @parts;
}
+sub bsearch(&@) {
+ my $code = shift;
+
+ my $rc;
+ my $i = 0;
+ my $j = @_;
+ do {
+ my $k = int(($i + $j) / 2);
+
+ return if $k >= @_;
+
+ local *_ = \$_[$k];
+ $rc = $code->();
+
+ $rc == 0 and
+ return wantarray ? $_ : 1;
+
+ if ($rc < 0) {
+ $i = $k + 1;
+ } else {
+ $j = $k - 1;
+ }
+ } until $i > $j;
+
+ return;
+}
+
sub _XScompiled {
return 0;
}
EOP
+die $@ if $@;
*first_index = \&firstidx;
*last_index = \&lastidx;
my $i = 0;
my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8]
+=item bsearch BLOCK LIST
+
+Performs a binary search on LIST which must be a sorted list of values. BLOCK
+must return a negative value if the current element (stored in C<$_>) is smaller,
+a positive value if it is bigger and zero if it matches.
+
+Returns a boolean value in scalar context. In list context, it returns the element
+if it was found, otherwise the empty list.
+
=back
=head1 EXPORTS
=head1 VERSION
-This is version 0.22.
+This is version 0.25_01.
=head1 BUGS
=head1 AUTHOR
-Tassilo von Parseval, E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
+Tassilo von Parseval, E<lt>vparseval@gmail.comE<gt>
=head1 COPYRIGHT AND LICENSE
-Copyright (C) 2004-2006 by Tassilo von Parseval
+Copyright (C) 2004-2009 by Tassilo von Parseval
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
--- /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
+
--- /dev/null
+
+require 5;
+package Sort::Naturally; # Time-stamp: "2004-12-29 18:30:03 AST"
+$VERSION = '1.02';
+@EXPORT = ('nsort', 'ncmp');
+require Exporter;
+@ISA = ('Exporter');
+
+use strict;
+use locale;
+use integer;
+
+#-----------------------------------------------------------------------------
+# constants:
+BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
+
+use Config ();
+BEGIN {
+ # Make a constant such that if a whole-number string is that long
+ # or shorter, we KNOW it's treatable as an integer
+ no integer;
+ my $x = length(256 ** $Config::Config{'intsize'} / 2) - 1;
+ die "Crazy intsize: <$Config::Config{'intsize'}>" if $x < 4;
+ eval 'sub MAX_INT_SIZE () {' . $x . '}';
+ die $@ if $@;
+ print "intsize $Config::Config{'intsize'} => MAX_INT_SIZE $x\n" if DEBUG;
+}
+
+sub X_FIRST () {-1}
+sub Y_FIRST () { 1}
+
+my @ORD = ('same', 'swap', 'asis');
+
+#-----------------------------------------------------------------------------
+# For lack of a preprocessor:
+
+my($code, $guts);
+$guts = <<'EOGUTS'; # This is the guts of both ncmp and nsort:
+
+ if($x eq $y) {
+ # trap this expensive case first, and then fall thru to tiebreaker
+ $rv = 0;
+
+ # Convoluted hack to get numerics to sort first, at string start:
+ } elsif($x =~ m/^\d/s) {
+ if($y =~ m/^\d/s) {
+ $rv = 0; # fall thru to normal comparison for the two numbers
+ } else {
+ $rv = X_FIRST;
+ DEBUG > 1 and print "Numeric-initial $x trumps letter-initial $y\n";
+ }
+ } elsif($y =~ m/^\d/s) {
+ $rv = Y_FIRST;
+ DEBUG > 1 and print "Numeric-initial $y trumps letter-initial $x\n";
+ } else {
+ $rv = 0;
+ }
+
+ unless($rv) {
+ # Normal case:
+ $rv = 0;
+ DEBUG and print "<$x> and <$y> compared...\n";
+
+ Consideration:
+ while(length $x and length $y) {
+
+ DEBUG > 2 and print " <$x> and <$y>...\n";
+
+ # First, non-numeric comparison:
+ $x2 = ($x =~ m/^(\D+)/s) ? length($1) : 0;
+ $y2 = ($y =~ m/^(\D+)/s) ? length($1) : 0;
+ # Now make x2 the min length of the two:
+ $x2 = $y2 if $x2 > $y2;
+ if($x2) {
+ DEBUG > 1 and printf " <%s> and <%s> lexically for length $x2...\n",
+ substr($x,0,$x2), substr($y,0,$x2);
+ do {
+ my $i = substr($x,0,$x2);
+ my $j = substr($y,0,$x2);
+ my $sv = $i cmp $j;
+ print "SCREAM! on <$i><$j> -- $sv != $rv \n" unless $rv == $sv;
+ last;
+ }
+
+
+ if $rv =
+ # The ''. things here force a copy that seems to work around a
+ # mysterious intermittent bug that 'use locale' provokes in
+ # many versions of Perl.
+ $cmp
+ ? $cmp->(substr($x,0,$x2) . '',
+ substr($y,0,$x2) . '',
+ )
+ :
+ scalar(( substr($x,0,$x2) . '' ) cmp
+ ( substr($y,0,$x2) . '' )
+ )
+ ;
+ # otherwise trim and keep going:
+ substr($x,0,$x2) = '';
+ substr($y,0,$x2) = '';
+ }
+
+ # Now numeric:
+ # (actually just using $x2 and $y2 as scratch)
+
+ if( $x =~ s/^(\d+)//s ) {
+ $x2 = $1;
+ if( $y =~ s/^(\d+)//s ) {
+ # We have two numbers here.
+ DEBUG > 1 and print " <$x2> and <$1> numerically\n";
+ if(length($x2) < MAX_INT_SIZE and length($1) < MAX_INT_SIZE) {
+ # small numbers: we can compare happily
+ last if $rv = $x2 <=> $1;
+ } else {
+ # ARBITRARILY large integers!
+
+ # This saves on loss of precision that could happen
+ # with actual stringification.
+ # Also, I sense that very large numbers aren't too
+ # terribly common in sort data.
+
+ # trim leading 0's:
+ ($y2 = $1) =~ s/^0+//s;
+ $x2 =~ s/^0+//s;
+ print " Treating $x2 and $y2 as bigint\n" if DEBUG;
+
+ no locale; # we want the dumb cmp back.
+ last if $rv = (
+ # works only for non-negative whole numbers:
+ length($x2) <=> length($y2)
+ # the longer the numeral, the larger the value
+ or $x2 cmp $y2
+ # between equals, compare lexically!! amazing but true.
+ );
+ }
+ } else {
+ # X is numeric but Y isn't
+ $rv = Y_FIRST;
+ last;
+ }
+ } elsif( $y =~ s/^\d+//s ) { # we don't need to capture the substring
+ $rv = X_FIRST;
+ last;
+ }
+ # else one of them is 0-length.
+
+ # end-while
+ }
+ }
+EOGUTS
+
+sub maker {
+ my $code = $_[0];
+ $code =~ s/~COMPARATOR~/$guts/g || die "Can't find ~COMPARATOR~";
+ eval $code;
+ die $@ if $@;
+}
+
+##############################################################################
+
+maker(<<'EONSORT');
+sub nsort {
+ # get options:
+ my($cmp, $lc);
+ ($cmp,$lc) = @{shift @_} if @_ and ref($_[0]) eq 'ARRAY';
+
+ return @_ unless @_ > 1 or wantarray; # be clever
+
+ my($x, $x2, $y, $y2, $rv); # scratch vars
+
+ # We use a Schwartzian xform to memoize the lc'ing and \W-removal
+
+ map $_->[0],
+ sort {
+ if($a->[0] eq $b->[0]) { 0 } # trap this expensive case
+ else {
+
+ $x = $a->[1];
+ $y = $b->[1];
+
+~COMPARATOR~
+
+ # Tiebreakers...
+ DEBUG > 1 and print " -<${$a}[0]> cmp <${$b}[0]> is $rv ($ORD[$rv])\n";
+ $rv ||= (length($x) <=> length($y)) # shorter is always first
+ || ($cmp and $cmp->($x,$y) || $cmp->($a->[0], $b->[0]))
+ || ($x cmp $y )
+ || ($a->[0] cmp $b->[0])
+ ;
+
+ DEBUG > 1 and print " <${$a}[0]> cmp <${$b}[0]> is $rv ($ORD[$rv])\n";
+ $rv;
+ }}
+
+ map {;
+ $x = $lc ? $lc->($_) : lc($_); # x as scratch
+ $x =~ s/\W+//s;
+ [$_, $x];
+ }
+ @_
+}
+EONSORT
+
+#-----------------------------------------------------------------------------
+maker(<<'EONCMP');
+sub ncmp {
+ # The guts are basically the same as above...
+
+ # get options:
+ my($cmp, $lc);
+ ($cmp,$lc) = @{shift @_} if @_ and ref($_[0]) eq 'ARRAY';
+
+ if(@_ == 0) {
+ @_ = ($a, $b); # bit of a hack!
+ DEBUG > 1 and print "Hacking in <$a><$b>\n";
+ } elsif(@_ != 2) {
+ require Carp;
+ Carp::croak("Not enough options to ncmp!");
+ }
+ my($a,$b) = @_;
+ my($x, $x2, $y, $y2, $rv); # scratch vars
+
+ DEBUG > 1 and print "ncmp args <$a><$b>\n";
+ if($a eq $b) { # trap this expensive case
+ 0;
+ } else {
+ $x = ($lc ? $lc->($a) : lc($a));
+ $x =~ s/\W+//s;
+ $y = ($lc ? $lc->($b) : lc($b));
+ $y =~ s/\W+//s;
+
+~COMPARATOR~
+
+
+ # Tiebreakers...
+ DEBUG > 1 and print " -<$a> cmp <$b> is $rv ($ORD[$rv])\n";
+ $rv ||= (length($x) <=> length($y)) # shorter is always first
+ || ($cmp and $cmp->($x,$y) || $cmp->($a,$b))
+ || ($x cmp $y)
+ || ($a cmp $b)
+ ;
+
+ DEBUG > 1 and print " <$a> cmp <$b> is $rv\n";
+ $rv;
+ }
+}
+EONCMP
+
+# clean up:
+undef $guts;
+undef &maker;
+
+#-----------------------------------------------------------------------------
+1;
+
+############### END OF MAIN SOURCE ###########################################
+__END__
+
+=head1 NAME
+
+Sort::Naturally -- sort lexically, but sort numeral parts numerically
+
+=head1 SYNOPSIS
+
+ @them = nsort(qw(
+ foo12a foo12z foo13a foo 14 9x foo12 fooa foolio Foolio Foo12a
+ ));
+ print join(' ', @them), "\n";
+
+Prints:
+
+ 9x 14 foo fooa foolio Foolio foo12 foo12a Foo12a foo12z foo13a
+
+(Or "foo12a" + "Foo12a" and "foolio" + "Foolio" and might be
+switched, depending on your locale.)
+
+=head1 DESCRIPTION
+
+This module exports two functions, C<nsort> and C<ncmp>; they are used
+in implementing my idea of a "natural sorting" algorithm. Under natural
+sorting, numeric substrings are compared numerically, and other
+word-characters are compared lexically.
+
+This is the way I define natural sorting:
+
+=over
+
+=item *
+
+Non-numeric word-character substrings are sorted lexically,
+case-insensitively: "Foo" comes between "fish" and "fowl".
+
+=item *
+
+Numeric substrings are sorted numerically:
+"100" comes after "20", not before.
+
+=item *
+
+\W substrings (neither words-characters nor digits) are I<ignored>.
+
+=item *
+
+Our use of \w, \d, \D, and \W is locale-sensitive: Sort::Naturally
+uses a C<use locale> statement.
+
+=item *
+
+When comparing two strings, where a numeric substring in one
+place is I<not> up against a numeric substring in another,
+the non-numeric always comes first. This is fudged by
+reading pretending that the lack of a number substring has
+the value -1, like so:
+
+ foo => "foo", -1
+ foobar => "foo", -1, "bar"
+ foo13 => "foo", 13,
+ foo13xyz => "foo", 13, "xyz"
+
+That's so that "foo" will come before "foo13", which will come
+before "foobar".
+
+=item *
+
+The start of a string is exceptional: leading non-\W (non-word,
+non-digit)
+components are are ignored, and numbers come I<before> letters.
+
+=item *
+
+I define "numeric substring" just as sequences matching m/\d+/ --
+scientific notation, commas, decimals, etc., are not seen. If
+your data has thousands separators in numbers
+("20,000 Leagues Under The Sea" or "20.000 lieues sous les mers"),
+consider stripping them before feeding them to C<nsort> or
+C<ncmp>.
+
+=back
+
+=head2 The nsort function
+
+This function takes a list of strings, and returns a copy of the list,
+sorted.
+
+This is what most people will want to use:
+
+ @stuff = nsort(...list...);
+
+When nsort needs to compare non-numeric substrings, it
+uses Perl's C<lc> function in scope of a <use locale>.
+And when nsort needs to lowercase things, it uses Perl's
+C<lc> function in scope of a <use locale>. If you want nsort
+to use other functions instead, you can specify them in
+an arrayref as the first argument to nsort:
+
+ @stuff = nsort( [
+ \&string_comparator, # optional
+ \&lowercaser_function # optional
+ ],
+ ...list...
+ );
+
+If you want to specify a string comparator but no lowercaser,
+then the options list is C<[\&comparator, '']> or
+C<[\&comparator]>. If you want to specify no string comparator
+but a lowercaser, then the options list is
+C<['', \&lowercaser]>.
+
+Any comparator you specify is called as
+C<$comparator-E<gt>($left, $right)>,
+and, like a normal Perl C<cmp> replacement, must return
+-1, 0, or 1 depending on whether the left argument is stringwise
+less than, equal to, or greater than the right argument.
+
+Any lowercaser function you specify is called as
+C<$lowercased = $lowercaser-E<gt>($original)>. The routine
+must not modify its C<$_[0]>.
+
+=head2 The ncmp function
+
+Often, when sorting non-string values like this:
+
+ @objects_sorted = sort { $a->tag cmp $b->tag } @objects;
+
+...or even in a Schwartzian transform, like this:
+
+ @strings =
+ map $_->[0]
+ sort { $a->[1] cmp $b->[1] }
+ map { [$_, make_a_sort_key_from($_) ]
+ @_
+ ;
+
+...you wight want something that replaces not C<sort>, but C<cmp>.
+That's what Sort::Naturally's C<ncmp> function is for. Call it with
+the syntax C<ncmp($left,$right)> instead of C<$left cmp $right>,
+but otherwise it's a fine replacement:
+
+ @objects_sorted = sort { ncmp($a->tag,$b->tag) } @objects;
+
+ @strings =
+ map $_->[0]
+ sort { ncmp($a->[1], $b->[1]) }
+ map { [$_, make_a_sort_key_from($_) ]
+ @_
+ ;
+
+Just as with C<nsort> can take different a string-comparator
+and/or lowercaser, you can do the same with C<ncmp>, by passing
+an arrayref as the first argument:
+
+ ncmp( [
+ \&string_comparator, # optional
+ \&lowercaser_function # optional
+ ],
+ $left, $right
+ )
+
+You might get string comparators from L<Sort::ArbBiLex|Sort::ArbBiLex>.
+
+=head1 NOTES
+
+=over
+
+=item *
+
+This module is not a substitute for
+L<Sort::Versions|Sort::Versions>! If
+you just need proper version sorting, use I<that!>
+
+=item *
+
+If you need something that works I<sort of> like this module's
+functions, but not quite the same, consider scouting thru this
+module's source code, and adapting what you see. Besides
+the functions that actually compile in this module, after the POD,
+there's several alternate attempts of mine at natural sorting
+routines, which are not compiled as part of the module, but which you
+might find useful. They should all be I<working> implementations of
+slightly different algorithms
+(all of them based on Martin Pool's C<nsort>) which I eventually
+discarded in favor of my algorithm. If you are having to
+naturally-sort I<very large> data sets, and sorting is getting
+ridiculously slow, you might consider trying one of those
+discarded functions -- I have a feeling they might be faster on
+large data sets. Benchmark them on your data and see. (Unless
+you I<need> the speed, don't bother. Hint: substitute C<sort>
+for C<nsort> in your code, and unless your program speeds up
+drastically, it's not the sorting that's slowing things down.
+But if it I<is> C<nsort> that's slowing things down, consider
+just:
+
+ if(@set >= SOME_VERY_BIG_NUMBER) {
+ no locale; # vroom vroom
+ @sorted = sort(@set); # feh, good enough
+ } elsif(@set >= SOME_BIG_NUMBER) {
+ use locale;
+ @sorted = sort(@set); # feh, good enough
+ } else {
+ # but keep it pretty for normal cases
+ @sorted = nsort(@set);
+ }
+
+=item *
+
+If you do adapt the routines in this module, email me; I'd
+just be interested in hearing about it.
+
+=item *
+
+Thanks to the EFNet #perl people for encouraging this module,
+especially magister and a-mused.
+
+=back
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+Copyright 2001, Sean M. Burke C<sburke@cpan.org>, all rights
+reserved. This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Sean M. Burke C<sburke@cpan.org>
+
+=cut
+
+############ END OF DOCS ############
+
+############################################################################
+############################################################################
+
+############ BEGIN OLD STUFF ############
+
+# We can't have "use integer;", or else (5 <=> 5.1) comes out "0" !
+
+#-----------------------------------------------------------------------------
+sub nsort {
+ my($cmp, $lc);
+ return @_ if @_ < 2; # Just to be CLEVER.
+
+ my($x, $i); # scratch vars
+
+ # And now, the GREAT BIG Schwartzian transform:
+
+ map
+ $_->[0],
+
+ sort {
+ # Uses $i as the index variable, $x as the result.
+ $x = 0;
+ $i = 1;
+ DEBUG and print "\nComparing ", map("{$_}", @$a),
+ ' : ', map("{$_}", @$b), , "...\n";
+
+ while($i < @$a and $i < @$b) {
+ DEBUG and print " comparing $i: {$a->[$i]} cmp {$b->[$i]} => ",
+ $a->[$i] cmp $b->[$i], "\n";
+ last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
+ ++$i;
+
+ DEBUG and print " comparing $i: {$a->[$i]} <=> {$b->[$i]} => ",
+ $a->[$i] <=> $b->[$i], "\n";
+ last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
+ ++$i;
+ }
+
+ DEBUG and print "{$a->[0]} : {$b->[0]} is ",
+ $x || (@$a <=> @$b) || 0
+ ,"\n"
+ ;
+ $x || (@$a <=> @$b) || ($a->[0] cmp $b->[0]);
+ # unless we found a result for $x in the while loop,
+ # use length as a tiebreaker, otherwise use cmp
+ # on the original string as a fallback tiebreaker.
+ }
+
+ map {
+ my @bit = ($x = defined($_) ? $_ : '');
+
+ if($x =~ m/^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?\z/s) {
+ # It's entirely purely numeric, so treat it specially:
+ push @bit, '', $x;
+ } else {
+ # Consume the string.
+ while(length $x) {
+ push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
+ push @bit, ($x =~ s/^(\d+)//s) ? $1 : 0;
+ }
+ }
+ DEBUG and print "$bit[0] => ", map("{$_} ", @bit), "\n";
+
+ # End result: [original bit , (text, number), (text, number), ...]
+ # Minimally: [0-length original bit,]
+ # Examples:
+ # ['10' => '' , 10, ]
+ # ['fo900' => 'fo' , 900, ]
+ # ['foo10' => 'foo', 10, ]
+ # ['foo9.pl' => 'foo', 9, , '.pl', 0 ]
+ # ['foo32.pl' => 'foo', 32, , '.pl', 0 ]
+ # ['foo325.pl' => 'foo', 325, , '.pl', 0 ]
+ # Yes, always an ODD number of elements.
+
+ \@bit;
+ }
+ @_;
+}
+
+#-----------------------------------------------------------------------------
+# Same as before, except without the pure-number trap.
+
+sub nsorts {
+ return @_ if @_ < 2; # Just to be CLEVER.
+
+ my($x, $i); # scratch vars
+
+ # And now, the GREAT BIG Schwartzian transform:
+
+ map
+ $_->[0],
+
+ sort {
+ # Uses $i as the index variable, $x as the result.
+ $x = 0;
+ $i = 1;
+ DEBUG and print "\nComparing ", map("{$_}", @$a),
+ ' : ', map("{$_}", @$b), , "...\n";
+
+ while($i < @$a and $i < @$b) {
+ DEBUG and print " comparing $i: {$a->[$i]} cmp {$b->[$i]} => ",
+ $a->[$i] cmp $b->[$i], "\n";
+ last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
+ ++$i;
+
+ DEBUG and print " comparing $i: {$a->[$i]} <=> {$b->[$i]} => ",
+ $a->[$i] <=> $b->[$i], "\n";
+ last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
+ ++$i;
+ }
+
+ DEBUG and print "{$a->[0]} : {$b->[0]} is ",
+ $x || (@$a <=> @$b) || 0
+ ,"\n"
+ ;
+ $x || (@$a <=> @$b) || ($a->[0] cmp $b->[0]);
+ # unless we found a result for $x in the while loop,
+ # use length as a tiebreaker, otherwise use cmp
+ # on the original string as a fallback tiebreaker.
+ }
+
+ map {
+ my @bit = ($x = defined($_) ? $_ : '');
+
+ while(length $x) {
+ push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
+ push @bit, ($x =~ s/^(\d+)//s) ? $1 : 0;
+ }
+ DEBUG and print "$bit[0] => ", map("{$_} ", @bit), "\n";
+
+ # End result: [original bit , (text, number), (text, number), ...]
+ # Minimally: [0-length original bit,]
+ # Examples:
+ # ['10' => '' , 10, ]
+ # ['fo900' => 'fo' , 900, ]
+ # ['foo10' => 'foo', 10, ]
+ # ['foo9.pl' => 'foo', 9, , '.pl', 0 ]
+ # ['foo32.pl' => 'foo', 32, , '.pl', 0 ]
+ # ['foo325.pl' => 'foo', 325, , '.pl', 0 ]
+ # Yes, always an ODD number of elements.
+
+ \@bit;
+ }
+ @_;
+}
+
+#-----------------------------------------------------------------------------
+# Same as before, except for the sort-key-making
+
+sub nsort0 {
+ return @_ if @_ < 2; # Just to be CLEVER.
+
+ my($x, $i); # scratch vars
+
+ # And now, the GREAT BIG Schwartzian transform:
+
+ map
+ $_->[0],
+
+ sort {
+ # Uses $i as the index variable, $x as the result.
+ $x = 0;
+ $i = 1;
+ DEBUG and print "\nComparing ", map("{$_}", @$a),
+ ' : ', map("{$_}", @$b), , "...\n";
+
+ while($i < @$a and $i < @$b) {
+ DEBUG and print " comparing $i: {$a->[$i]} cmp {$b->[$i]} => ",
+ $a->[$i] cmp $b->[$i], "\n";
+ last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
+ ++$i;
+
+ DEBUG and print " comparing $i: {$a->[$i]} <=> {$b->[$i]} => ",
+ $a->[$i] <=> $b->[$i], "\n";
+ last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
+ ++$i;
+ }
+
+ DEBUG and print "{$a->[0]} : {$b->[0]} is ",
+ $x || (@$a <=> @$b) || 0
+ ,"\n"
+ ;
+ $x || (@$a <=> @$b) || ($a->[0] cmp $b->[0]);
+ # unless we found a result for $x in the while loop,
+ # use length as a tiebreaker, otherwise use cmp
+ # on the original string as a fallback tiebreaker.
+ }
+
+ map {
+ my @bit = ($x = defined($_) ? $_ : '');
+
+ if($x =~ m/^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?\z/s) {
+ # It's entirely purely numeric, so treat it specially:
+ push @bit, '', $x;
+ } else {
+ # Consume the string.
+ while(length $x) {
+ push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
+ # Secret sauce:
+ if($x =~ s/^(\d+)//s) {
+ if(substr($1,0,1) eq '0' and $1 != 0) {
+ push @bit, $1 / (10 ** length($1));
+ } else {
+ push @bit, $1;
+ }
+ } else {
+ push @bit, 0;
+ }
+ }
+ }
+ DEBUG and print "$bit[0] => ", map("{$_} ", @bit), "\n";
+
+ \@bit;
+ }
+ @_;
+}
+
+#-----------------------------------------------------------------------------
+# Like nsort0, but WITHOUT pure number handling, and WITH special treatment
+# of pulling off extensions and version numbers.
+
+sub nsortf {
+ return @_ if @_ < 2; # Just to be CLEVER.
+
+ my($x, $i); # scratch vars
+
+ # And now, the GREAT BIG Schwartzian transform:
+
+ map
+ $_->[0],
+
+ sort {
+ # Uses $i as the index variable, $x as the result.
+ $x = 0;
+ $i = 3;
+ DEBUG and print "\nComparing ", map("{$_}", @$a),
+ ' : ', map("{$_}", @$b), , "...\n";
+
+ while($i < @$a and $i < @$b) {
+ DEBUG and print " comparing $i: {$a->[$i]} cmp {$b->[$i]} => ",
+ $a->[$i] cmp $b->[$i], "\n";
+ last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
+ ++$i;
+
+ DEBUG and print " comparing $i: {$a->[$i]} <=> {$b->[$i]} => ",
+ $a->[$i] <=> $b->[$i], "\n";
+ last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
+ ++$i;
+ }
+
+ DEBUG and print "{$a->[0]} : {$b->[0]} is ",
+ $x || (@$a <=> @$b) || 0
+ ,"\n"
+ ;
+ $x || (@$a <=> @$b ) || ($a->[1] cmp $b->[1])
+ || ($a->[2] <=> $b->[2]) || ($a->[0] cmp $b->[0]);
+ # unless we found a result for $x in the while loop,
+ # use length as a tiebreaker, otherwise use the
+ # lc'd extension, otherwise the verison, otherwise use
+ # the original string as a fallback tiebreaker.
+ }
+
+ map {
+ my @bit = ( ($x = defined($_) ? $_ : ''), '',0 );
+
+ {
+ # Consume the string.
+
+ # First, pull off any VAX-style version
+ $bit[2] = $1 if $x =~ s/;(\d+)$//;
+
+ # Then pull off any apparent extension
+ if( $x !~ m/^\.+$/s and # don't mangle ".", "..", or "..."
+ $x =~ s/(\.[^\.\;]*)$//sg
+ # We could try to avoid catching all-digit extensions,
+ # but I think that's getting /too/ clever.
+ ) {
+ $i = $1;
+ if($x =~ m<[^\\\://]$>s) {
+ # We didn't take the whole basename.
+ $bit[1] = lc $i;
+ DEBUG and print "Consuming extension \"$1\"\n";
+ } else {
+ # We DID take the whole basename. Fix it.
+ $x = $1; # Repair it.
+ }
+ }
+
+ push @bit, '', -1 if $x =~ m/^\./s;
+ # A hack to make .-initial filenames sort first, regardless of locale.
+ # And -1 is always a sort-firster, since in the code below, there's
+ # no allowance for filenames containing negative numbers: -1.dat
+ # will be read as string '-' followed by number 1.
+
+ while(length $x) {
+ push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
+ # Secret sauce:
+ if($x =~ s/^(\d+)//s) {
+ if(substr($1,0,1) eq '0' and $1 != 0) {
+ push @bit, $1 / (10 ** length($1));
+ } else {
+ push @bit, $1;
+ }
+ } else {
+ push @bit, 0;
+ }
+ }
+ }
+
+ DEBUG and print "$bit[0] => ", map("{$_} ", @bit), "\n";
+
+ \@bit;
+ }
+ @_;
+}
+
+# yowza yowza yowza.
+
# Common YAML character sets
my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
my $FOLD_CHAR = '>';
-my $LIT_CHAR = '|';
-my $LIT_CHAR_RX = "\\$LIT_CHAR";
+my $LIT_CHAR = '|';
+my $LIT_CHAR_RX = "\\$LIT_CHAR";
sub load {
my $self = shift;
$self->{stream} =~ s|\015\012|\012|g;
$self->{stream} =~ s|\015|\012|g;
$self->line(0);
- $self->die('YAML_PARSE_ERR_BAD_CHARS')
+ $self->die('YAML_PARSE_ERR_BAD_CHARS')
if $self->stream =~ /$ESCAPE_CHAR/;
- $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE')
- if length($self->stream) and
+ # $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE')
+ $self->{stream} .= "\n"
+ if length($self->stream) and
$self->{stream} !~ s/(.)\n\Z/$1/s;
$self->lines([split /\x0a/, $self->stream, -1]);
$self->line(1);
$directives{YAML} ||= '1.0';
$directives{TAB} ||= 'NONE';
- ($self->{major_version}, $self->{minor_version}) =
+ ($self->{major_version}, $self->{minor_version}) =
split /\./, $directives{YAML}, 2;
$self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML})
if $self->major_version ne '1';
$self->preface('');
my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
- ($anchor, $alias, $explicit, $implicit, $preface) =
+ ($anchor, $alias, $explicit, $implicit, $preface) =
$self->_parse_qualifiers($preface);
if ($anchor) {
$self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
$self->inline('');
while (length $preface) {
my $line = $self->line - 1;
- if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) {
+ if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) {
$indicator = $1;
$chomp = $2 if defined($2);
}
}
else {
$node = do {my $sv = "*$alias"};
- push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
+ push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
}
}
elsif (length $self->inline) {
$node = $self->_parse_inline(1, $implicit, $explicit);
if (length $self->inline) {
- $self->die('YAML_PARSE_ERR_SINGLE_LINE');
+ $self->die('YAML_PARSE_ERR_SINGLE_LINE');
}
}
elsif ($indicator eq $LIT_CHAR) {
$self->{level}++;
$node = $self->_parse_block($chomp);
$node = $self->_parse_implicit($node) if $implicit;
- $self->{level}--;
+ $self->{level}--;
}
elsif ($indicator eq $FOLD_CHAR) {
$self->{level}++;
}
elsif ($preface =~ s/^\&([^ ,:]+)\s*//) {
$token = $1;
- $self->die('YAML_PARSE_ERR_BAD_ANCHOR')
+ $self->die('YAML_PARSE_ERR_BAD_ANCHOR')
unless $token =~ /^[a-zA-Z0-9]+$/;
$self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor;
$self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias;
$alias = $token;
}
}
- return ($anchor, $alias, $explicit, $implicit, $preface);
+ return ($anchor, $alias, $explicit, $implicit, $preface);
}
-# Morph a node to it's explicit type
+# Morph a node to it's explicit type
sub _parse_explicit {
my $self = shift;
my ($node, $explicit) = @_;
$key = $self->_parse_node();
$key = "$key";
}
- # If "default" key (equals sign)
+ # If "default" key (equals sign)
elsif ($self->{content} =~ s/^\=\s*//) {
$key = VALUE;
}
$self->content($self->inline);
$self->inline('');
}
-
+
unless ($self->{content} =~ s/^:\s*//) {
$self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT');
}
my ($top, $top_implicit, $top_explicit) = (@_, '', '', '');
$self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump
my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5;
- ($anchor, $alias, $explicit, $implicit, $self->{inline}) =
+ ($anchor, $alias, $explicit, $implicit, $self->{inline}) =
$self->_parse_qualifiers($self->inline);
if ($anchor) {
$self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
}
else {
$node = do {my $sv = "*$alias"};
- push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
+ push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
}
}
elsif ($self->inline =~ /^\{/) {
my $value = $self->_parse_inline();
push @$node, $value;
next if $self->inline =~ /^\s*\]/;
- $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
+ $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
unless $self->{inline} =~ s/^\,\s*//;
}
return $node;
# 3) Find the next _content_ line
# A) Skip over any throwaways (Comments/blanks)
# B) Set $self->indent, $self->content, $self->line
-# 4) Expand tabs appropriately
+# 4) Expand tabs appropriately
sub _parse_next_line {
my $self = shift;
my ($type) = @_;
$offset = $self->offset->[++$level];
}
# Determine the offset for a new collection level
- elsif ($type == COLLECTION and
+ elsif ($type == COLLECTION and
$self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
$self->_parse_throwaway_comments();
if ($self->eos) {
}
$offset = $self->offset->[++$level];
}
-
+
if ($type == LEAF) {
while (@{$self->lines} and
$self->lines->[0] =~ m{^( *)(\#)} and
else {
$self->_parse_throwaway_comments();
}
- return if $self->eos;
-
+ return if $self->eos;
+
if ($self->lines->[0] =~ /^---(\s|$)/) {
$self->done(1);
return;
}
- if ($type == LEAF and
+ if ($type == LEAF and
$self->lines->[0] =~ /^ {$offset}(.*)$/
) {
$self->indent($offset);
while ($self->offset->[$level] > length($1)) {
$level--;
}
- $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION')
+ $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION')
if $self->offset->[$level] != length($1);
$self->indent(length($1));
$self->content($2);
#==============================================================================
# Printable characters for escapes
-my %unescapes =
+my %unescapes =
(
z => "\x00", a => "\x07", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
-
+
# Transform all the backslash style escape characters to their literal meaning
sub _unescape {
my $self = shift;
push @INC, "modules/fallback"; # Only use our own versions of modules if there's no system version.
}
-use Config::Std;
use Data::Dumper;
use Devel::REPL 1.002001;
use Term::ReadLine::Perl::Bind; # use sane key binding for rxvt users
-read_config 'config/console.conf' => my %config;# if -f 'config/console.conf';
+use SL::LxOfficeConf;
+SL::LxOfficeConf->read;
-my $login = shift || $config{Console}{login} || 'demo';
-my $history_file = $config{Console}{history_file} || '/tmp/lxoffice_console_history.log'; # fallback if users is not writable
-my $autorun = $config{Console}{autorun};
+my $login = shift || $::lx_office_conf{console}{login} || 'demo';
+my $history_file = $::lx_office_conf{console}{history_file} || '/tmp/lxoffice_console_history.log'; # fallback if users is not writable
+my $autorun = $::lx_office_conf{console}{autorun};
# will be configed eventually
my @plugins = qw(History LexEnv Colors MultiLine::PPI FancyPrompt PermanentHistory AutoloadModules);
package main;
- { no warnings 'once';
- $::userspath = "users";
- $::templates = "templates";
- $::sendmail = "| /usr/sbin/sendmail -t";
- }
-
- eval { require "config/lx-erp.conf"; };
- eval { require "config/lx-erp-local.conf"; } if -f "config/lx-erp-local.conf";
-
$::lxdebug = LXDebug->new;
- $::locale = Locale->new($::language);
+ $::locale = Locale->new($::lx_office_conf{system}->{language});
$::cgi = CGI->new qw();
$::form = Form->new;
$::auth = SL::Auth->new;
Configuration of this script is located in:
- config/console.conf
- config/console.conf.default
+ config/lx_office.conf
+ config/lx_office.conf.default
See there for interesting options.
use utf8;
use English '-no_match_vars';
+use Config::Std;
use DBI;
use Data::Dumper;
use Getopt::Long;
use Text::Iconv;
use SL::LXDebug;
+use SL::LxOfficeConf;
+SL::LxOfficeConf->read;
our $lxdebug = LXDebug->new();
use SL::Auth;
#######
#######
-eval { require "config/lx-erp.conf"; };
-eval { require "config/lx-erp-local.conf"; } if (-f "config/lx-erp-local.conf");
-
-$locale = Locale->new($::language);
-$form = Form->new();
+$locale = Locale->new;
+$form = Form->new;
#######
#######
#!/usr/bin/perl -l
use strict;
#use warnings; # corelist and find throw tons of warnings
-use Module::CoreList;
use File::Find;
+use Module::CoreList;
use SL::InstallationCheck;
-
-my (%uselines, %modules, %supplied);
+use Term::ANSIColor;
+
+my (%uselines, %modules, %supplied, %requires);
+
+# since the information which classes belong to a cpan distribution is not
+# easily obtained, I'll just hard code the bigger ones we use here. the same
+# hash will be filled later with information gathered from the source files.
+%requires = (
+ 'DateTime' => {
+ 'DateTime::Duration' => 1,
+ 'DateTime::Infinite' => 1,
+ },
+ 'Rose::DB::Object' => {
+ 'Rose::DB::Object::ConventionManager' => 1,
+ 'Rose::DB::Object::Manager' => 1,
+ 'Rose::DB::Object::Metadata' => 1,
+ },
+ 'Rose::Object' => {
+ 'Rose::Object::MakeMethods::Generic' => 1,
+ },
+ 'Template' => {
+ 'Template::Constants' => 1,
+ 'Template::Exception' => 1,
+ 'Template::Iterator' => 1,
+ 'Template::Plugin' => 1,
+ 'Template::Plugin::Filter' => 1,
+ },
+);
find(sub {
return unless /(\.p[lm]|console)$/;
my ($useline) = m/^use\s+(.*?)$/;
- next if $useline =~ /^[\d.]+;/; # skip version requirements
+ next if $useline =~ /^[\d._]+;/; # skip version requirements
next if !$useline;
- $uselines{$useline}++;
+ $uselines{$useline} ||= [];
+ push @{ $uselines{$useline} }, $File::Find::name;
}
}, '.');
for my $useline (keys %uselines) {
$useline =~ s/#.*//; # kill comments
- # modules can be loaded implicit with use base qw(Module) or use parent
+ # modules can be loaded implicitly with use base qw(Module) or use parent
# 'Module'. catch these:
my ($module, $args) = $useline =~ /
(?:
next if $useline =~ /^most and offer that in a small/; # YAML
my $version = Module::CoreList->first_release($module);
- $modules{$module} = $supplied{$module} ? 'included'
- : $version ? sprintf '%2.6f', $version
- : is_documented($module) ? 'required'
- : '!missing';
+ $modules{$module} = { status => $supplied{$module} ? 'included'
+ : $version ? sprintf '%2.6f', $version
+ : is_documented($module) ? 'required'
+ : '!missing',
+ files => $uselines{$useline},
+ };
+
+ # build requirement tree
+ for my $file (@{ $uselines{$useline} }) {
+ next if $file =~ /\.pl$/;
+ my $orig_module = modulize($file);
+ $requires{$orig_module} ||= {};
+ $requires{$orig_module}{$module}++;
+ }
}
-print sprintf "%8s : %s", $modules{$_}, $_
+# build transitive closure for documented dependancies
+my $changed = 1;
+while ($changed) {
+ $changed = 0;
+ for my $src_module (keys %requires) {
+ for my $dst_module (keys %{ $requires{$src_module} }) {
+ if ( $modules{$src_module}
+ && $modules{$dst_module}
+ && $modules{$src_module}->{status} =~ /^required/
+ && $modules{$dst_module}->{status} eq '!missing') {
+ $modules{$dst_module}->{status} = "required"; # . ", via $src_module";
+ $changed = 1;
+ }
+ }
+ }
+}
+
+print sprintf "%8s : %s (%s)", color_text($modules{$_}->{status}), $_, join(' ', @{ $modules{$_}->{files} || [] })
for sort {
- $modules{$a} cmp $modules{$b}
- || $a cmp $b
+ $modules{$a}->{status} cmp $modules{$b}->{status}
+ || $a cmp $b
} keys %modules;
sub modulize {
for (my ($name) = @_) {
s#^./modules/\w+/##;
+ s#^./##;
s#.pm$##;
s#/#::#g;
return $_;
sub is_documented {
my ($module) = @_;
- return grep { $_->{name} eq $module } @SL::InstallationCheck::required_modules;
+ grep { $_->{name} eq $module } @SL::InstallationCheck::required_modules;
+}
+
+sub color_text {
+ my ($text) = @_;
+ return color(get_color($text)) . $text . color('reset');
+}
+
+sub get_color {
+ for (@_) {
+ return 'yellow' if /^5./ && $_ > 5.008;
+ return 'green' if /^5./;
+ return 'green' if /^included/;
+ return 'red' if /^!missing/;
+ return 'yellow';
+ }
}
+1;
+
__END__
=head1 NAME
=head1 EXAMPLE
# perl scipts/find-use.pl
- missing : Perl::Tags
- missing : Template::Constants
- missing : DBI
+ !missing : Perl::Tags
+ !missing : Template::Constants
+ !missing : DBI
=head1 EXPLANATION
This util is useful for package builders to identify all the CPAN dependencies
-we've made. It requires Module::CoreList (which is core, but is not in most
-stable releases of perl) to determine if a module is distributed with perl or
-not. The output reports which version of perl the module is in. If it reports
-0.000000, then the module is not in core perl, and needs to be installed before
-Lx-Office will operate.
+we have. It requires Module::CoreList (which is core since 5.9) to determine if
+a module is distributed with perl or not. The output will be one of the
+following:
+
+=over 4
+
+=item VERSION
+
+If a version string is displayed, the module is core since this version.
+Everything up to 5.8 is alright. 5.10 (aka 5.010) is acceptable, but should be
+documented. Please do not use 5.12 core modules without adding an explicit
+requirement.
+
+=item included
+
+This module is included in C<modules/*>. Don't worry about it.
+
+=item required
+
+This module is documented in C<SL:InstallationCheck> to be necessary, or is a
+dependancy of one of these. Everything alright.
+
+= item !missing
+
+These modules are neither core, nor included, nor required. This is ok for
+developer tools, but should never occur for modules the actual program uses.
=head1 AUTHOR
my $basedir = "../..";
my $locales_dir = ".";
my $bindir = "$basedir/bin/mozilla";
-my @progdirs = ( "$basedir/SL/Controller", "$basedir/SL/Template/Plugin" );
+my @progdirs = ( "$basedir/SL/Controller", "$basedir/SL/Template/Plugin", "$basedir/SL/Auth" );
my $dbupdir = "$basedir/sql/Pg-upgrade";
my $dbupdir2 = "$basedir/sql/Pg-upgrade2";
my $menufile = "menu.ini";
}
use CGI qw( -no_xhtml);
+use Config::Std;
use Data::Dumper;
use English qw( -no_match_vars );
use List::MoreUtils qw(any);
use SL::Form;
use SL::Locale;
use SL::LXDebug;
+use SL::LxOfficeConf;
use SL::DB::Helper::ALL;
use SL::DB::Helper::Mappings;
our $form;
our $cgi;
our $auth;
+our %lx_office_conf;
our $script = __FILE__;
$script =~ s:.*/::;
exit 1;
}
- my $login = shift @ARGV;
+ SL::LxOfficeConf->read;
- $::userspath = "users";
- $::templates = "templates";
- $::sendmail = "| /usr/sbin/sendmail -t";
+ my $login = shift @ARGV;
$::lxdebug = LXDebug->new();
- require "config/lx-erp.conf";
- require "config/lx-erp-local.conf" if -f "config/lx-erp-local.conf";
-
# locale messages
$::locale = Locale->new("de");
$::form = new Form;
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'
use SL::Form;
use SL::Template;
-$userspath = "users";
-$templates = "templates";
-$memberfile = "users/members";
$sendmail = "| /usr/sbin/sendmail -t";
$| = 1;
$lxdebug = LXDebug->new();
-require "lx-erp.conf";
-
$form = new Form;
$form->{"script"} = "oe.pl";
--- /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 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::LxOfficeConf;
+use SL::Locale;
+
+our %lx_office_conf;
+
+# 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 = $lx_office_conf{task_server}->{login};
+
+ package main;
+
+ $::lxdebug = LXDebug->new;
+ $::locale = Locale->new($::lx_office_conf{system}->{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 = $lx_office_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;
+
+ SL::LxOfficeConf->read;
+
+ die "Missing section [task_server] in config file" unless $lx_office_conf{task_server};
+ die "Missing key 'login' in section [task_server] in config file" unless $lx_office_conf{task_server}->{login};
+
+ drop_privileges();
+ lxinit();
+
+ return ();
+}
+
+sub gd_run {
+ while (1) {
+ my $ok = eval {
+ $::lxdebug->message(0, "Retrieving jobs") if $lx_office_conf{task_server}->{debug};
+
+ my $jobs = SL::DB::Manager::BackgroundJob->get_all_need_to_run;
+
+ $::lxdebug->message(0, " Found: " . join(' ', map { $_->package_name } @{ $jobs })) if $lx_office_conf{task_server}->{debug} && @{ $jobs };
+
+ foreach my $job (@{ $jobs }) {
+ # Provide fresh global variables in case legacy code modifies
+ # them somehow.
+ $::locale = Locale->new($::lx_office_conf{system}->{language});
+ $::form = Form->new;
+
+ $job->run;
+ }
+
+ 1;
+ };
+
+ if ($lx_office_conf{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;
+
+my $file = -f "${cwd}/config/lx_office.conf" ? "${cwd}/config/lx_office.conf" : "${cwd}/config/lx_office.conf.default";
+newdaemon(configfile => $file,
+ progname => 'lx-office-task-server',
+ pidbase => "${pidbase}/",
+ );
+
+1;
$sth->execute() || mydberror($query);
my $query_update = "UPDATE parts SET buchungsgruppen_id = ?";
- $query_update .= ", inventory_accno_id = ?" if ($main::eur);
+ $query_update .= ", inventory_accno_id = ?" if $::lx_office_conf{system}->{eur};
$query_update .= " WHERE id = ?";
my $sth_update = $dbh->prepare($query_update);
while (my $ref = $sth->fetchrow_hashref()) {
foreach my $bg (@{$buchungsgruppen}) {
- if (($main::eur ||
+ if (($::lx_office_conf{system}->{eur} ||
($ref->{"inventory_accno_id"} == $bg->{"inventory_accno_id"})) &&
($ref->{"income_accno_id"} == $bg->{"income_accno_id_0"}) &&
($ref->{"expense_accno_id"} == $bg->{"expense_accno_id_0"})) {
my @values = ($bg->{"id"}, $ref->{"id"});
- splice(@values, 1, 0, $bg->{"inventory_accno_id"}) if ($main::eur);
+ splice(@values, 1, 0, $bg->{"inventory_accno_id"}) if $::lx_office_conf{system}->{eur};
$sth_update->execute(@values) ||
mydberror($query_update . " (" . join(", ", @values) . ")");
last;
if (($ref->{"income_accno_id"} == $bg->{"income_accno_id_0"}) &&
($ref->{"expense_accno_id"} == $bg->{"expense_accno_id_0"})) {
my @values = ($bg->{"id"}, $ref->{"id"});
- splice(@values, 1, 0, undef) if ($main::eur);
+ splice(@values, 1, 0, undef) if $::lx_office_conf{system}->{eur};
$sth_update->execute(@values) ||
mydberror($query_update . " (" . join(", ", @values) . ")");
last;
$entry->{"ACC_INVENTORY"} = $acc_inventory;
$entry->{"ACC_INCOME"} = $acc_income;
$entry->{"ACC_EXPENSE"} = $acc_expense;
- $entry->{"eur"} = $main::eur;
+ $entry->{"eur"} = $::lx_office_conf{system}->{eur};
}
# $form->parse_html_template("dbupgrade/buchungsgruppen_parts")
# If balancing is off then force parts.inventory_accno_id to
# a single value for parts.
- force_inventory_accno_id_for_parts() if ($main::eur);
+ force_inventory_accno_id_for_parts() if $::lx_office_conf{system}->{eur};
# Force "IC" to be present in chart.link for all accounts
# which have been used as inventory accounts in parts.
--- /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;
</table>
<p>
- [% 'If you want to change any of these parameters then press the "Back" button, edit the file "config/authentication.pl" and login into the admin module again.' | $T8 %]
+ [% 'If you want to change any of these parameters then press the "Back" button, edit the file "config/lx_office.conf" and login into the admin module again.' | $T8 %]
</p>
<form method="post" action="admin.pl">
<p><b>[% 'Error!' | $T8 %]</b></p>
- <p>[% 'The authentication configuration file "config/authentication.pl" does not exist. This Lx-Office installation has probably not been updated correctly yet. Please contact your administrator.' | $T8 %]</p>
+ <p>[% 'The authentication configuration file "config/lx_office.conf" does not exist. This Lx-Office installation has probably not been updated correctly yet. Please contact your administrator.' | $T8 %]</p>
<p>[% 'If you yourself want to upgrade the installation then please read the file "doc/UPGRADE" and follow the steps outlined in this file.' | $T8 %]</p>
--- /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>
<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