|
#=====================================================================
|
|
# LX-Office ERP
|
|
# Copyright (C) 2004
|
|
# Based on SQL-Ledger Version 2.1.9
|
|
# Web http://www.lx-office.org
|
|
#
|
|
#=====================================================================
|
|
# SQL-Ledger Accounting
|
|
# Copyright (C) 1998-2002
|
|
#
|
|
# Author: Dieter Simader
|
|
# Email: dsimader@sql-ledger.org
|
|
# Web: http://www.sql-ledger.org
|
|
#
|
|
# Contributors: Thomas Bayen <bayen@gmx.de>
|
|
# Antti Kaihola <akaihola@siba.fi>
|
|
# Moritz Bunkus (tex code)
|
|
#
|
|
# This program is free software; you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 2 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# 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. See the
|
|
# GNU General Public License for more details.
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program; if not, write to the Free Software
|
|
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
|
|
# MA 02110-1335, USA.
|
|
#======================================================================
|
|
# Utilities for parsing forms
|
|
# and supporting routines for linking account numbers
|
|
# used in AR, AP and IS, IR modules
|
|
#
|
|
#======================================================================
|
|
|
|
package Form;
|
|
|
|
use Carp;
|
|
use Data::Dumper;
|
|
|
|
use Carp;
|
|
use CGI;
|
|
use Cwd;
|
|
use Encode;
|
|
use File::Copy;
|
|
use File::Temp ();
|
|
use IO::File;
|
|
use Math::BigInt;
|
|
use Params::Validate qw(:all);
|
|
use POSIX qw(strftime);
|
|
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::DBConnect;
|
|
use SL::DBUtils;
|
|
use SL::DB::AdditionalBillingAddress;
|
|
use SL::DB::Customer;
|
|
use SL::DB::CustomVariableConfig;
|
|
use SL::DB::Default;
|
|
use SL::DB::PaymentTerm;
|
|
use SL::DB::Vendor;
|
|
use SL::DO;
|
|
use SL::Helper::Flash qw();
|
|
use SL::IC;
|
|
use SL::IS;
|
|
use SL::Layout::Dispatcher;
|
|
use SL::Locale;
|
|
use SL::Locale::String;
|
|
use SL::Mailer;
|
|
use SL::Menu;
|
|
use SL::MoreCommon qw(uri_encode uri_decode);
|
|
use SL::OE;
|
|
use SL::PrefixedNumber;
|
|
use SL::Request;
|
|
use SL::Template;
|
|
use SL::User;
|
|
use SL::Util;
|
|
use SL::Version;
|
|
use SL::X;
|
|
use Template;
|
|
use URI;
|
|
use List::Util qw(first max min sum);
|
|
use List::MoreUtils qw(all any apply);
|
|
use SL::DB::Tax;
|
|
use SL::Helper::File qw(:all);
|
|
use SL::Helper::Number;
|
|
use SL::Helper::CreatePDF qw(merge_pdfs);
|
|
|
|
use strict;
|
|
|
|
sub read_version {
|
|
SL::Version->get_version;
|
|
}
|
|
|
|
sub new {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my $type = shift;
|
|
|
|
my $self = {};
|
|
|
|
no warnings 'once';
|
|
if ($LXDebug::watch_form) {
|
|
require SL::Watchdog;
|
|
tie %{ $self }, 'SL::Watchdog';
|
|
}
|
|
|
|
bless $self, $type;
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub _flatten_variables_rec {
|
|
$main::lxdebug->enter_sub(2);
|
|
|
|
my $self = shift;
|
|
my $curr = shift;
|
|
my $prefix = shift;
|
|
my $key = shift;
|
|
|
|
my @result;
|
|
|
|
if ('' eq ref $curr->{$key}) {
|
|
@result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
|
|
|
|
} elsif ('HASH' eq ref $curr->{$key}) {
|
|
foreach my $hash_key (sort keys %{ $curr->{$key} }) {
|
|
push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
|
|
}
|
|
|
|
} else {
|
|
foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
|
|
my $first_array_entry = 1;
|
|
|
|
my $element = $curr->{$key}[$idx];
|
|
|
|
if ('HASH' eq ref $element) {
|
|
foreach my $hash_key (sort keys %{ $element }) {
|
|
push @result, $self->_flatten_variables_rec($element, $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
|
|
$first_array_entry = 0;
|
|
}
|
|
} else {
|
|
push @result, { 'key' => $prefix . $key . '[]', 'value' => $element };
|
|
}
|
|
}
|
|
}
|
|
|
|
$main::lxdebug->leave_sub(2);
|
|
|
|
return @result;
|
|
}
|
|
|
|
sub flatten_variables {
|
|
$main::lxdebug->enter_sub(2);
|
|
|
|
my $self = shift;
|
|
my @keys = @_;
|
|
|
|
my @variables;
|
|
|
|
foreach (@keys) {
|
|
push @variables, $self->_flatten_variables_rec($self, '', $_);
|
|
}
|
|
|
|
$main::lxdebug->leave_sub(2);
|
|
|
|
return @variables;
|
|
}
|
|
|
|
sub flatten_standard_variables {
|
|
$main::lxdebug->enter_sub(2);
|
|
|
|
my $self = shift;
|
|
my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar), @_);
|
|
|
|
my @variables;
|
|
|
|
foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
|
|
push @variables, $self->_flatten_variables_rec($self, '', $_);
|
|
}
|
|
|
|
$main::lxdebug->leave_sub(2);
|
|
|
|
return @variables;
|
|
}
|
|
|
|
sub escape {
|
|
my ($self, $str) = @_;
|
|
|
|
return uri_encode($str);
|
|
}
|
|
|
|
sub unescape {
|
|
my ($self, $str) = @_;
|
|
|
|
return uri_decode($str);
|
|
}
|
|
|
|
sub quote {
|
|
$main::lxdebug->enter_sub();
|
|
my ($self, $str) = @_;
|
|
|
|
if ($str && !ref($str)) {
|
|
$str =~ s/\"/"/g;
|
|
}
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
return $str;
|
|
}
|
|
|
|
sub unquote {
|
|
$main::lxdebug->enter_sub();
|
|
my ($self, $str) = @_;
|
|
|
|
if ($str && !ref($str)) {
|
|
$str =~ s/"/\"/g;
|
|
}
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
return $str;
|
|
}
|
|
|
|
sub hide_form {
|
|
$main::lxdebug->enter_sub();
|
|
my $self = shift;
|
|
|
|
if (@_) {
|
|
map({ print($::request->{cgi}->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
|
|
} else {
|
|
for (sort keys %$self) {
|
|
next if (($_ eq "header") || (ref($self->{$_}) ne ""));
|
|
print($::request->{cgi}->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
|
|
}
|
|
}
|
|
$main::lxdebug->leave_sub();
|
|
}
|
|
|
|
sub throw_on_error {
|
|
my ($self, $code) = @_;
|
|
local $self->{__ERROR_HANDLER} = sub { SL::X::FormError->throw(error => $_[0]) };
|
|
$code->();
|
|
}
|
|
|
|
sub error {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
$main::lxdebug->show_backtrace();
|
|
|
|
my ($self, $msg) = @_;
|
|
|
|
if ($self->{__ERROR_HANDLER}) {
|
|
$self->{__ERROR_HANDLER}->($msg);
|
|
|
|
} elsif ($ENV{HTTP_USER_AGENT}) {
|
|
$msg =~ s/\n/<br>/g;
|
|
$self->show_generic_error($msg);
|
|
|
|
} else {
|
|
confess "Error: $msg\n";
|
|
}
|
|
|
|
$main::lxdebug->leave_sub();
|
|
}
|
|
|
|
sub info {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my ($self, $msg) = @_;
|
|
|
|
if ($ENV{HTTP_USER_AGENT}) {
|
|
$self->header;
|
|
print $self->parse_html_template('generic/form_info', { message => $msg });
|
|
|
|
} elsif ($self->{info_function}) {
|
|
&{ $self->{info_function} }($msg);
|
|
} else {
|
|
print "$msg\n";
|
|
}
|
|
|
|
$main::lxdebug->leave_sub();
|
|
}
|
|
|
|
# calculates the number of rows in a textarea based on the content and column number
|
|
# can be capped with maxrows
|
|
sub numtextrows {
|
|
$main::lxdebug->enter_sub();
|
|
my ($self, $str, $cols, $maxrows, $minrows) = @_;
|
|
|
|
$minrows ||= 1;
|
|
|
|
my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
|
|
$maxrows ||= $rows;
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
return max(min($rows, $maxrows), $minrows);
|
|
}
|
|
|
|
sub dberror {
|
|
my ($self, $msg) = @_;
|
|
|
|
SL::X::DBError->throw(
|
|
msg => $msg,
|
|
db_error => $DBI::errstr,
|
|
);
|
|
}
|
|
|
|
sub isblank {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my ($self, $name, $msg) = @_;
|
|
|
|
my $curr = $self;
|
|
foreach my $part (split m/\./, $name) {
|
|
if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
|
|
$self->error($msg);
|
|
}
|
|
$curr = $curr->{$part};
|
|
}
|
|
|
|
$main::lxdebug->leave_sub();
|
|
}
|
|
|
|
sub _get_request_uri {
|
|
my $self = shift;
|
|
|
|
return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
|
|
return URI->new if !$ENV{REQUEST_URI}; # for testing
|
|
|
|
my $scheme = $::request->is_https ? 'https' : 'http';
|
|
my $port = $ENV{SERVER_PORT};
|
|
$port = undef if (($scheme eq 'http' ) && ($port == 80))
|
|
|| (($scheme eq 'https') && ($port == 443));
|
|
|
|
my $uri = URI->new("${scheme}://");
|
|
$uri->scheme($scheme);
|
|
$uri->port($port);
|
|
$uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
|
|
$uri->path_query($ENV{REQUEST_URI});
|
|
$uri->query('');
|
|
|
|
return $uri;
|
|
}
|
|
|
|
sub _add_to_request_uri {
|
|
my $self = shift;
|
|
|
|
my $relative_new_path = shift;
|
|
my $request_uri = shift || $self->_get_request_uri;
|
|
my $relative_new_uri = URI->new($relative_new_path);
|
|
my @request_segments = $request_uri->path_segments;
|
|
|
|
my $new_uri = $request_uri->clone;
|
|
$new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
|
|
|
|
return $new_uri;
|
|
}
|
|
|
|
sub create_http_response {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my $self = shift;
|
|
my %params = @_;
|
|
|
|
my $cgi = $::request->{cgi};
|
|
|
|
my $session_cookie;
|
|
if (defined $main::auth) {
|
|
my $uri = $self->_get_request_uri;
|
|
my @segments = $uri->path_segments;
|
|
pop @segments;
|
|
$uri->path_segments(@segments);
|
|
|
|
my $session_cookie_value = $main::auth->get_session_id();
|
|
|
|
if ($session_cookie_value) {
|
|
$session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
|
|
'-value' => $session_cookie_value,
|
|
'-path' => $uri->path,
|
|
'-expires' => '+' . $::auth->{session_timeout} . 'm',
|
|
'-secure' => $::request->is_https);
|
|
$session_cookie = "$session_cookie; SameSite=strict";
|
|
}
|
|
}
|
|
|
|
my %cgi_params = ('-type' => $params{content_type});
|
|
$cgi_params{'-charset'} = $params{charset} if ($params{charset});
|
|
$cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
|
|
|
|
map { $cgi_params{'-' . $_} = $params{$_} if exists $params{$_} } qw(content_disposition content_length status);
|
|
|
|
my $output = $cgi->header(%cgi_params);
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
return $output;
|
|
}
|
|
|
|
sub header {
|
|
$::lxdebug->enter_sub;
|
|
|
|
my ($self, %params) = @_;
|
|
my @header;
|
|
|
|
$::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
|
|
|
|
if ($params{no_layout}) {
|
|
$::request->{layout} = SL::Layout::Dispatcher->new(style => 'none');
|
|
}
|
|
|
|
my $layout = $::request->{layout};
|
|
|
|
# standard css for all
|
|
# this should gradually move to the layouts that need it
|
|
$layout->use_stylesheet("$_.css") for qw(
|
|
common main menu list_accounts jquery.autocomplete
|
|
jquery.multiselect2side
|
|
ui-lightness/jquery-ui
|
|
jquery-ui.custom
|
|
tooltipster themes/tooltipster-light
|
|
);
|
|
|
|
$layout->use_javascript("$_.js") for (qw(
|
|
jquery jquery-ui jquery.cookie jquery.checkall jquery.download
|
|
jquery/jquery.form jquery/fixes namespace client_js
|
|
jquery/jquery.tooltipster.min
|
|
common part_selection
|
|
), "jquery/ui/i18n/jquery.ui.datepicker-$::myconfig{countrycode}");
|
|
|
|
$layout->use_javascript("$_.js") for @{ $params{use_javascripts} // [] };
|
|
|
|
$self->{favicon} ||= "favicon.ico";
|
|
$self->{titlebar} = join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->read_version if $self->{title} || !$self->{titlebar};
|
|
|
|
# build includes
|
|
if ($self->{refresh_url} || $self->{refresh_time}) {
|
|
my $refresh_time = $self->{refresh_time} || 3;
|
|
my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
|
|
push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
|
|
}
|
|
|
|
my $auto_reload_resources_param = $layout->auto_reload_resources_param;
|
|
|
|
push @header, map { qq|<link rel="stylesheet" href="${_}${auto_reload_resources_param}" type="text/css" title="Stylesheet">| } $layout->stylesheets;
|
|
push @header, "<style type='text/css'>\@page { size:landscape; }</style> " if $self->{landscape};
|
|
push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
|
|
push @header, map { qq|<script type="text/javascript" src="${_}${auto_reload_resources_param}"></script>| } $layout->javascripts;
|
|
push @header, '<meta name="viewport" content="width=device-width, initial-scale=1">';
|
|
push @header, $self->{javascript} if $self->{javascript};
|
|
push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
|
|
|
|
my %doctypes = (
|
|
strict => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">|,
|
|
transitional => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">|,
|
|
frameset => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">|,
|
|
html5 => qq|<!DOCTYPE html>|,
|
|
);
|
|
|
|
# output
|
|
print $self->create_http_response(content_type => 'text/html', charset => 'UTF-8');
|
|
print $doctypes{$params{doctype} || $::request->layout->html_dialect}, $/;
|
|
print <<EOT;
|
|
<html>
|
|
<head>
|
|
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
|
|
<title>$self->{titlebar}</title>
|
|
EOT
|
|
print " $_\n" for @header;
|
|
print <<EOT;
|
|
<meta name="robots" content="noindex,nofollow">
|
|
</head>
|
|
<body>
|
|
|
|
EOT
|
|
print $::request->{layout}->pre_content;
|
|
print $::request->{layout}->start_content;
|
|
|
|
$layout->header_done;
|
|
|
|
$::lxdebug->leave_sub;
|
|
}
|
|
|
|
sub footer {
|
|
return unless $::request->{layout}->need_footer;
|
|
|
|
print $::request->{layout}->end_content;
|
|
print $::request->{layout}->post_content;
|
|
|
|
if (my @inline_scripts = $::request->{layout}->javascripts_inline) {
|
|
print "<script type='text/javascript'>" . join("; ", @inline_scripts) . "</script>\n";
|
|
}
|
|
|
|
print <<EOL
|
|
</body>
|
|
</html>
|
|
EOL
|
|
}
|
|
|
|
sub ajax_response_header {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my ($self) = @_;
|
|
|
|
my $output = $::request->{cgi}->header('-charset' => 'UTF-8');
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
return $output;
|
|
}
|
|
|
|
sub redirect_header {
|
|
my $self = shift;
|
|
my $new_url = shift;
|
|
|
|
my $base_uri = $self->_get_request_uri;
|
|
my $new_uri = URI->new_abs($new_url, $base_uri);
|
|
|
|
die "Headers already sent" if $self->{header};
|
|
$self->{header} = 1;
|
|
|
|
return $::request->{cgi}->redirect($new_uri);
|
|
}
|
|
|
|
sub set_standard_title {
|
|
$::lxdebug->enter_sub;
|
|
my $self = shift;
|
|
|
|
$self->{titlebar} = "kivitendo " . $::locale->text('Version') . " " . $self->read_version;
|
|
$self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
|
|
$self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
|
|
|
|
$::lxdebug->leave_sub;
|
|
}
|
|
|
|
sub _prepare_html_template {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my ($self, $file, $additional_params) = @_;
|
|
my $language;
|
|
|
|
if (!%::myconfig || !$::myconfig{"countrycode"}) {
|
|
$language = $::lx_office_conf{system}->{language};
|
|
} else {
|
|
$language = $main::myconfig{"countrycode"};
|
|
}
|
|
$language = "de" unless ($language);
|
|
|
|
my $webpages_path = $::request->layout->webpages_path;
|
|
my $webpages_fallback = $::request->layout->webpages_fallback_path;
|
|
|
|
my @templates = first { -f } map { "${_}/${file}.html" } grep { defined } $webpages_path, $webpages_fallback;
|
|
|
|
if (@templates) {
|
|
$file = $templates[0];
|
|
} elsif (ref $file eq 'SCALAR') {
|
|
# file is a scalarref, use inline mode
|
|
} else {
|
|
my $info = "Web page template '${file}' not found.\n";
|
|
$::form->header;
|
|
print qq|<pre>$info</pre>|;
|
|
$::dispatcher->end_request;
|
|
}
|
|
|
|
$additional_params->{AUTH} = $::auth;
|
|
$additional_params->{INSTANCE_CONF} = $::instance_conf;
|
|
$additional_params->{LOCALE} = $::locale;
|
|
$additional_params->{LXCONFIG} = \%::lx_office_conf;
|
|
$additional_params->{LXDEBUG} = $::lxdebug;
|
|
$additional_params->{MYCONFIG} = \%::myconfig;
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
return $file;
|
|
}
|
|
|
|
sub parse_html_template {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my ($self, $file, $additional_params) = @_;
|
|
|
|
$additional_params ||= { };
|
|
|
|
my $real_file = $self->_prepare_html_template($file, $additional_params);
|
|
my $template = $self->template;
|
|
|
|
map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
|
|
|
|
my $output;
|
|
$template->process($real_file, $additional_params, \$output) || die $template->error;
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
return $output;
|
|
}
|
|
|
|
sub template { $::request->presenter->get_template }
|
|
|
|
sub show_generic_error {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my ($self, $error, %params) = @_;
|
|
|
|
if ($self->{__ERROR_HANDLER}) {
|
|
$self->{__ERROR_HANDLER}->($error);
|
|
$main::lxdebug->leave_sub();
|
|
return;
|
|
}
|
|
|
|
if ($::request->is_ajax) {
|
|
SL::ClientJS->new
|
|
->error($error)
|
|
->render(SL::Controller::Base->new);
|
|
$::dispatcher->end_request;
|
|
}
|
|
|
|
my $add_params = {
|
|
'title_error' => $params{title},
|
|
'label_error' => $error,
|
|
};
|
|
|
|
$self->{title} = $params{title} if $params{title};
|
|
|
|
for my $bar ($::request->layout->get('actionbar')) {
|
|
$bar->add(
|
|
action => [
|
|
t8('Back'),
|
|
call => [ 'kivi.history_back' ],
|
|
accesskey => 'enter',
|
|
],
|
|
);
|
|
}
|
|
|
|
$self->header();
|
|
print $self->parse_html_template("generic/error", $add_params);
|
|
|
|
print STDERR "Error: $error\n";
|
|
|
|
$main::lxdebug->leave_sub();
|
|
|
|
$::dispatcher->end_request;
|
|
}
|
|
|
|
sub show_generic_information {
|
|
$main::lxdebug->enter_sub();
|
|
|
|
my ($self, $text, $title) = @_;
|
|
|
|
my $add_params = {
|
|
'title_information' => $title,
|
|
'label_information' => $text,
|
|
};
|
|
|
|
$self->{title} = $title |