X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FForm.pm;h=c92d267a5c6d76909bd800b36d736d2fada6b998;hb=6ceacc682f9c760e654f5aacde9b8480760d8b36;hp=da4684358df7ff2ce230743e7ee99cb0bfa1c9ca;hpb=9096031d4534a25bbd0573c23af1ce24f5ca5ba4;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index da4684358..c92d267a5 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -42,11 +42,11 @@ use Carp; use Data::Dumper; use Carp; -use Config; use CGI; use Cwd; use Encode; use File::Copy; +use File::Temp (); use IO::File; use Math::BigInt; use POSIX qw(strftime); @@ -87,6 +87,7 @@ 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; @@ -115,11 +116,6 @@ sub new { return $self; } -sub read_cgi_input { - my ($self) = @_; - SL::Request::read_cgi_input($self); -} - sub _flatten_variables_rec { $main::lxdebug->enter_sub(2); @@ -249,7 +245,7 @@ sub hide_form { sub throw_on_error { my ($self, $code) = @_; - local $self->{__ERROR_HANDLER} = sub { die SL::X::FormError->new($_[0]) }; + local $self->{__ERROR_HANDLER} = sub { SL::X::FormError->throw(error => $_[0]) }; $code->(); } @@ -311,9 +307,9 @@ sub numtextrows { sub dberror { my ($self, $msg) = @_; - die SL::X::DBError->new( - msg => $msg, - error => $DBI::errstr, + SL::X::DBError->throw( + msg => $msg, + db_error => $DBI::errstr, ); } @@ -386,10 +382,11 @@ sub create_http_response { 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, - '-secure' => $::request->is_https); + $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); } } @@ -397,7 +394,7 @@ sub create_http_response { $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); + map { $cgi_params{'-' . $_} = $params{$_} if exists $params{$_} } qw(content_disposition content_length status); my $output = $cgi->header(%cgi_params); @@ -703,44 +700,10 @@ sub sort_columns { return @columns; } # -sub format_amount { - $main::lxdebug->enter_sub(2); +sub format_amount { my ($self, $myconfig, $amount, $places, $dash) = @_; - $amount ||= 0; - $dash ||= ''; - my $neg = $amount < 0; - my $force_places = defined $places && $places >= 0; - - $amount = $self->round_amount($amount, abs $places) if $force_places; - $neg = 0 if $amount == 0; # don't show negative zero - $amount = sprintf "%.*f", ($force_places ? $places : 10), abs $amount; # 6 is default for %fa - - # 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. - - $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 - $amount = $p[0]; - if ($places || $p[1]) { - $amount .= $d[0] - . ( $p[1] || '' ) - . (0 x max(abs($places || 0) - length ($p[1]||''), 0)); # pad the fraction - } - - $amount = do { - ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) : - ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) : - ($neg ? "-$amount" : "$amount" ) ; - }; - - $main::lxdebug->leave_sub(2); - return $amount; + SL::Helper::Number::_format_number($amount, $places, %$myconfig, dash => $dash); } sub format_amount_units { @@ -829,82 +792,11 @@ sub format_string { # sub parse_amount { - $main::lxdebug->enter_sub(2); - 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; - $amount =~ s/,/\./g; - } - - if ($myconfig->{numberformat} eq "1'000.00") { - $amount =~ s/\'//g; - } - - $amount =~ s/,//g; - - $main::lxdebug->leave_sub(2); - - # Make sure no code wich is not a math expression ends up in eval(). - return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x; - - # Prevent numbers from being parsed as octals; - $amount =~ s{ (?get_precision || 0.01; - return $self->round_amount( $self->round_amount($amount / $precision, 0) * $precision, $places); - } - - # We use Perl's knowledge of string representation for - # rounding. First, convert the floating point number to a string - # with a high number of places. Then split the string on the decimal - # sign and use integer calculation for rounding the decimal places - # part. If an overflow occurs then apply that overflow to the part - # before the decimal sign as well using integer arithmetic again. - - my $int_amount = int(abs $amount); - my $str_places = max(min(10, 16 - length("$int_amount") - $places), $places); - my $amount_str = sprintf '%.*f', $places + $str_places, abs($amount); - - return $amount unless $amount_str =~ m{^(\d+)\.(\d+)$}; - - my ($pre, $post) = ($1, $2); - my $decimals = '1' . substr($post, 0, $places); - - my $propagation_limit = $Config{i32size} == 4 ? 7 : 18; - my $add_for_rounding = substr($post, $places, 1) >= 5 ? 1 : 0; - - if ($places > $propagation_limit) { - $decimals = Math::BigInt->new($decimals)->badd($add_for_rounding); - $pre = Math::BigInt->new($decimals)->badd(1) if substr($decimals, 0, 1) eq '2'; - - } else { - $decimals += $add_for_rounding; - $pre += 1 if substr($decimals, 0, 1) eq '2'; - } - - $amount = ("${pre}." . substr($decimals, 1)) * ($amount <=> 0); - - return $amount; -} +sub round_amount { shift; goto &SL::Helper::Number::_round_number; } sub parse_template { $main::lxdebug->enter_sub(); @@ -914,11 +806,18 @@ sub parse_template { local (*IN, *OUT); - my $defaults = SL::DB::Default->get; - my $userspath = $::lx_office_conf{paths}->{userspath}; + my $defaults = SL::DB::Default->get; + + my $keep_temp_files = $::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files}; + $self->{cwd} = getcwd(); + my $temp_dir = File::Temp->newdir( + "kivitendo-print-XXXXXX", + DIR => $self->{cwd} . "/" . $::lx_office_conf{paths}->{userspath}, + CLEANUP => !$keep_temp_files, + ); - $self->{"cwd"} = getcwd(); - $self->{"tmpdir"} = $self->{cwd} . "/${userspath}"; + my $userspath = File::Spec->abs2rel($temp_dir->dirname); + $self->{tmpdir} = $temp_dir->dirname; my $ext_for_format; @@ -935,13 +834,6 @@ sub parse_template { $template_type = 'HTML'; $ext_for_format = 'html'; - } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) { - $template_type = 'XML'; - $ext_for_format = 'xml'; - - } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) { - $template_type = 'XML'; - } elsif ( $self->{"format"} =~ /excel/i ) { $template_type = 'Excel'; $ext_for_format = 'xls'; @@ -985,7 +877,6 @@ sub parse_template { # OUT is used for the media, screen, printer, email # for postscript we store a copy in a temporary file - my $keep_temp_files = $::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files}; my ($temp_fh, $suffix); $suffix = $self->{IN}; @@ -1035,7 +926,14 @@ sub parse_template { } 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; + + if ($copy_to_webdav) { + if (my $error = Common::copy_file_to_webdav_folder($self)) { + chdir("$self->{cwd}"); + $self->error($error); + } + } + if (!$self->{preview} && $self->doc_storage_enabled) { $self->{attachment_filename} ||= $self->generate_attachment_filename; @@ -1049,7 +947,12 @@ sub parse_template { return; } - Common::copy_file_to_webdav_folder($self) if $copy_to_webdav; + if ($copy_to_webdav) { + if (my $error = Common::copy_file_to_webdav_folder($self)) { + chdir("$self->{cwd}"); + $self->error($error); + } + } if ( !$self->{preview} && $ext_for_format eq 'pdf' && $self->doc_storage_enabled) { $self->{attachment_filename} ||= $self->generate_attachment_filename; @@ -1112,8 +1015,8 @@ sub send_email { if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) { $mail->{content_type} = "text/html"; $mail->{message} =~ s/\r//g; - $mail->{message} =~ s/\n/
\n/g; - $full_signature =~ s/\n/
\n/g; + $mail->{message} =~ s{\n}{
\n}g; + $full_signature =~ s{\n}{
\n}g; $mail->{message} .= $full_signature; open(IN, "<", $self->{tmpfile}) @@ -1123,7 +1026,7 @@ sub send_email { } elsif (($self->{attachment_policy} // '') ne 'no_file') { my $attachment_name = $self->{attachment_filename} || $self->{tmpfile}; - $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format); + $attachment_name =~ s{\.(.+?)$}{.${ext_for_format}} if ($ext_for_format); if (($self->{attachment_policy} // '') eq 'old_file') { my ( $attfile ) = SL::File->get_all(object_id => $self->{id}, @@ -1263,6 +1166,20 @@ sub get_formname_translation { return $formname_translations{$formname}; } +sub get_cusordnumber_translation { + $main::lxdebug->enter_sub(); + my ($self, $formname) = @_; + + $formname ||= $self->{formname}; + + $self->{recipient_locale} ||= Locale->lang_to_locale($self->{language}); + local $::locale = Locale->new($self->{recipient_locale}); + + + $main::lxdebug->leave_sub(); + return $main::locale->text('Your Order'); +} + sub get_number_prefix_for_type { $main::lxdebug->enter_sub(); my ($self) = @_; @@ -1338,13 +1255,17 @@ sub generate_email_subject { $subject .= " " . $self->{"${prefix}number"} } + if ($self->{cusordnumber}) { + $subject = $self->get_cusordnumber_translation() . ' ' . $self->{cusordnumber} . ' / ' . $subject; + } + $main::lxdebug->leave_sub(); return $subject; } sub generate_email_body { $main::lxdebug->enter_sub(); - my ($self) = @_; + my ($self, %params) = @_; # simple german and english will work grammatically (most european languages as well) # Dear Mr Alan Greenspan: # Sehr geehrte Frau Meyer, @@ -1352,7 +1273,7 @@ sub generate_email_body { # Gentile Signora Ferrari, my $body = ''; - if ($self->{cp_id}) { + if ($self->{cp_id} && !$params{record_email}) { my $givenname = SL::DB::Contact->load_cached($self->{cp_id})->cp_givenname; # for qw(gender givename name); my $name = SL::DB::Contact->load_cached($self->{cp_id})->cp_name; # for qw(gender givename name); my $gender = SL::DB::Contact->load_cached($self->{cp_id})->cp_gender; # for qw(gender givename name); @@ -1365,8 +1286,11 @@ sub generate_email_body { return undef unless $body; - $body .= GenericTranslations->get(translation_type =>"salutation_punctuation_mark", language_id => $self->{language_id}) . "\n"; - $body .= GenericTranslations->get(translation_type =>"preset_text_$self->{formname}", language_id => $self->{language_id}); + my $translation_type = $params{translation_type} // "preset_text_$self->{formname}"; + my $main_body = GenericTranslations->get(translation_type => $translation_type, language_id => $self->{language_id}); + $main_body = GenericTranslations->get(translation_type => $params{fallback_translation_type}, language_id => $self->{language_id}) if !$main_body && $params{fallback_translation_type}; + $body .= GenericTranslations->get(translation_type => "salutation_punctuation_mark", language_id => $self->{language_id}) . "\n\n"; + $body .= $main_body; $body = $main::locale->unquote_special_chars('HTML', $body); @@ -1860,7 +1784,7 @@ sub add_shipto { my @values; foreach my $item (qw(name department_1 department_2 street zipcode city country gln - contact cp_gender phone fax email)) { + contact phone fax email)) { if ($self->{"shipto$item"}) { $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"}); } @@ -1869,6 +1793,12 @@ sub add_shipto { return if !$shipto; + # shiptocp_gender only makes sense, if any other shipto attribute is set. + # Because shiptocp_gender is set to 'm' by default in forms + # it must not be considered above to decide if shiptos has to be added or + # updated, but must be inserted or updated as well in case. + push(@values, $self->{shiptocp_gender}); + my $shipto_id = $self->{shipto_id}; if ($self->{shipto_id}) { @@ -1882,10 +1812,10 @@ sub add_shipto { shiptocountry = ?, shiptogln = ?, shiptocontact = ?, - shiptocp_gender = ?, shiptophone = ?, shiptofax = ?, shiptoemail = ? + shiptocp_gender = ?, WHERE shipto_id = ?|; do_query($self, $dbh, $query, @values, $self->{shipto_id}); } else { @@ -1899,10 +1829,10 @@ sub add_shipto { shiptocountry = ? AND shiptogln = ? AND shiptocontact = ? AND - shiptocp_gender = ? AND shiptophone = ? AND shiptofax = ? AND shiptoemail = ? AND + shiptocp_gender = ? AND module = ? AND trans_id = ?|; my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id); @@ -1910,7 +1840,7 @@ sub add_shipto { my $insert_query = qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2, shiptostreet, shiptozipcode, shiptocity, shiptocountry, shiptogln, - shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module) + shiptocontact, shiptophone, shiptofax, shiptoemail, shiptocp_gender, module) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|; do_query($self, $dbh, $insert_query, $id, @values, $module); @@ -2058,26 +1988,6 @@ sub _get_projects { $main::lxdebug->leave_sub(); } -sub _get_shipto { - $main::lxdebug->enter_sub(); - - my ($self, $dbh, $vc_id, $key) = @_; - - $key = "all_shipto" unless ($key); - - if ($vc_id) { - # get shipping addresses - my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|; - - $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id); - - } else { - $self->{$key} = []; - } - - $main::lxdebug->leave_sub(); -} - sub _get_printers { $main::lxdebug->enter_sub(); @@ -2117,36 +2027,6 @@ sub _get_charts { $main::lxdebug->leave_sub(); } -sub _get_taxcharts { - $main::lxdebug->enter_sub(); - - my ($self, $dbh, $params) = @_; - - my $key = "all_taxcharts"; - my @where; - - if (ref $params eq 'HASH') { - $key = $params->{key} if ($params->{key}); - if ($params->{module} eq 'AR') { - push @where, 'chart_categories ~ \'[ACILQ]\''; - - } elsif ($params->{module} eq 'AP') { - push @where, 'chart_categories ~ \'[ACELQ]\''; - } - - } elsif ($params) { - $key = $params; - } - - my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : ''; - - my $query = qq|SELECT * FROM tax $where ORDER BY taxkey, rate|; - - $self->{$key} = selectall_hashref_query($self, $dbh, $query); - - $main::lxdebug->leave_sub(); -} - sub _get_taxzones { $main::lxdebug->enter_sub(); @@ -2360,31 +2240,19 @@ sub _get_simple { $main::lxdebug->leave_sub(); } -#sub _get_groups { -# $main::lxdebug->enter_sub(); -# -# my ($self, $dbh, $key) = @_; -# -# $key ||= "all_groups"; -# -# my $groups = $main::auth->read_groups(); -# -# $self->{$key} = selectall_hashref_query($self, $dbh, $query); -# -# $main::lxdebug->leave_sub(); -#} - sub get_lists { $main::lxdebug->enter_sub(); my $self = shift; my %params = @_; + croak "get_lists: shipto is no longer supported" if $params{shipto}; + my $dbh = $self->get_standard_dbh(\%main::myconfig); my ($sth, $query, $ref); my ($vc, $vc_id); - if ($params{contacts} || $params{shipto}) { + if ($params{contacts}) { $vc = 'customer' if $self->{"vc"} eq "customer"; $vc = 'vendor' if $self->{"vc"} eq "vendor"; die "invalid use of get_lists, need 'vc'" unless $vc; @@ -2395,10 +2263,6 @@ sub get_lists { $self->_get_contacts($dbh, $vc_id, $params{"contacts"}); } - if ($params{"shipto"}) { - $self->_get_shipto($dbh, $vc_id, $params{"shipto"}); - } - if ($params{"projects"} || $params{"all_projects"}) { $self->_get_projects($dbh, $params{"all_projects"} ? $params{"all_projects"} : $params{"projects"}, @@ -2417,10 +2281,6 @@ sub get_lists { $self->_get_charts($dbh, $params{"charts"}); } - if ($params{"taxcharts"}) { - $self->_get_taxcharts($dbh, $params{"taxcharts"}); - } - if ($params{"taxzones"}) { $self->_get_taxzones($dbh, $params{"taxzones"}); } @@ -2473,10 +2333,6 @@ sub get_lists { $self->_get_warehouses($dbh, $params{warehouses}); } -# if ($params{groups}) { -# $self->_get_groups($dbh, $params{groups}); -# } - if ($params{partsgroup}) { $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} }); } @@ -2710,8 +2566,8 @@ sub create_links { if ($self->{id}) { $query = qq|SELECT - a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid, - a.duedate, a.ordnumber, a.taxincluded, (SELECT cu.name FROM currencies cu WHERE cu.id=a.currency_id) AS currency, a.notes, + a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid, a.deliverydate, + a.duedate, a.tax_point, a.ordnumber, a.taxincluded, (SELECT cu.name FROM currencies cu WHERE cu.id=a.currency_id) AS currency, a.notes, a.mtime, a.itime, a.intnotes, a.department_id, a.amount AS oldinvtotal, a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type, @@ -3326,19 +3182,6 @@ sub prepare_for_printing { $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 then it's - # one from the customer's/vendor's master data. Otherwise look an a - # customized address linking back to the current record. - my $shipto_module = $self->{type} =~ /_delivery_order$/ ? 'DO' - : $self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/ ? 'OE' - : 'AR'; - my $shipto = $self->{shipto_id} ? SL::DB::Shipto->new(shipto_id => $self->{shipto_id})->load - : SL::DB::Manager::Shipto->get_first(where => [ module => $shipto_module, trans_id => $self->{id} ]); - if ($shipto) { - $self->{$_} = $shipto->$_ for grep { m{^shipto} } map { $_->name } @{ $shipto->meta->columns }; - $self->{"shiptocvar_" . $_->config->name} = $_->value_as_text for @{ $shipto->cvars_by_config }; - } - my $language = $self->{language} ? '_' . $self->{language} : ''; my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates); @@ -3387,7 +3230,7 @@ sub prepare_for_printing { # Format dates. $self->format_dates($output_dateformat, $output_longdates, - qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid + qw(invdate orddate quodate pldate duedate reqdate transdate tax_point 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}))); @@ -3407,6 +3250,14 @@ sub prepare_for_printing { $self->reformat_numbers($output_numberformat, $precision, @{ $field_list }); } + # Translate units + if (($self->{language} // '') ne '') { + my $template_arrays = $self->{TEMPLATE_ARRAYS} || $self; + for my $idx (0..scalar(@{ $template_arrays->{unit} }) - 1) { + $template_arrays->{unit}->[$idx] = AM->translate_units($self, $self->{language}, $template_arrays->{unit}->[$idx], $template_arrays->{qty}->[$idx]) + } + } + $self->{template_meta} = { formname => $self->{formname}, language => SL::DB::Manager::Language->find_by_or_create(id => $self->{language_id} || undef),