X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;ds=sidebyside;f=SL%2FForm.pm;h=86f643378a64c02dfb6f611d15e8b34b4145e4f5;hb=5d23fb605bc40f699ab677e6ee13a7e498c9fb14;hp=74de73833eacd0b4d6cdc38a415998dc4d4b9668;hpb=8e08bedb4b4bfb97adcb4f4eb94a60012ca3729b;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index 74de73833..86f643378 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -37,8 +37,6 @@ package Form; -#use strict; - use Data::Dumper; use CGI; @@ -59,6 +57,8 @@ use Template; use List::Util qw(first max min sum); use List::MoreUtils qw(any); +use strict; + my $standard_dbh; END { @@ -68,62 +68,6 @@ END { } } -=item _store_value() - -parses a complex var name, and stores it in the form. - -syntax: - $form->_store_value($key, $value); - -keys must start with a string, and can contain various tokens. -supported key structures are: - -1. simple access - simple key strings work as expected - - id => $form->{id} - -2. hash access. - separating two keys by a dot (.) will result in a hash lookup for the inner value - this is similar to the behaviour of java and templating mechanisms. - - filter.description => $form->{filter}->{description} - -3. array+hashref access - - adding brackets ([]) before the dot will cause the next hash to be put into an array. - using [+] instead of [] will force a new array index. this is useful for recurring - data structures like part lists. put a [+] into the first varname, and use [] on the - following ones. - - repeating these names in your template: - - invoice.items[+].id - invoice.items[].parts_id - - will result in: - - $form->{invoice}->{items}->[ - { - id => ... - parts_id => ... - }, - { - id => ... - parts_id => ... - } - ... - ] - -4. arrays - - using brackets at the end of a name will result in a pure array to be created. - note that you mustn't use [+], which is reserved for array+hash access and will - result in undefined behaviour in array context. - - filter.status[] => $form->{status}->[ val1, val2, ... ] - -=cut sub _store_value { $main::lxdebug->enter_sub(2); @@ -259,7 +203,10 @@ sub _recode_recursively { if (any { ref $param eq $_ } qw(Form HASH)) { foreach my $key (keys %{ $param }) { if (!ref $param->{$key}) { - $param->{$key} = $iconv->convert($param->{$key}); + # Workaround for a bug: converting $param->{$key} directly + # leads to 'undef'. I don't know why. Converting a copy works, + # though. + $param->{$key} = $iconv->convert("" . $param->{$key}); } else { _recode_recursively($iconv, $param->{$key}); } @@ -268,7 +215,10 @@ sub _recode_recursively { } elsif (ref $param eq 'ARRAY') { foreach my $idx (0 .. scalar(@{ $param }) - 1) { if (!ref $param->[$idx]) { - $param->[$idx] = $iconv->convert($param->[$idx]); + # Workaround for a bug: converting $param->[$idx] directly + # leads to 'undef'. I don't know why. Converting a copy works, + # though. + $param->[$idx] = $iconv->convert("" . $param->[$idx]); } else { _recode_recursively($iconv, $param->[$idx]); } @@ -306,19 +256,21 @@ sub new { my $db_charset = $main::dbcharset; $db_charset ||= Common::DEFAULT_CHARSET; - if ($self->{INPUT_ENCODING} && (lc $self->{INPUT_ENCODING} ne $db_charset)) { - require Text::Iconv; - my $iconv = Text::Iconv->new($self->{INPUT_ENCODING}, $db_charset); + if ($self->{INPUT_ENCODING}) { + if (lc $self->{INPUT_ENCODING} ne lc $db_charset) { + require Text::Iconv; + my $iconv = Text::Iconv->new($self->{INPUT_ENCODING}, $db_charset); - _recode_recursively($iconv, $self); + _recode_recursively($iconv, $self); + } - delete $self{INPUT_ENCODING}; + delete $self->{INPUT_ENCODING}; } $self->{action} = lc $self->{action}; $self->{action} =~ s/( |-|,|\#)/_/g; - $self->{version} = "2.6.0"; + $self->{version} = "2.6.1"; $main::lxdebug->leave_sub(); @@ -607,9 +559,10 @@ sub create_http_response { my $session_cookie_value = $main::auth->get_session_id(); $session_cookie_value ||= 'NO_SESSION'; - $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(), - '-value' => $session_cookie_value, - '-path' => $base_path); + $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(), + '-value' => $session_cookie_value, + '-path' => $base_path, + '-secure' => $ENV{HTTPS}); } my %cgi_params = ('-type' => $params{content_type}); @@ -627,6 +580,8 @@ sub create_http_response { sub header { $main::lxdebug->enter_sub(); + # extra code ist 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) = @_; if ($self->{header}) { @@ -671,13 +626,22 @@ sub header { |; } - my $fokus = qq| document.$self->{fokus}.focus();| if ($self->{"fokus"}); + my $fokus = qq| + + | if $self->{"fokus"}; #Set Calendar my $jsscript = ""; if ($self->{jsscript} == 1) { $jsscript = qq| + @@ -692,7 +656,7 @@ sub header { ? "$self->{title} - $self->{titlebar}" : $self->{titlebar}; my $ajax = ""; - foreach my $item (@ { $self->{AJAX} }) { + for my $item (@ { $self->{AJAX} || [] }) { $ajax .= $item->show_javascript(); } @@ -708,13 +672,9 @@ sub header { $jsscript $ajax - + $fokus + + @@ -760,7 +720,7 @@ sub _prepare_html_template { my ($self, $file, $additional_params) = @_; my $language; - if (!defined(%main::myconfig) || !defined($main::myconfig{"countrycode"})) { + if (!%::myconfig || !$::myconfig{"countrycode"}) { $language = $main::language; } else { $language = $main::myconfig{"countrycode"}; @@ -811,6 +771,8 @@ sub _prepare_html_template { $additional_params->{"conf_lizenzen"} = $main::lizenzen; $additional_params->{"conf_latex_templates"} = $main::latex; $additional_params->{"conf_opendocument_templates"} = $main::opendocument_templates; + $additional_params->{"conf_vertreter"} = $main::vertreter; + $additional_params->{"conf_show_best_before"} = $main::show_best_before; if (%main::debug_options) { map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options; @@ -1165,13 +1127,13 @@ sub round_amount { my ($self, $amount, $places) = @_; my $round_amount; - # Rounding like "Kaufmannsrunden" - # Descr. http://de.wikipedia.org/wiki/Rundung - # Inspired by - # http://www.perl.com/doc/FAQs/FAQ/oldfaq-html/Q4.13.html - # Solves Bug: 189 - # Udo Spallek - $amount = $amount * (10**($places)); + # 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); @@ -1216,6 +1178,10 @@ sub parse_template { } elsif ( $self->{"format"} =~ /elstertaxbird/i ) { $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + } elsif ( $self->{"format"} =~ /excel/i ) { + $template = ExcelTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $ext_for_format = 'xls'; + } elsif ( defined $self->{'format'}) { $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}"); @@ -1423,6 +1389,7 @@ sub get_extension_for_format { my $extension = $self->{format} =~ /pdf/i ? ".pdf" : $self->{format} =~ /postscript/i ? ".ps" : $self->{format} =~ /opendocument/i ? ".odt" + : $self->{format} =~ /excel/i ? ".xls" : $self->{format} =~ /html/i ? ".html" : ""; @@ -1483,7 +1450,7 @@ sub cleanup { close(FH); } - if ($self->{tmpfile}) { + if ($self->{tmpfile} && ! $::keep_temp_files) { $self->{tmpfile} =~ s|.*/||g; # strip extension $self->{tmpfile} =~ s/\.\w+$//g; @@ -1582,7 +1549,7 @@ sub get_standard_dbh { my ($self, $myconfig) = @_; if ($standard_dbh && !$standard_dbh->{Active}) { - $main::lxdebug->message(LXDebug::INFO, "get_standard_dbh: \$standard_dbh is defined but not Active anymore"); + $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore"); undef $standard_dbh; } @@ -1777,7 +1744,7 @@ sub check_exchangerate { return $exchangerate; } -sub get_default_currency { +sub get_all_currencies { $main::lxdebug->enter_sub(); my ($self, $myconfig) = @_; @@ -1785,14 +1752,24 @@ sub get_default_currency { my $query = qq|SELECT curr FROM defaults|; - my ($curr) = selectrow_query($self, $dbh, $query); - my ($defaultcurrency) = split m/:/, $curr; + my ($curr) = selectrow_query($self, $dbh, $query); + my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr; $main::lxdebug->leave_sub(); - return $defaultcurrency; + return @currencies; } +sub get_default_currency { + $main::lxdebug->enter_sub(); + + my ($self, $myconfig) = @_; + my @currencies = $self->get_all_currencies($myconfig); + + $main::lxdebug->leave_sub(); + + return $currencies[0]; +} sub set_payment_options { $main::lxdebug->enter_sub(); @@ -1841,6 +1818,7 @@ 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; @@ -1894,6 +1872,8 @@ sub set_payment_options { map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts; + $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent}; + $main::lxdebug->leave_sub(); } @@ -2018,6 +1998,8 @@ sub get_employee { my ($self, $dbh) = @_; + $dbh ||= $self->get_standard_dbh(\%main::myconfig); + my $query = qq|SELECT id, name FROM employee WHERE login = ?|; ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login}); $self->{"employee_id"} *= 1; @@ -2060,11 +2042,11 @@ sub get_duedate { my ($self, $myconfig, $reference_date) = @_; - my $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_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 $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}); $main::lxdebug->leave_sub(); @@ -2191,7 +2173,7 @@ sub _get_charts { my $transdate = quote_db_date($params->{transdate}); my $query = - qq|SELECT c.id, c.accno, c.description, c.link, tk.taxkey_id, tk.tax_id | . + qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | . qq|FROM chart c | . qq|LEFT JOIN taxkeys tk ON | . qq|(tk.id = (SELECT id FROM taxkeys | . @@ -2264,9 +2246,15 @@ sub _get_business_types { my ($self, $dbh, $key) = @_; - $key = "all_business_types" unless ($key); - $self->{$key} = - selectall_hashref_query($self, $dbh, qq|SELECT * FROM business|); + my $options = ref $key eq 'HASH' ? $key : { key => $key }; + $options->{key} ||= "all_business_types"; + my $where = ''; + + if (exists $options->{salesman}) { + $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)'; + } + + $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|); $main::lxdebug->leave_sub(); } @@ -2330,14 +2318,15 @@ $main::lxdebug->enter_sub(); sub _get_customers { $main::lxdebug->enter_sub(); - my ($self, $dbh, $key, $limit) = @_; - - $key = "all_customers" unless ($key); - my $limit_clause = "LIMIT $limit" if $limit; + my ($self, $dbh, $key) = @_; - my $query = qq|SELECT * FROM customer WHERE NOT obsolete ORDER BY name $limit_clause|; + my $options = ref $key eq 'HASH' ? $key : { key => $key }; + $options->{key} ||= "all_customers"; + my $limit_clause = "LIMIT $options->{limit}" if $options->{limit}; + my $where = $options->{business_is_salesman} ? qq| AND business_id IN (SELECT id FROM business WHERE salesman)| : ''; - $self->{$key} = selectall_hashref_query($self, $dbh, $query); + my $query = qq|SELECT * FROM customer WHERE NOT obsolete $where ORDER BY name $limit_clause|; + $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query); $main::lxdebug->leave_sub(); } @@ -2504,11 +2493,7 @@ sub get_lists { } if($params{"customers"}) { - if (ref $params{"customers"} eq 'HASH') { - $self->_get_customers($dbh, $params{"customers"}{key}, $params{"customers"}{limit}); - } else { - $self->_get_customers($dbh, $params{"customers"}); - } + $self->_get_customers($dbh, $params{"customers"}); } if($params{"vendors"}) { @@ -2610,7 +2595,7 @@ sub all_vc { my ($count) = selectrow_query($self, $dbh, $query); # build selection list - if ($count < $myconfig->{vclimit}) { + if ($count <= $myconfig->{vclimit}) { $query = qq|SELECT id, name, salesman_id FROM $table WHERE NOT obsolete ORDER BY name|; @@ -2730,7 +2715,7 @@ sub all_departments { ORDER BY description|; $self->{all_departments} = selectall_hashref_query($self, $dbh, $query); - delete($self->{all_departments}) unless (@{ $self->{all_departments} }); + delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] }); $main::lxdebug->leave_sub(); } @@ -3010,7 +2995,9 @@ sub lastname_used { sub current_date { $main::lxdebug->enter_sub(); - my ($self, $myconfig, $thisdate, $days) = @_; + my $self = shift; + my $myconfig = shift || \%::myconfig; + my ($thisdate, $days) = @_; my $dbh = $self->get_standard_dbh($myconfig); my $query; @@ -3302,19 +3289,6 @@ sub update_defaults { return $var; } -=item update_business - -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. - -=cut sub update_business { $main::lxdebug->enter_sub(); @@ -3488,3 +3462,93 @@ sub restore_vars { } 1; + +__END__ + +=head1 NAME + +SL::Form.pm - main data object. + +=head1 SYNOPSIS + +This is the main data object of Lx-Office. +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: + + - $form->error - renders a generic error in html. accepts an error message + - $form->get_standard_dbh - returns a database connection for the + +=head1 SPECIAL FUNCTIONS + +=over 4 + +=item _store_value() + +parses a complex var name, and stores it in the form. + +syntax: + $form->_store_value($key, $value); + +keys must start with a string, and can contain various tokens. +supported key structures are: + +1. simple access + simple key strings work as expected + + id => $form->{id} + +2. hash access. + separating two keys by a dot (.) will result in a hash lookup for the inner value + this is similar to the behaviour of java and templating mechanisms. + + filter.description => $form->{filter}->{description} + +3. array+hashref access + + adding brackets ([]) before the dot will cause the next hash to be put into an array. + using [+] instead of [] will force a new array index. this is useful for recurring + data structures like part lists. put a [+] into the first varname, and use [] on the + following ones. + + repeating these names in your template: + + invoice.items[+].id + invoice.items[].parts_id + + will result in: + + $form->{invoice}->{items}->[ + { + id => ... + parts_id => ... + }, + { + id => ... + parts_id => ... + } + ... + ] + +4. arrays + + using brackets at the end of a name will result in a pure array to be created. + note that you mustn't use [+], which is reserved for array+hash access and will + result in undefined behaviour in array context. + + filter.status[] => $form->{status}->[ val1, val2, ... ] + +=item update_business 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. + +=back + +=cut