X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FForm.pm;h=7cbf60f8cd1be951dd86ed391f9f4c527663c939;hb=833f083eae2a4547c49f8f92a2fdca6ba4dfe5f4;hp=050614d5622879178350d3aae21cc04eecc4c2bf;hpb=5ae567349e69719bd1df8bf93166d2c47a18ee85;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index 050614d56..7cbf60f8c 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -1,4 +1,4 @@ -#==================================================================== +#========= =========================================================== # LX-Office ERP # Copyright (C) 2004 # Based on SQL-Ledger Version 2.1.9 @@ -37,8 +37,10 @@ package Form; +use Carp; use Data::Dumper; +use Carp; use CGI; use Cwd; use Encode; @@ -53,14 +55,20 @@ use SL::CVar; use SL::DB; use SL::DBConnect; use SL::DBUtils; +use SL::DB::Customer; +use SL::DB::Default; +use SL::DB::PaymentTerm; +use SL::DB::Vendor; use SL::DO; use SL::IC; use SL::IS; +use SL::Layout::Dispatcher; use SL::Locale; 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; @@ -84,6 +92,17 @@ sub disconnect_standard_dbh { undef $standard_dbh; } +sub read_version { + my ($self) = @_; + + open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file + my $version = ; + $version =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code. + close VERSION_FILE; + + return $version; +} + sub new { $main::lxdebug->enter_sub(); @@ -99,10 +118,7 @@ sub new { bless $self, $type; - open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file - $self->{version} = ; - close VERSION_FILE; - $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code. + $self->{version} = $self->read_version; $main::lxdebug->leave_sub(); @@ -136,9 +152,15 @@ sub _flatten_variables_rec { foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) { my $first_array_entry = 1; - foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) { - push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key); - $first_array_entry = 0; + 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 { + @result = ({ 'key' => $prefix . $key . ($first_array_entry ? '[+]' : '[]'), 'value' => $element }); } } } @@ -286,8 +308,7 @@ sub error { $self->show_generic_error($msg); } else { - print STDERR "Error: $msg\n"; - ::end_of_request(); + confess "Error: $msg\n"; } $main::lxdebug->leave_sub(); @@ -299,35 +320,13 @@ sub info { my ($self, $msg) = @_; if ($ENV{HTTP_USER_AGENT}) { - $msg =~ s/\n/
/g; - - if (!$self->{header}) { - $self->header; - print qq||; - } - - print qq| -

$msg

