X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FForm.pm;h=d0a4157b4a66bb7d4ee10f2fc5833bbcd631688b;hb=8003c3b1db2dd73402977fcfe29653108794099c;hp=06a8910a7629ae5ec37467d624e36782847dd014;hpb=84565d3d86385bbb8a3caf453168ca1e114a01bd;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index 06a8910a7..d0a4157b4 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -40,7 +40,6 @@ package Form; use Data::Dumper; use CGI; -use CGI::Ajax; use Cwd; use Encode; use File::Copy; @@ -59,7 +58,9 @@ use SL::IC; use SL::IS; use SL::Mailer; use SL::Menu; +use SL::MoreCommon qw(uri_encode uri_decode); use SL::OE; +use SL::Request; use SL::Template; use SL::User; use SL::X; @@ -82,168 +83,6 @@ sub disconnect_standard_dbh { undef $standard_dbh; } -sub _store_value { - $main::lxdebug->enter_sub(2); - - my $self = shift; - my $key = shift; - my $value = shift; - - my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key; - - my $curr; - - if (scalar @tokens) { - $curr = \ $self->{ shift @tokens }; - } - - while (@tokens) { - my $sep = shift @tokens; - my $key = shift @tokens; - - $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]'; - $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].'; - $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].'; - $curr = \ $$curr->{$key} - } - - $$curr = $value; - - $main::lxdebug->leave_sub(2); - - return $curr; -} - -sub _input_to_hash { - $main::lxdebug->enter_sub(2); - - my $self = shift; - my $input = shift; - - my @pairs = split(/&/, $input); - - foreach (@pairs) { - my ($key, $value) = split(/=/, $_, 2); - $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key); - } - - $main::lxdebug->leave_sub(2); -} - -sub _request_to_hash { - $main::lxdebug->enter_sub(2); - - my $self = shift; - my $input = shift; - my $uploads = {}; - - if (!$ENV{'CONTENT_TYPE'} - || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) { - - $self->_input_to_hash($input); - - $main::lxdebug->leave_sub(2); - return $uploads; - } - - my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous); - - my $boundary = '--' . $1; - - foreach my $line (split m/\n/, $input) { - last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r")); - - if (($line eq $boundary) || ($line eq "$boundary\r")) { - ${ $previous } =~ s|\r?\n$|| if $previous; - - undef $previous; - undef $filename; - - $headers_done = 0; - $content_type = "text/plain"; - $boundary_found = 1; - $need_cr = 0; - - next; - } - - next unless $boundary_found; - - if (!$headers_done) { - $line =~ s/[\r\n]*$//; - - if (!$line) { - $headers_done = 1; - next; - } - - if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) { - if ($line =~ m|filename\s*=\s*"(.*?)"|i) { - $filename = $1; - substr $line, $-[0], $+[0] - $-[0], ""; - } - - if ($line =~ m|name\s*=\s*"(.*?)"|i) { - $name = $1; - substr $line, $-[0], $+[0] - $-[0], ""; - } - - $previous = _store_value($uploads, $name, '') if ($name); - $self->{FILENAME} = $filename if ($filename); - - next; - } - - if ($line =~ m|^content-type\s*:\s*(.*?)$|i) { - $content_type = $1; - } - - next; - } - - next unless $previous; - - ${ $previous } .= "${line}\n"; - } - - ${ $previous } =~ s|\r?\n$|| if $previous; - - $main::lxdebug->leave_sub(2); - - return $uploads; -} - -sub _recode_recursively { - $main::lxdebug->enter_sub(); - my ($iconv, $param) = @_; - - if (any { ref $param eq $_ } qw(Form HASH)) { - foreach my $key (keys %{ $param }) { - if (!ref $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}); - } - } - - } elsif (ref $param eq 'ARRAY') { - foreach my $idx (0 .. scalar(@{ $param }) - 1) { - if (!ref $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]); - } - } - } - $main::lxdebug->leave_sub(); -} - sub new { $main::lxdebug->enter_sub(); @@ -251,6 +90,7 @@ sub new { my $self = {}; + no warnings 'once'; if ($LXDebug::watch_form) { require SL::Watchdog; tie %{ $self }, 'SL::Watchdog'; @@ -258,43 +98,6 @@ sub new { bless $self, $type; - $main::lxdebug->leave_sub(); - - return $self; -} - -sub read_cgi_input { - $main::lxdebug->enter_sub(); - - my ($self) = @_; - - $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING}; - $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0]; - - my $uploads; - if ($ENV{CONTENT_LENGTH}) { - my $content; - read STDIN, $content, $ENV{CONTENT_LENGTH}; - $uploads = $self->_request_to_hash($content); - } - - if ($self->{RESTORE_FORM_FROM_SESSION_ID}) { - my %temp_form; - $::auth->restore_form_from_session(delete $self->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form); - $self->_input_to_hash(join '&', map { $self->escape($_) . '=' . $self->escape($temp_form{$_}) } keys %temp_form); - } - - my $db_charset = $::lx_office_conf{system}->{dbcharset}; - $db_charset ||= Common::DEFAULT_CHARSET; - - my $encoding = $self->{INPUT_ENCODING} || $db_charset; - delete $self->{INPUT_ENCODING}; - - _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self); - - map { $self->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads; - - #$self->{version} = "2.6.1"; # Old hardcoded but secure style open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file $self->{version} = ; close VERSION_FILE; @@ -305,6 +108,11 @@ sub read_cgi_input { return $self; } +sub read_cgi_input { + my ($self) = @_; + SL::Request::read_cgi_input($self); +} + sub _flatten_variables_rec { $main::lxdebug->enter_sub(2); @@ -404,32 +212,15 @@ sub dumper { } sub escape { - $main::lxdebug->enter_sub(2); - my ($self, $str) = @_; - $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8; - $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge; - - $main::lxdebug->leave_sub(2); - - return $str; + return uri_encode($str); } sub unescape { - $main::lxdebug->enter_sub(2); - my ($self, $str) = @_; - $str =~ tr/+/ /; - $str =~ s/\\$//; - - $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg; - $str = Encode::decode('utf-8-strict', $str) if $::locale->is_utf8; - - $main::lxdebug->leave_sub(2); - - return $str; + return uri_decode($str); } sub quote { @@ -463,11 +254,11 @@ sub hide_form { my $self = shift; if (@_) { - map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_); + map({ print($::request->{cgi}->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_); } else { for (sort keys %$self) { next if (($_ eq "header") || (ref($self->{$_}) ne "")); - print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); + print($::request->{cgi}->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } } $main::lxdebug->leave_sub(); @@ -520,7 +311,7 @@ sub info { ', '', - '', + '', '', '', '', - ''; + '', + '', + '', + ''; push @header, $self->{javascript} if $self->{javascript}; push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] }; push @header, "" if $self->{fokus}; @@ -720,10 +513,15 @@ sub header { |; } + my %doctypes = ( + strict => qq||, + transitional => qq||, + frameset => qq||, + ); + # output print $self->create_http_response(content_type => 'text/html', charset => $db_charset); - print "\n" - if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE. + print $doctypes{$params{doctype} || 'transitional'}, $/; print < @@ -732,9 +530,9 @@ sub header { EOT print " $_\n" for @header; print < - - + + + - $extra_code + $params{extra_code} $title_hack @@ -759,8 +557,7 @@ sub ajax_response_header { my ($self) = @_; my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET; - my $cgi = $main::cgi || CGI->new(''); - my $output = $cgi->header('-charset' => $db_charset); + my $output = $::request->{cgi}->header('-charset' => $db_charset); $main::lxdebug->leave_sub(); @@ -777,8 +574,7 @@ sub redirect_header { die "Headers already sent" if $self->{header}; $self->{header} = 1; - my $cgi = $main::cgi || CGI->new(''); - return $cgi->redirect($new_uri); + return $::request->{cgi}->redirect($new_uri); } sub set_standard_title { @@ -845,8 +641,8 @@ sub _prepare_html_template { $additional_params->{"conf_payments_changeable"} = $::lx_office_conf{features}->{payments_changeable}; $additional_params->{"INSTANCE_CONF"} = $::instance_conf; - if (%main::debug_options) { - map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options; + if (my $debug_options = $::lx_office_conf{debug}{options}) { + map { $additional_params->{'DEBUG_' . uc($_)} = $debug_options->{$_} } keys %$debug_options; } if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) { @@ -1117,8 +913,7 @@ sub format_amount_units { return ''; } - AM->retrieve_all_units(); - my $all_units = $main::all_units; + my $all_units = AM->retrieve_all_units; if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) { $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller'); @@ -1233,7 +1028,7 @@ sub parse_template { $main::lxdebug->enter_sub(); my ($self, $myconfig) = @_; - my $out; + my ($out, $out_mode); local (*IN, *OUT); @@ -1299,31 +1094,30 @@ sub parse_template { # OUT is used for the media, screen, printer, email # for postscript we store a copy in a temporary file - my $fileid = time; - my $prepend_userspath; - - if (!$self->{tmpfile}) { - $self->{tmpfile} = "${fileid}.$self->{IN}"; - $prepend_userspath = 1; - } - - $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath; - - $self->{tmpfile} =~ s|.*/||; - $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g; - $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath; + my ($temp_fh, $suffix); + $suffix = $self->{IN}; + $suffix =~ s/.*\.//; + ($temp_fh, $self->{tmpfile}) = File::Temp::tempfile( + 'lx-office-printXXXXXX', + SUFFIX => '.' . ($suffix || 'tex'), + DIR => $userspath, + UNLINK => 1, + ); + close $temp_fh; if ($template->uses_temp_file() || $self->{media} eq 'email') { $out = $self->{OUT}; + $out_mode = $self->{OUT_MODE} || '>'; $self->{OUT} = "$self->{tmpfile}"; + $self->{OUT_MODE} = '>'; } my $result; if ($self->{OUT}) { - open(OUT, ">", $self->{OUT}) or $self->error("$self->{OUT} : $!"); + open(OUT, $self->{OUT_MODE}, $self->{OUT}) or $self->error("error on opening $self->{OUT} with mode $self->{OUT_MODE} : $!"); } else { - open(OUT, ">&", \*STDOUT) or $self->error("STDOUT : $!"); + *OUT = ($::dispatcher->get_standard_filehandles)[1]; $self->header; } @@ -1332,7 +1126,7 @@ sub parse_template { $self->error("$self->{IN} : " . $template->get_error()); } - close OUT; + close OUT if $self->{OUT}; if ($self->{media} eq 'file') { copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file; @@ -1355,7 +1149,7 @@ sub parse_template { $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET; $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email}; $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|; - $mail->{fileid} = "$fileid."; + $mail->{fileid} = time() . '.' . $$ . '.'; $myconfig->{signature} =~ s/\r//g; # if we send html or plain text inline @@ -1394,7 +1188,8 @@ sub parse_template { } else { - $self->{OUT} = $out; + $self->{OUT} = $out; + $self->{OUT_MODE} = $out_mode; my $numbytes = (-s $self->{tmpfile}); open(IN, "<", $self->{tmpfile}) @@ -1408,8 +1203,8 @@ sub parse_template { #print(STDERR "OUT $self->{OUT}\n"); for my $i (1 .. $self->{copies}) { if ($self->{OUT}) { - open OUT, '>', $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!"); - print OUT while ; + open OUT, $self->{OUT_MODE}, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!"); + print OUT $_ while ; close OUT; seek IN, 0, 0; @@ -2337,7 +2132,7 @@ sub _get_taxcharts { $key = $params; } - my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where); + my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : ''; my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|; @@ -2452,7 +2247,7 @@ sub _get_customers { my $options = ref $key eq 'HASH' ? $key : { key => $key }; $options->{key} ||= "all_customers"; - my $limit_clause = "LIMIT $options->{limit}" if $options->{limit}; + my $limit_clause = $options->{limit} ? "LIMIT $options->{limit}" : ''; my @where; push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman}; @@ -2755,19 +2550,11 @@ sub all_vc { @{ $self->{all_employees} } = sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} }; - if ($module eq 'AR') { # prepare query for departments - $query = qq|SELECT id, description - FROM department - WHERE role = 'P' - ORDER BY description|; - - } else { $query = qq|SELECT id, description FROM department ORDER BY description|; - } $self->{all_departments} = selectall_hashref_query($self, $dbh, $query); @@ -2838,15 +2625,9 @@ sub all_departments { my ($self, $myconfig, $table) = @_; my $dbh = $self->get_standard_dbh($myconfig); - my $where; - - if ($table eq 'customer') { - $where = "WHERE role = 'P' "; - } my $query = qq|SELECT id, description FROM department - $where ORDER BY description|; $self->{all_departments} = selectall_hashref_query($self, $dbh, $query); @@ -2886,11 +2667,28 @@ sub create_links { } # now get the account numbers - $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id - FROM chart c, taxkeys tk - WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id = - (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1) - ORDER BY c.accno|; +# $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id +# FROM chart c, taxkeys tk +# WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id = +# (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1) +# ORDER BY c.accno|; + +# same query as above, but without expensive subquery for each row. about 80% faster + $query = qq| + SELECT c.accno, c.description, c.link, c.taxkey_id, tk2.tax_id + FROM chart c + -- find newest entries in taxkeys + INNER JOIN ( + SELECT chart_id, MAX(startdate) AS startdate + FROM taxkeys + WHERE (startdate <= $transdate) + GROUP BY chart_id + ) tk ON (c.id = tk.chart_id) + -- and load all of those entries + INNER JOIN taxkeys tk2 + ON (tk.chart_id = tk2.chart_id AND tk.startdate = tk2.startdate) + WHERE (c.link LIKE ?) + ORDER BY c.accno|; $sth = $dbh->prepare($query); @@ -2949,6 +2747,9 @@ 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}); @@ -3056,7 +2857,7 @@ sub create_links { if ($self->{"$self->{vc}_id"}) { # only setup currency - ($self->{currency}) = split(/:/, $self->{currencies}); + ($self->{currency}) = split(/:/, $self->{currencies}) if !$self->{currency}; } else { @@ -3086,12 +2887,14 @@ sub lastname_used { "a.department_id" => "department_id", "d.description" => "department", "ct.name" => $table, + "ct.curr" => "cv_curr", "current_date + ct.terms" => "duedate", ); if ($self->{type} =~ /delivery_order/) { $arap = 'delivery_orders'; delete $column_map{"a.curr"}; + delete $column_map{"ct.curr"}; } elsif ($self->{type} =~ /_order/) { $arap = 'oe'; @@ -3125,6 +2928,13 @@ sub lastname_used { 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(); } @@ -3652,8 +3462,8 @@ sub prepare_for_printing { $extension = 'xls'; } - my $printer_code = '_' . $self->{printer_code} if $self->{printer_code}; - my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}"; + my $printer_code = $self->{printer_code} ? '_' . $self->{printer_code} : ''; + my $email_extension = -f "$::myconfig{templates}/$self->{formname}_email${language}.${extension}" ? '_email' : ''; $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}"; # Format dates. @@ -3774,61 +3584,6 @@ Points of interest for a beginner are: =head1 SPECIAL FUNCTIONS -=head2 C<_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, ... ] - =head2 C PARAMS PARAMS (not named):