- - - - - |; + $self->header; + print $self->parse_html_template('generic/form_info', { message => $msg }); + } elsif ($self->{info_function}) { + &{ $self->{info_function} }($msg); } else { - - if ($self->{info_function}) { - &{ $self->{info_function} }($msg); - } else { - print "$msg\n"; - } + print "$msg\n"; } $main::lxdebug->leave_sub(); @@ -379,9 +378,10 @@ 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 = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http'; - my $port = $ENV{SERVER_PORT} || ''; + my $port = $ENV{SERVER_PORT}; $port = undef if (($scheme eq 'http' ) && ($port == 80)) || (($scheme eq 'https') && ($port == 443)); @@ -447,52 +447,37 @@ sub create_http_response { return $output; } -sub use_stylesheet { - my $self = shift; - - $self->{stylesheet} = [ $self->{stylesheet} ] unless ref $self->{stylesheet} eq 'ARRAY'; - $self->{stylesheet} = [ grep { -f } - map { m:^css/: ? $_ : "css/$_" } - grep { $_ } - (@{ $self->{stylesheet} }, @_) - ]; - - return @{ $self->{stylesheet} }; -} - -sub get_stylesheet_for_user { - my $css_path = 'css'; - if (my $user_style = $::myconfig{stylesheet}) { - $user_style =~ s/\.css$//; # nuke trailing .css, this is a remnand of pre 2.7.0 stylesheet handling - if (-d "$css_path/$user_style" && - -f "$css_path/$user_style/main.css") { - $css_path = "$css_path/$user_style"; - } else { - $css_path = "$css_path/lx-office-erp"; - } - } else { - $css_path = "$css_path/lx-office-erp"; - } - $::myconfig{css_path} = $css_path; # needed for menunew, FIXME: don't do this here - - return $css_path; -} - sub header { $::lxdebug->enter_sub; - # 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, %params) = @_; - 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 $css_path = $self->get_stylesheet_for_user; + 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( + main menu list_accounts jquery.autocomplete + jquery.multiselect2side + ui-lightness/jquery-ui + jquery-ui.custom + ); + + $layout->use_javascript("$_.js") for (qw( + jquery jquery-ui jquery.cookie jquery.checkall jquery.download + jquery/jquery.form jquery/fixes client_js + common part_selection switchmenuframe autocomplete_part + ), "jquery/ui/i18n/jquery.ui.datepicker-$::myconfig{countrycode}"); $self->{favicon} ||= "favicon.ico"; - $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title}; + $self->{titlebar} = join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title} || !$self->{titlebar}; # build includes if ($self->{refresh_url} || $self->{refresh_time}) { @@ -501,76 +486,68 @@ sub header { push @header, ""; } - push @header, map { qq|| } $self->use_stylesheet; + my $auto_reload_resources_param = $layout->auto_reload_resources_param; - push @header, "" if $self->{landscape}; - push @header, "" if -f $self->{favicon}; - push @header, map { qq|| } - qw(jquery common jscalendar/calendar jscalendar/lang/calendar-de jscalendar/calendar-setup part_selection jquery-ui jqModal switchmenuframe); - push @header, map { qq|| } - qw(main menu tabcontent list_accounts jquery.autocomplete jquery.multiselect2side frame_header/header ui-lightness/jquery-ui-1.8.12.custom); - push @header, map { qq|| } + push @header, map { qq|| } $layout->stylesheets; + push @header, " " if $self->{landscape}; + push @header, "" if -f $self->{favicon}; + push @header, map { qq|| } $layout->javascripts; + push @header, $self->{javascript} if $self->{javascript}; push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] }; - push @header, "" if $self->{fokus}; - push @header, sprintf "", - join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title}; - - # if there is a title, we put some JavaScript in to the page, wich writes a - # meaningful title-tag for our frameset. - my $title_hack = ''; - if ($self->{title}) { - $title_hack = qq| - |; - } my %doctypes = ( strict => qq||, transitional => qq||, frameset => qq||, + html5 => qq||, ); # output - print $self->create_http_response(content_type => 'text/html', charset => $db_charset); + print $self->create_http_response(content_type => 'text/html', charset => 'UTF-8'); print $doctypes{$params{doctype} || 'transitional'}, $/; print < - + $self->{titlebar} EOT print " $_\n" for @header; print < - - $params{extra_code} - $title_hack + 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 "\n"; + } + + print < + +EOL +} + sub ajax_response_header { $main::lxdebug->enter_sub(); my ($self) = @_; - my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET; - my $output = $::request->{cgi}->header('-charset' => $db_charset); + my $output = $::request->{cgi}->header('-charset' => 'UTF-8'); $main::lxdebug->leave_sub(); @@ -594,7 +571,7 @@ sub set_standard_title { $::lxdebug->enter_sub; my $self = shift; - $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}"; + $self->{titlebar} = "kivitendo " . $::locale->text('Version') . " $self->{version}"; $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name}; $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name}; @@ -617,8 +594,11 @@ sub _prepare_html_template { if (-f "templates/webpages/${file}.html") { $file = "templates/webpages/${file}.html"; + } 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|
$info
|; ::end_of_request(); } @@ -642,17 +622,7 @@ sub _prepare_html_template { map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig; } - $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset}; - $additional_params->{"conf_webdav"} = $::lx_office_conf{features}->{webdav}; - $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{features}->{vertreter}; - $additional_params->{"conf_show_best_before"} = $::lx_office_conf{features}->{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}; - $additional_params->{"conf_payments_changeable"} = $::lx_office_conf{features}->{payments_changeable}; - $additional_params->{"INSTANCE_CONF"} = $::instance_conf; + $additional_params->{INSTANCE_CONF} = $::instance_conf; if (my $debug_options = $::lx_office_conf{debug}{options}) { map { $additional_params->{'DEBUG_' . uc($_)} = $debug_options->{$_} } keys %$debug_options; @@ -694,6 +664,8 @@ sub init_template { return $self->template if $self->template; + # Force scripts/locales.pl to pick up the exception handling template. + # parse_html_template('generic/exception') return $self->template(Template->new({ 'INTERPOLATE' => 0, 'EVAL_PERL' => 0, @@ -703,6 +675,8 @@ sub init_template { 'INCLUDE_PATH' => '.:templates/webpages', 'COMPILE_EXT' => '.tcc', 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache', + 'ERROR' => 'templates/webpages/generic/exception.html', + 'ENCODING' => 'utf8', })) || die; } @@ -723,6 +697,13 @@ sub show_generic_error { return; } + if ($::request->is_ajax) { + SL::ClientJS->new + ->error($error) + ->render(SL::Controller::Base->new); + ::end_of_request(); + } + my $add_params = { 'title_error' => $params{title}, 'label_error' => $error, @@ -774,53 +755,6 @@ sub show_generic_information { ::end_of_request(); } -# write Trigger JavaScript-Code ($qty = quantity of Triggers) -# changed it to accept an arbitrary number of triggers - sschoeling -sub write_trigger { - $main::lxdebug->enter_sub(); - - my $self = shift; - my $myconfig = shift; - my $qty = shift; - - # set dateform for jsscript - # default - my %dateformats = ( - "dd.mm.yy" => "%d.%m.%Y", - "dd-mm-yy" => "%d-%m-%Y", - "dd/mm/yy" => "%d/%m/%Y", - "mm/dd/yy" => "%m/%d/%Y", - "mm-dd-yy" => "%m-%d-%Y", - "yyyy-mm-dd" => "%Y-%m-%d", - ); - - my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ? - $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y"; - - my @triggers; - while ($#_ >= 2) { - push @triggers, qq| - Calendar.setup( - { - inputField : "| . (shift) . qq|", - ifFormat :"$ifFormat", - align : "| . (shift) . qq|", - button : "| . (shift) . qq|" - } - ); - |; - } - my $jsscript = qq| - - |; - - $main::lxdebug->leave_sub(); - - return $jsscript; -} #end sub write_trigger - sub _store_redirect_info_in_session { my ($self) = @_; @@ -864,39 +798,30 @@ sub format_amount { $main::lxdebug->enter_sub(2); my ($self, $myconfig, $amount, $places, $dash) = @_; - $dash ||= ''; - - if ($amount eq "") { - $amount = 0; - } - - # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13 + $amount ||= 0; + $dash ||= ''; + my $neg = $amount < 0; + my $force_places = defined $places && $places >= 0; - my $neg = ($amount =~ s/^-//); - my $exp = ($amount =~ m/[e]/) ? 1 : 0; + $amount = $self->round_amount($amount, abs $places) if $force_places; + $amount = sprintf "%.*f", ($force_places ? $places : 10), abs $amount; # 6 is default for %fa - if (defined($places) && ($places ne '')) { - if (not $exp) { - if ($places < 0) { - $amount *= 1; - $places *= -1; + # before the sprintf amount was a number, afterwards it's a string. because of the dynamic nature of perl + # this is easy to confuse, so keep in mind: before this comment no s///, m//, concat or other strong ops on + # $amount. after this comment no +,-,*,/,abs. it will only introduce subtle bugs. - if ($amount =~ /\.(\d+)/) { - my $actual_places = length $1; - $places = $actual_places if $actual_places > $places; - } - } - } - $amount = $self->round_amount($amount, $places); - } + $amount =~ s/0*$// unless defined $places && $places == 0; # cull trailing 0s my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars - my @p = split(/\./, $amount); # split amount at decimal point - - $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters + my @p = split(/\./, $amount); # split amount at decimal point + $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters $amount = $p[0]; - $amount .= $d[0].($p[1]||'').(0 x ($places - length ($p[1]||''))) if ($places || $p[1] ne ''); + if ($places || $p[1]) { + $amount .= $d[0] + . ( $p[1] || '' ) + . (0 x (abs($places || 0) - length ($p[1]||''))); # pad the fraction + } $amount = do { ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) : @@ -904,7 +829,6 @@ sub format_amount { ($neg ? "-$amount" : "$amount" ) ; }; - $main::lxdebug->leave_sub(2); return $amount; } @@ -999,6 +923,11 @@ sub parse_amount { my ($self, $myconfig, $amount) = @_; + if (!defined($amount) || ($amount eq '')) { + $main::lxdebug->leave_sub(2); + return 0; + } + if ( ($myconfig->{numberformat} eq '1.000,00') || ($myconfig->{numberformat} eq '1000,00')) { $amount =~ s/\.//g; @@ -1019,24 +948,45 @@ sub parse_amount { } sub round_amount { - $main::lxdebug->enter_sub(2); - my ($self, $amount, $places) = @_; - my $round_amount; # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung ) - # Round amounts to eight places before rounding to the requested - # number of places. This gets rid of errors due to internal floating - # point representation. - $amount = $self->round_amount($amount, 8) if $places < 8; - $amount = $amount * (10**($places)); - $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places)); - - $main::lxdebug->leave_sub(2); - - return $round_amount; + # If you search for rounding in Perl, you'll likely get the first version of + # this algorithm: + # + # ($amount <=> 0) * int(abs($amount) * 10**$places) + .5) / 10**$places + # + # That doesn't work. It falls apart for certain values that are exactly 0.5 + # over the cutoff, because the internal IEEE754 representation is slightly + # below the cutoff. Perl makes matters worse in that it really, really tries to + # recognize exact values for presentation to you, even if they are not. + # + # Example: take the value 64.475 and round to 2 places. + # + # printf("%.20f\n", 64.475) gives you 64.47499999999999431566 + # + # Then 64.475 * 100 + 0.5 is 6447.99999999999909050530, and + # int(64.475 * 100 + 0.5) / 100 = 64.47 + # + # Trying to round with more precision first only shifts the problem to rarer + # cases, which nevertheless exist. + # + # Now we exploit the presentation rounding of Perl. Since it really tries hard + # to recognize integers, we double $amount, and let Perl give us a representation. + # If Perl recognizes it as a slightly too small integer, and rounds up to the + # next odd integer, we follow suit and treat the fraction as .5 or greater. + + my $sign = $amount <=> 0; + $amount = abs $amount; + + my $shift = 10 ** ($places); + my $shifted_and_double = $amount * $shift * 2; + my $rounding_bias = sprintf('%f', $shifted_and_double) % 2; + $amount = int($amount * $shift) + $rounding_bias; + $amount = $amount / $shift * $sign; + return $amount; } sub parse_template { @@ -1047,6 +997,7 @@ sub parse_template { local (*IN, *OUT); + my $defaults = SL::DB::Default->get; my $userspath = $::lx_office_conf{paths}->{userspath}; $self->{"cwd"} = getcwd(); @@ -1060,7 +1011,6 @@ sub parse_template { $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt'; } elsif ($self->{"format"} =~ /(postscript|pdf)/i) { - $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"}; $template_type = 'LaTeX'; $ext_for_format = 'pdf'; @@ -1093,17 +1043,26 @@ sub parse_template { file_name => $self->{IN}, form => $self, myconfig => $myconfig, - userspath => $userspath); + userspath => $userspath, + %{ $self->{TEMPLATE_DRIVER_OPTIONS} || {} }); # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be. - $self->{"notes"} = $self->{ $self->{"formname"} . "notes" }; + $self->{"notes"} = $self->{ $self->{"formname"} . "notes" } if exists $self->{ $self->{"formname"} . "notes" }; if (!$self->{employee_id}) { - map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns); + $self->{"employee_${_}"} = $myconfig->{$_} for qw(email tel fax name signature); + $self->{"employee_${_}"} = $defaults->$_ for qw(address businessnumber co_ustid company duns sepa_creditor_id taxnumber); } - map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid); - map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig }; + $self->{"myconfig_${_}"} = $myconfig->{$_} for grep { $_ ne 'dbpasswd' } keys %{ $myconfig }; + $self->{$_} = $defaults->$_ for qw(co_ustid); + $self->{"myconfig_${_}"} = $defaults->$_ for qw(address businessnumber co_ustid company duns sepa_creditor_id taxnumber); + $self->{AUTH} = $::auth; + $self->{INSTANCE_CONF} = $::instance_conf; + $self->{LOCALE} = $::locale; + $self->{LXCONFIG} = $::lx_office_conf; + $self->{LXDEBUG} = $::lxdebug; + $self->{MYCONFIG} = \%::myconfig; $self->{copies} = 1 if (($self->{copies} *= 1) <= 0); @@ -1113,19 +1072,18 @@ sub parse_template { $suffix = $self->{IN}; $suffix =~ s/.*\.//; ($temp_fh, $self->{tmpfile}) = File::Temp::tempfile( - 'lx-office-printXXXXXX', + 'kivitendo-printXXXXXX', SUFFIX => '.' . ($suffix || 'tex'), DIR => $userspath, - UNLINK => 1, + UNLINK => ($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})? 0 : 1, ); close $temp_fh; + (undef, undef, $self->{template_meta}{tmpfile}) = File::Spec->splitpath( $self->{tmpfile} ); - if ($template->uses_temp_file() || $self->{media} eq 'email') { - $out = $self->{OUT}; - $out_mode = $self->{OUT_MODE} || '>'; - $self->{OUT} = "$self->{tmpfile}"; - $self->{OUT_MODE} = '>'; - } + $out = $self->{OUT}; + $out_mode = $self->{OUT_MODE} || '>'; + $self->{OUT} = "$self->{tmpfile}"; + $self->{OUT_MODE} = '>'; my $result; my $command_formatter = sub { @@ -1147,9 +1105,13 @@ sub parse_template { } close OUT if $self->{OUT}; + # check only one flag (webdav_documents) + # therefore copy to webdav, even if we do not have the webdav feature enabled (just archive) + my $copy_to_webdav = $::instance_conf->get_webdav_documents && !$self->{preview} && $self->{tmpdir} && $self->{tmpfile} && $self->{type}; if ($self->{media} eq 'file') { copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file; + Common::copy_file_to_webdav_folder($self) if $copy_to_webdav; $self->cleanup; chdir("$self->{cwd}"); @@ -1158,93 +1120,95 @@ sub parse_template { return; } - if ($template->uses_temp_file() || $self->{media} eq 'email') { - - if ($self->{media} eq 'email') { + Common::copy_file_to_webdav_folder($self) if $copy_to_webdav; - my $mail = new Mailer; + if ($self->{media} eq 'email') { - map { $mail->{$_} = $self->{$_} } - qw(cc bcc subject message version format); - $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} = time() . '.' . $$ . '.'; - $myconfig->{signature} =~ s/\r//g; + my $mail = new Mailer; - # if we send html or plain text inline - if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) { - $mail->{contenttype} = "text/html"; - $mail->{message} =~ s/\r//g; - $mail->{message} =~ s/\n/
\n/g; - $myconfig->{signature} =~ s/\n/
\n/g; - $mail->{message} .= "
\n--
\n$myconfig->{signature}\n
"; + map { $mail->{$_} = $self->{$_} } + qw(cc bcc subject message version format); + $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email}; + $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|; + $mail->{fileid} = time() . '.' . $$ . '.'; + my $full_signature = $self->create_email_signature(); + $full_signature =~ s/\r//g; - open(IN, "<", $self->{tmpfile}) - or $self->error($self->cleanup . "$self->{tmpfile} : $!"); - $mail->{message} .= $_ while ; - close(IN); + # if we send html or plain text inline + if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) { + $mail->{contenttype} = "text/html"; + $mail->{message} =~ s/\r//g; + $mail->{message} =~ s/\n/
\n/g; + $full_signature =~ s/\n/
\n/g; + $mail->{message} .= $full_signature; - } else { - - if (!$self->{"do_not_attach"}) { - my $attachment_name = $self->{attachment_filename} || $self->{tmpfile}; - $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format); - $mail->{attachments} = [{ "filename" => $self->{tmpfile}, - "name" => $attachment_name }]; - } + open(IN, "<", $self->{tmpfile}) + or $self->error($self->cleanup . "$self->{tmpfile} : $!"); + $mail->{message} .= $_ while ; + close(IN); - $mail->{message} =~ s/\r//g; - $mail->{message} .= "\n-- \n$myconfig->{signature}"; + } else { + if (!$self->{"do_not_attach"}) { + my $attachment_name = $self->{attachment_filename} || $self->{tmpfile}; + $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format); + $mail->{attachments} = [{ "filename" => $self->{tmpfile}, + "name" => $attachment_name }]; } - my $err = $mail->send(); - $self->error($self->cleanup . "$err") if ($err); + $mail->{message} .= $full_signature; + } - } else { + my $err = $mail->send(); + $self->error($self->cleanup . "$err") if ($err); - $self->{OUT} = $out; - $self->{OUT_MODE} = $out_mode; + } else { - my $numbytes = (-s $self->{tmpfile}); - open(IN, "<", $self->{tmpfile}) - or $self->error($self->cleanup . "$self->{tmpfile} : $!"); - binmode IN; + $self->{OUT} = $out; + $self->{OUT_MODE} = $out_mode; - $self->{copies} = 1 unless $self->{media} eq 'printer'; + my $numbytes = (-s $self->{tmpfile}); + open(IN, "<", $self->{tmpfile}) + or $self->error($self->cleanup . "$self->{tmpfile} : $!"); + binmode IN; - chdir("$self->{cwd}"); - #print(STDERR "Kopien $self->{copies}\n"); - #print(STDERR "OUT $self->{OUT}\n"); - for my $i (1 .. $self->{copies}) { - if ($self->{OUT}) { - $self->{OUT} = $command_formatter->($self->{OUT_MODE}, $self->{OUT}); + $self->{copies} = 1 unless $self->{media} eq 'printer'; - open OUT, $self->{OUT_MODE}, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!"); - print OUT $_ while ; - close OUT; - seek IN, 0, 0; + chdir("$self->{cwd}"); + #print(STDERR "Kopien $self->{copies}\n"); + #print(STDERR "OUT $self->{OUT}\n"); + for my $i (1 .. $self->{copies}) { + if ($self->{OUT}) { + $self->{OUT} = $command_formatter->($self->{OUT_MODE}, $self->{OUT}); - } else { - $self->{attachment_filename} = ($self->{attachment_filename}) - ? $self->{attachment_filename} - : $self->generate_attachment_filename(); + open OUT, $self->{OUT_MODE}, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!"); + print OUT $_ while ; + close OUT; + seek IN, 0, 0; - # launch application - print qq|Content-Type: | . $template->get_mime_type() . qq| -Content-Disposition: attachment; filename="$self->{attachment_filename}" -Content-Length: $numbytes + } else { + my %headers = ('-type' => $template->get_mime_type, + '-connection' => 'close', + '-charset' => 'UTF-8'); + + $self->{attachment_filename} ||= $self->generate_attachment_filename; + + if ($self->{attachment_filename}) { + %headers = ( + %headers, + '-attachment' => $self->{attachment_filename}, + '-content-length' => $numbytes, + '-charset' => '', + ); + } -|; + print $::request->cgi->header(%headers); - $::locale->with_raw_io(\*STDOUT, sub { print while }); - } + $::locale->with_raw_io(\*STDOUT, sub { print while }); } - - close(IN); } + close(IN); } $self->cleanup; @@ -1423,22 +1387,13 @@ sub datetonum { # Database routines used throughout -sub _dbconnect_options { - my $self = shift; - my $options = { pg_enable_utf8 => $::locale->is_utf8, - @_ }; - - return $options; -} - sub dbconnect { $main::lxdebug->enter_sub(2); my ($self, $myconfig) = @_; # connect to database - my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options) - or $self->dberror; + my $dbh = SL::DBConnect->connect or $self->dberror; # set db options if ($myconfig->{dboptions}) { @@ -1456,8 +1411,7 @@ sub dbconnect_noauto { my ($self, $myconfig) = @_; # connect to database - my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0)) - or $self->dberror; + my $dbh = SL::DBConnect->connect(SL::DBConnect->get_connect_args(AutoCommit => 0)) or $self->dberror; # set db options if ($myconfig->{dboptions}) { @@ -1487,28 +1441,36 @@ sub get_standard_dbh { return $standard_dbh; } +sub set_standard_dbh { + my ($self, $dbh) = @_; + my $old_dbh = $standard_dbh; + $standard_dbh = $dbh; + + return $old_dbh; +} + sub date_closed { $main::lxdebug->enter_sub(); my ($self, $date, $myconfig) = @_; - my $dbh = $self->dbconnect($myconfig); + my $dbh = $self->get_standard_dbh; my $query = "SELECT 1 FROM defaults WHERE ? < closedto"; my $sth = prepare_execute_query($self, $dbh, $query, conv_date($date)); # Falls $date = '' - Fehlermeldung aus der Datenbank. Ich denke, - # es ist sicher ein conv_date vorher IMMER auszuführen. - # Testfälle ohne definiertes closedto: + # es ist sicher ein conv_date vorher IMMER auszuführen. + # Testfälle ohne definiertes closedto: # Leere Datumseingabe i.O. # SELECT 1 FROM defaults WHERE '' < closedto - # normale Zahlungsbuchung über Rechnungsmaske i.O. + # normale Zahlungsbuchung über Rechnungsmaske i.O. # SELECT 1 FROM defaults WHERE '10.05.2011' < closedto - # Testfälle mit definiertem closedto (30.04.2011): + # Testfälle mit definiertem closedto (30.04.2011): # Leere Datumseingabe i.O. # SELECT 1 FROM defaults WHERE '' < closedto - # normale Buchung im geschloßenem Zeitraum i.O. + # normale Buchung im geschloßenem Zeitraum i.O. # SELECT 1 FROM defaults WHERE '21.04.2011' < closedto - # Fehlermeldung: Es können keine Zahlungen für abgeschlossene Bücher gebucht werden! + # Fehlermeldung: Es können keine Zahlungen für abgeschlossene Bücher gebucht werden! # normale Buchung in aktiver Buchungsperiode i.O. # SELECT 1 FROM defaults WHERE '01.05.2011' < closedto @@ -1519,6 +1481,24 @@ sub date_closed { return $closed; } +# prevents bookings to the to far away future +sub date_max_future { + $main::lxdebug->enter_sub(); + + my ($self, $date, $myconfig) = @_; + my $dbh = $self->get_standard_dbh; + + my $query = "SELECT 1 FROM defaults WHERE ? - current_date > max_future_booking_interval"; + my $sth = prepare_execute_query($self, $dbh, $query, conv_date($date)); + + my ($max_future_booking_interval) = $sth->fetchrow_array; + + $main::lxdebug->leave_sub(); + + return $max_future_booking_interval; +} + + sub update_balance { $main::lxdebug->enter_sub(); @@ -1552,19 +1532,17 @@ sub update_exchangerate { $main::lxdebug->leave_sub(); return; } - $query = qq|SELECT curr FROM defaults|; - - my ($currency) = selectrow_query($self, $dbh, $query); - my ($defaultcurrency) = split m/:/, $currency; + $query = qq|SELECT name AS curr FROM currencies WHERE id=(SELECT currency_id FROM defaults)|; + my ($defaultcurrency) = selectrow_query($self, $dbh, $query); if ($curr eq $defaultcurrency) { $main::lxdebug->leave_sub(); return; } - $query = qq|SELECT e.curr FROM exchangerate e - WHERE e.curr = ? AND e.transdate = ? + $query = qq|SELECT e.currency_id FROM exchangerate e + WHERE e.currency_id = (SELECT cu.id FROM currencies cu WHERE cu.name=?) AND e.transdate = ? FOR UPDATE|; my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate); @@ -1590,12 +1568,12 @@ sub update_exchangerate { if ($sth->fetchrow_array) { $query = qq|UPDATE exchangerate SET $set - WHERE curr = ? + WHERE currency_id = (SELECT id FROM currencies WHERE name = ?) AND transdate = ?|; } else { - $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate) - VALUES (?, $buy, $sell, ?)|; + $query = qq|INSERT INTO exchangerate (currency_id, buy, sell, transdate) + VALUES ((SELECT id FROM currencies WHERE name = ?), $buy, $sell, ?)|; } $sth->finish; do_query($self, $dbh, $query, $curr, $transdate); @@ -1630,23 +1608,22 @@ sub get_exchangerate { my ($self, $dbh, $curr, $transdate, $fld) = @_; my ($query); - unless ($transdate) { + unless ($transdate && $curr) { $main::lxdebug->leave_sub(); return 1; } - $query = qq|SELECT curr FROM defaults|; + $query = qq|SELECT name AS curr FROM currencies WHERE id = (SELECT currency_id FROM defaults)|; - my ($currency) = selectrow_query($self, $dbh, $query); - my ($defaultcurrency) = split m/:/, $currency; + my ($defaultcurrency) = selectrow_query($self, $dbh, $query); - if ($currency eq $defaultcurrency) { + if ($curr eq $defaultcurrency) { $main::lxdebug->leave_sub(); return 1; } $query = qq|SELECT e.$fld FROM exchangerate e - WHERE e.curr = ? AND e.transdate = ?|; + WHERE e.currency_id = (SELECT id FROM currencies WHERE name = ?) AND e.transdate = ?|; my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate); @@ -1679,7 +1656,7 @@ sub check_exchangerate { my $dbh = $self->get_standard_dbh($myconfig); my $query = qq|SELECT e.$fld FROM exchangerate e - WHERE e.curr = ? AND e.transdate = ?|; + WHERE e.currency_id = (SELECT id FROM currencies WHERE name = ?) AND e.transdate = ?|; my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate); @@ -1695,10 +1672,8 @@ sub get_all_currencies { my $myconfig = shift || \%::myconfig; my $dbh = $self->get_standard_dbh($myconfig); - my $query = qq|SELECT curr FROM defaults|; - - my ($curr) = selectrow_query($self, $dbh, $query); - my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr; + my $query = qq|SELECT name FROM currencies|; + my @currencies = map { $_->{name} } selectall_hashref_query($self, $dbh, $query); $main::lxdebug->leave_sub(); @@ -1709,11 +1684,14 @@ sub get_default_currency { $main::lxdebug->enter_sub(); my ($self, $myconfig) = @_; - my @currencies = $self->get_all_currencies($myconfig); + my $dbh = $self->get_standard_dbh($myconfig); + my $query = qq|SELECT name AS curr FROM currencies WHERE id = (SELECT currency_id FROM defaults)|; + + my ($defaultcurrency) = selectrow_query($self, $dbh, $query); $main::lxdebug->leave_sub(); - return $currencies[0]; + return $defaultcurrency; } sub set_payment_options { @@ -1763,10 +1741,9 @@ sub set_payment_options { $amounts{invtotal} = $self->{invtotal}; $amounts{total} = $self->{total}; } - $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto}; - map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts; + $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto}; $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto}; $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto}); $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto}); @@ -1961,6 +1938,7 @@ sub get_employee_data { my $self = shift; my %params = @_; + my $defaults = SL::DB::Default->get; Common::check_params(\%params, qw(prefix)); Common::check_params_x(\%params, qw(id)); @@ -1973,16 +1951,24 @@ sub get_employee_data { my $myconfig = \%main::myconfig; my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig); - my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id})); + my ($login, $deleted) = selectrow_query($self, $dbh, qq|SELECT login,deleted FROM employee WHERE id = ?|, conv_i($params{id})); if ($login) { - my $user = User->new(login => $login); - map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel); - + # login already fetched and still the same client (mandant) | same for both cases (delete|!delete) $self->{$params{prefix} . '_login'} = $login; - $self->{$params{prefix} . '_name'} ||= $login; - } + $self->{$params{prefix} . "_${_}"} = $defaults->$_ for qw(address businessnumber co_ustid company duns taxnumber); + if (!$deleted) { + # get employee data from auth.user_config + my $user = User->new(login => $login); + $self->{$params{prefix} . "_${_}"} = $user->{$_} for qw(email fax name signature tel); + } else { + # get saved employee data from employee + my $employee = SL::DB::Manager::Employee->find_by(id => conv_i($params{id})); + $self->{$params{prefix} . "_${_}"} = $employee->{"deleted_$_"} for qw(email fax signature tel); + $self->{$params{prefix} . "_name"} = $employee->name; + } + } $main::lxdebug->leave_sub(); } @@ -1991,11 +1977,12 @@ sub get_duedate { my ($self, $myconfig, $reference_date) = @_; - $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date'; - - my $dbh = $self->get_standard_dbh($myconfig); - my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|; - my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id}); + my $terms = $self->{payment_id} ? SL::DB::PaymentTerm->new(id => $self->{payment_id}) ->load + : $self->{customer_id} ? SL::DB::Customer ->new(id => $self->{customer_id})->load->payment + : $self->{vendor_id} ? SL::DB::Vendor ->new(id => $self->{vendor_id}) ->load->payment + : $self->{invdate} ? undef # no payment terms, therefore invdate == duedate + : croak("Missing field in \$::form: payment_id, customer_id, vendor_id or invdate"); + my $duedate = $terms ? $terms->calc_date(reference_date => $reference_date)->to_kivitendo : undef; $main::lxdebug->leave_sub(); @@ -2146,10 +2133,10 @@ sub _get_taxcharts { if (ref $params eq 'HASH') { $key = $params->{key} if ($params->{key}); if ($params->{module} eq 'AR') { - push @where, 'taxkey NOT IN (8, 9, 18, 19)'; + push @where, 'chart_categories ~ \'[ACILQ]\''; } elsif ($params->{module} eq 'AP') { - push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)'; + push @where, 'chart_categories ~ \'[ACELQ]\''; } } elsif ($params) { @@ -2158,7 +2145,7 @@ sub _get_taxcharts { my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : ''; - my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|; + my $query = qq|SELECT * FROM tax $where ORDER BY taxkey, rate|; $self->{$key} = selectall_hashref_query($self, $dbh, $query); @@ -2171,8 +2158,10 @@ sub _get_taxzones { my ($self, $dbh, $key) = @_; $key = "all_taxzones" unless ($key); + my $tzfilter = ""; + $tzfilter = "WHERE obsolete is FALSE" if $key eq 'ALL_ACTIVE_TAXZONES'; - my $query = qq|SELECT * FROM tax_zones ORDER BY id|; + my $query = qq|SELECT * FROM tax_zones $tzfilter ORDER BY sortkey|; $self->{$key} = selectall_hashref_query($self, $dbh, $query); @@ -2182,10 +2171,22 @@ sub _get_taxzones { sub _get_employees { $main::lxdebug->enter_sub(); - my ($self, $dbh, $default_key, $key) = @_; + my ($self, $dbh, $params) = @_; + + my $deleted = 0; + + my $key; + if (ref $params eq 'HASH') { + $key = $params->{key}; + $deleted = $params->{deleted}; - $key = $default_key unless ($key); - $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|); + } else { + $key = $params; + } + + $key ||= "all_employees"; + my $filter = $deleted ? '' : 'WHERE NOT COALESCE(deleted, FALSE)'; + $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee $filter ORDER BY lower(name)|); $main::lxdebug->leave_sub(); } @@ -2243,9 +2244,7 @@ $main::lxdebug->enter_sub(); $key = "all_currencies" unless ($key); - my $query = qq|SELECT curr AS currency FROM defaults|; - - $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})]; + $self->{$key} = [$self->get_all_currencies()]; $main::lxdebug->leave_sub(); } @@ -2389,8 +2388,13 @@ sub get_lists { my $dbh = $self->get_standard_dbh(\%main::myconfig); my ($sth, $query, $ref); - my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor"; - my $vc_id = $self->{"${vc}_id"}; + my ($vc, $vc_id); + if ($params{contacts} || $params{shipto}) { + $vc = 'customer' if $self->{"vc"} eq "customer"; + $vc = 'vendor' if $self->{"vc"} eq "vendor"; + die "invalid use of get_lists, need 'vc'"; + $vc_id = $self->{"${vc}_id"}; + } if ($params{"contacts"}) { $self->_get_contacts($dbh, $vc_id, $params{"contacts"}); @@ -2427,7 +2431,7 @@ sub get_lists { } if ($params{"employees"}) { - $self->_get_employees($dbh, "all_employees", $params{"employees"}); + $self->_get_employees($dbh, $params{"employees"}); } if ($params{"salesmen"}) { @@ -2546,14 +2550,14 @@ sub all_vc { $table = $table eq "customer" ? "customer" : "vendor"; # build selection list - # Hotfix für Bug 1837 - Besser wäre es alte Buchungsbelege + # Hotfix für Bug 1837 - Besser wäre es alte Buchungsbelege # OHNE Auswahlliste (reines Textfeld) zu laden. Hilft aber auch - # nicht für veränderbare Belege (oe, do, ...) - my $obsolete = "WHERE NOT obsolete" unless $self->{id}; + # nicht für veränderbare Belege (oe, do, ...) + my $obsolete = $self->{id} ? '' : "WHERE NOT obsolete"; my $query = qq|SELECT count(*) FROM $table $obsolete|; my ($count) = selectrow_query($self, $dbh, $query); - if ($count < $myconfig->{vclimit}) { + if ($count <= $myconfig->{vclimit}) { $query = qq|SELECT id, name, salesman_id FROM $table $obsolete ORDER BY name|; @@ -2566,7 +2570,8 @@ sub all_vc { # setup sales contacts $query = qq|SELECT e.id, e.name FROM employee e - WHERE (e.sales = '1') AND (NOT e.id = ?)|; + WHERE (e.sales = '1') AND (NOT e.id = ?) + ORDER BY name|; $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id}); # this is for self @@ -2574,11 +2579,6 @@ sub all_vc { { id => $self->{employee_id}, name => $self->{employee} }); - # sort the whole thing - @{ $self->{all_employees} } = - sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} }; - - # prepare query for departments $query = qq|SELECT id, description FROM department @@ -2753,14 +2753,17 @@ sub create_links { $self->{TAX} = selectall_hashref_query($self, $dbh, $query); } + my $extra_columns = ''; + $extra_columns .= 'a.direct_debit, ' if ($module eq 'AR') || ($module eq 'AP'); + if ($self->{id}) { $query = qq|SELECT a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid, - a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes, + a.duedate, a.ordnumber, a.taxincluded, (SELECT cu.name FROM currencies cu WHERE cu.id=a.currency_id) AS currency, a.notes, a.intnotes, a.department_id, a.amount AS oldinvtotal, a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type, - a.globalproject_id, + a.globalproject_id, ${extra_columns} c.name AS $table, d.description AS department, e.name AS employee @@ -2775,9 +2778,6 @@ sub create_links { $self->{$key} = $ref->{$key}; } - # remove any trailing whitespace - $self->{currency} =~ s/\s*$//; - my $transdate = "current_date"; if ($self->{transdate}) { $transdate = $dbh->quote($self->{transdate}); @@ -2826,14 +2826,7 @@ sub create_links { FROM acc_trans a LEFT JOIN chart c ON (c.id = a.chart_id) LEFT JOIN project p ON (p.id = a.project_id) - LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk - WHERE (tk.taxkey_id=a.taxkey) AND - ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey) - THEN tk.chart_id = a.chart_id - ELSE 1 = 1 - END) - OR (c.link='%tax%')) AND - (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1)) + LEFT JOIN tax t ON (t.id= a.tax_id) WHERE a.trans_id = ? AND a.fx_transaction = '0' ORDER BY a.acc_trans_id, a.transdate|; @@ -2861,9 +2854,11 @@ sub create_links { } $sth->finish; + #check das: $query = qq|SELECT - d.curr AS currencies, d.closedto, d.revtrans, + d.closedto, d.revtrans, + (SELECT cu.name FROM currencies cu WHERE cu.id=d.currency_id) AS defaultcurrency, (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno, (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno FROM defaults d|; @@ -2875,7 +2870,8 @@ sub create_links { # get date $query = qq|SELECT - current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans, + current_date AS transdate, d.closedto, d.revtrans, + (SELECT cu.name FROM currencies cu WHERE cu.id=d.currency_id) AS defaultcurrency, (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno, (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno FROM defaults d|; @@ -2885,7 +2881,7 @@ sub create_links { if ($self->{"$self->{vc}_id"}) { # only setup currency - ($self->{currency}) = split(/:/, $self->{currencies}) if !$self->{currency}; + ($self->{currency}) = $self->{defaultcurrency} if !$self->{currency}; } else { @@ -2910,19 +2906,17 @@ sub lastname_used { my ($arap, $where); $table = $table eq "customer" ? "customer" : "vendor"; - my %column_map = ("a.curr" => "currency", - "a.${table}_id" => "${table}_id", + my %column_map = ("a.${table}_id" => "${table}_id", "a.department_id" => "department_id", "d.description" => "department", "ct.name" => $table, - "ct.curr" => "cv_curr", + "cu.name" => "currency", "current_date + ct.terms" => "duedate", ); if ($self->{type} =~ /delivery_order/) { $arap = 'delivery_orders'; - delete $column_map{"a.curr"}; - delete $column_map{"ct.curr"}; + delete $column_map{"cu.currency"}; } elsif ($self->{type} =~ /_order/) { $arap = 'oe'; @@ -2951,18 +2945,12 @@ sub lastname_used { FROM $arap a LEFT JOIN $table ct ON (a.${table}_id = ct.id) LEFT JOIN department d ON (a.department_id = d.id) + LEFT JOIN currencies cu ON (cu.id=ct.currency_id) WHERE a.id = ?|; my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id); map { $self->{$_} = $ref->{$_} } values %column_map; - # remove any trailing whitespace - $self->{currency} =~ s/\s*$// if $self->{currency}; - $self->{cv_curr} =~ s/\s*$// if $self->{cv_curr}; - - # if customer/vendor currency is set use this - $self->{currency} = $self->{cv_curr} if $self->{cv_curr}; - $main::lxdebug->leave_sub(); } @@ -3224,88 +3212,6 @@ sub get_history { return 0; } -sub update_defaults { - $main::lxdebug->enter_sub(); - - my ($self, $myconfig, $fld, $provided_dbh) = @_; - - my $dbh; - if ($provided_dbh) { - $dbh = $provided_dbh; - } else { - $dbh = $self->dbconnect_noauto($myconfig); - } - my $query = qq|SELECT $fld FROM defaults FOR UPDATE|; - my $sth = $dbh->prepare($query); - - $sth->execute || $self->dberror($query); - my ($var) = $sth->fetchrow_array; - $sth->finish; - - if ($var =~ m/\d+$/) { - my $new_var = (substr $var, $-[0]) * 1 + 1; - my $len_diff = length($var) - $-[0] - length($new_var); - $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var; - - } else { - $var = $var . '1'; - } - - $query = qq|UPDATE defaults SET $fld = ?|; - do_query($self, $dbh, $query, $var); - - if (!$provided_dbh) { - $dbh->commit; - $dbh->disconnect; - } - - $main::lxdebug->leave_sub(); - - return $var; -} - -sub update_business { - $main::lxdebug->enter_sub(); - - my ($self, $myconfig, $business_id, $provided_dbh) = @_; - - my $dbh; - if ($provided_dbh) { - $dbh = $provided_dbh; - } else { - $dbh = $self->dbconnect_noauto($myconfig); - } - my $query = - qq|SELECT customernumberinit FROM business - WHERE id = ? FOR UPDATE|; - my ($var) = selectrow_query($self, $dbh, $query, $business_id); - - return undef unless $var; - - if ($var =~ m/\d+$/) { - my $new_var = (substr $var, $-[0]) * 1 + 1; - my $len_diff = length($var) - $-[0] - length($new_var); - $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var; - - } else { - $var = $var . '1'; - } - - $query = qq|UPDATE business - SET customernumberinit = ? - WHERE id = ?|; - do_query($self, $dbh, $query, $var, $business_id); - - if (!$provided_dbh) { - $dbh->commit; - $dbh->disconnect; - } - - $main::lxdebug->leave_sub(); - - return $var; -} - sub get_partsgroup { $main::lxdebug->enter_sub(); @@ -3439,17 +3345,30 @@ sub restore_vars { sub prepare_for_printing { my ($self) = @_; - $self->{templates} ||= $::myconfig{templates}; + my $defaults = SL::DB::Default->get; + + $self->{templates} ||= $defaults->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}; + # Several fields that used to reside in %::myconfig (stored in + # auth.user_config) are now stored in defaults. Copy them over for + # compatibility. + $self->{$_} = $defaults->$_ for qw(company address taxnumber co_ustid duns sepa_creditor_id); + + $self->{"myconfig_${_}"} = $::myconfig{$_} for grep { $_ ne 'dbpasswd' } keys %::myconfig; + + if (!$self->{employee_id}) { + $self->{"employee_${_}"} = $::myconfig{$_} for qw(email tel fax name signature); + $self->{"employee_${_}"} = $defaults->$_ for qw(address businessnumber co_ustid company duns sepa_creditor_id taxnumber); + } + + # Load shipping address from database if shipto_id is set. + if ($self->{shipto_id}) { + my $shipto = SL::DB::Shipto->new(shipto_id => $self->{shipto_id})->load; + $self->{$_} = $shipto->$_ for grep { m{^shipto} } map { $_->name } @{ $shipto->meta->columns }; } my $language = $self->{language} ? '_' . $self->{language} : ''; @@ -3457,17 +3376,21 @@ sub prepare_for_printing { 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; } + $output_dateformat ||= $::myconfig{dateformat}; + $output_numberformat ||= $::myconfig{numberformat}; + $output_longdates //= 1; + + $self->{myconfig_output_dateformat} = $output_dateformat // $::myconfig{dateformat}; + $self->{myconfig_output_longdates} = $output_longdates // 1; + $self->{myconfig_output_numberformat} = $output_numberformat // $::myconfig{numberformat}; + # Retrieve accounts for tax calculation. IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount}); if ($self->{type} =~ /_delivery_order$/) { - DO->order_details(); + DO->order_details(\%::myconfig, $self); } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) { OE->order_details(\%::myconfig, $self); } else { @@ -3491,7 +3414,7 @@ sub prepare_for_printing { } my $printer_code = $self->{printer_code} ? '_' . $self->{printer_code} : ''; - my $email_extension = -f "$::myconfig{templates}/$self->{formname}_email${language}.${extension}" ? '_email' : ''; + my $email_extension = $self->{media} eq 'email' && -f ($defaults->templates . "/$self->{formname}_email${language}.${extension}") ? '_email' : ''; $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}"; # Format dates. @@ -3516,6 +3439,16 @@ sub prepare_for_printing { $self->reformat_numbers($output_numberformat, $precision, @{ $field_list }); } + $self->{template_meta} = { + formname => $self->{formname}, + language => SL::DB::Manager::Language->find_by_or_create(id => $self->{language_id} || undef), + format => $self->{format}, + media => $self->{media}, + extension => $extension, + printer => SL::DB::Manager::Printer->find_by_or_create(id => $self->{printer_id} || undef), + today => DateTime->today, + }; + return $self; } @@ -3593,6 +3526,44 @@ sub reformat_numbers { $::myconfig{numberformat} = $saved_numberformat; } +sub create_email_signature { + + my $client_signature = $::instance_conf->get_signature; + my $user_signature = $::myconfig{signature}; + + my $signature = ''; + if ( $client_signature or $user_signature ) { + $signature = "\n\n-- \n"; + $signature .= $user_signature . "\n" if $user_signature; + $signature .= $client_signature . "\n" if $client_signature; + }; + return $signature; + +}; + +sub layout { + my ($self) = @_; + $::lxdebug->enter_sub; + + my %style_to_script_map = ( + v3 => 'v3', + neu => 'new', + ); + + my $menu_script = $style_to_script_map{$::myconfig{menustyle}} || ''; + + package main; + require "bin/mozilla/menu$menu_script.pl"; + package Form; + require SL::Controller::FrameHeader; + + + my $layout = SL::Controller::FrameHeader->new->action_header . ::render(); + + $::lxdebug->leave_sub; + return $layout; +} + 1; __END__ @@ -3603,7 +3574,7 @@ SL::Form.pm - main data object. =head1 SYNOPSIS -This is the main data object of Lx-Office. +This is the main data object of kivitendo. Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points. Points of interest for a beginner are: @@ -3612,23 +3583,11 @@ Points of interest for a beginner are: =head1 SPECIAL FUNCTIONS -=head2 C PARAMS - -PARAMS (not named): - \%config, - config hashref - $business_id, - business id - $dbh - optional database handle - -handles business (thats customer/vendor types) sequences. - -special behaviour for empty strings in customerinitnumber field: -will in this case not increase the value, and return undef. - =head2 C $url Generates a HTTP redirection header for the new C<$url>. Constructs an absolute URL including scheme, host name and port. If C<$url> is a -relative URL then it is considered relative to Lx-Office base URL. +relative URL then it is considered relative to kivitendo base URL. This function Cs if headers have already been created with C<$::form-Eheader>.