X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FForm.pm;h=8d28f845b869a38afe3348df0669eb9dc06a86a2;hb=ce83fab980b72a2b3d4066ce2b49cbf3feec56a5;hp=b9ba6942f36b0515c682f81030b56a092ad5a273;hpb=debd14edcc23a6168e827be861a052f396aee901;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index b9ba6942f..8d28f845b 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; @@ -57,9 +56,12 @@ use SL::DBUtils; use SL::DO; use SL::IC; use SL::IS; +use SL::Locale; 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 +84,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(); @@ -259,43 +99,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; @@ -306,6 +109,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); @@ -405,32 +213,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 { @@ -464,11 +255,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(); @@ -521,7 +312,7 @@ sub info { ', - '', - '', - '', - '', - '', - '', - '', - ''; + push @header, map { qq|| } + qw(jquery common jscalendar/calendar jscalendar/lang/calendar-de jscalendar/calendar-setup part_selection jquery-ui jqModal switchmenuframe); push @header, $self->{javascript} if $self->{javascript}; + 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 { $_->show_javascript } @{ $self->{AJAX} || [] }; push @header, "" if $self->{fokus}; push @header, sprintf "", @@ -723,10 +529,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 < @@ -735,9 +546,7 @@ sub header { EOT print " $_\n" for @header; print < - - + - $extra_code + $params{extra_code} $title_hack @@ -762,8 +571,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(); @@ -780,15 +588,14 @@ 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 { $::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}; @@ -1058,6 +865,7 @@ sub format_amount { $main::lxdebug->enter_sub(2); my ($self, $myconfig, $amount, $places, $dash) = @_; + $dash ||= ''; if ($amount eq "") { $amount = 0; @@ -1074,9 +882,10 @@ sub format_amount { $amount *= 1; $places *= -1; - my ($actual_places) = ($amount =~ /\.(\d+)/); - $actual_places = length($actual_places); - $places = $actual_places > $places ? $actual_places : $places; + if ($amount =~ /\.(\d+)/) { + my $actual_places = length $1; + $places = $actual_places if $actual_places > $places; + } } } $amount = $self->round_amount($amount, $places); @@ -1088,7 +897,7 @@ sub format_amount { $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 ''); + $amount .= $d[0].($p[1]||'').(0 x ($places - length ($p[1]||''))) if ($places || $p[1] ne ''); $amount = do { ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) : @@ -1235,7 +1044,7 @@ sub parse_template { $main::lxdebug->enter_sub(); my ($self, $myconfig) = @_; - my $out; + my ($out, $out_mode); local (*IN, *OUT); @@ -1301,29 +1110,33 @@ 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( + 'kivitendo-printXXXXXX', + SUFFIX => '.' . ($suffix || 'tex'), + DIR => $userspath, + UNLINK => 1, + ); + close $temp_fh; if ($template->uses_temp_file() || $self->{media} eq 'email') { - $out = $self->{OUT}; - $self->{OUT} = "$self->{tmpfile}"; + $out = $self->{OUT}; + $out_mode = $self->{OUT_MODE} || '>'; + $self->{OUT} = "$self->{tmpfile}"; + $self->{OUT_MODE} = '>'; } my $result; + my $command_formatter = sub { + my ($out_mode, $out) = @_; + return $out_mode eq '|-' ? SL::Template::create(type => 'ShellCommand', form => $self)->parse($out) : $out; + }; if ($self->{OUT}) { - open(OUT, ">", $self->{OUT}) or $self->error("$self->{OUT} : $!"); + $self->{OUT} = $command_formatter->($self->{OUT_MODE}, $self->{OUT}); + open(OUT, $self->{OUT_MODE}, $self->{OUT}) or $self->error("error on opening $self->{OUT} with mode $self->{OUT_MODE} : $!"); } else { *OUT = ($::dispatcher->get_standard_filehandles)[1]; $self->header; @@ -1357,24 +1170,20 @@ 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 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
"; + $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
"; open(IN, "<", $self->{tmpfile}) or $self->error($self->cleanup . "$self->{tmpfile} : $!"); - while () { - $mail->{message} .= $_; - } - + $mail->{message} .= $_ while ; close(IN); } else { @@ -1396,7 +1205,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}) @@ -1410,10 +1220,12 @@ 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 ; + $self->{OUT} = $command_formatter->($self->{OUT_MODE}, $self->{OUT}); + + open OUT, $self->{OUT_MODE}, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!"); + print OUT $_ while ; close OUT; - seek IN, 0, 0; + seek IN, 0, 0; } else { $self->{attachment_filename} = ($self->{attachment_filename}) @@ -1448,6 +1260,9 @@ sub get_formname_translation { $formname ||= $self->{formname}; + $self->{recipient_locale} ||= Locale->lang_to_locale($self->{language}); + local $::locale = Locale->new($self->{recipient_locale}); + my %formname_translations = ( bin_list => $main::locale->text('Bin List'), credit_note => $main::locale->text('Credit Note'), @@ -1465,7 +1280,7 @@ sub get_formname_translation { ); $main::lxdebug->leave_sub(); - return $formname_translations{$formname} + return $formname_translations{$formname}; } sub get_number_prefix_for_type { @@ -1501,11 +1316,14 @@ sub generate_attachment_filename { $main::lxdebug->enter_sub(); my ($self) = @_; + $self->{recipient_locale} ||= Locale->lang_to_locale($self->{language}); + my $recipient_locale = Locale->new($self->{recipient_locale}); + my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation()); my $prefix = $self->get_number_prefix_for_type(); if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) { - $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format(); + $attachment_filename .= ' (' . $recipient_locale->text('Preview') . ')' . $self->get_extension_for_format(); } elsif ($attachment_filename && $self->{"${prefix}number"}) { $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format(); @@ -2159,7 +1977,7 @@ sub get_employee_data { my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id})); if ($login) { - my $user = User->new($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); $self->{$params{prefix} . '_login'} = $login; @@ -2339,7 +2157,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|; @@ -2454,7 +2272,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}; @@ -2716,7 +2534,7 @@ sub get_name { return scalar(@{ $self->{name_list} }); } -# the selection sub is used in the AR, AP, IS, IR and OE module +# the selection sub is used in the AR, AP, IS, IR, DO and OE module # sub all_vc { $main::lxdebug->enter_sub(); @@ -2728,13 +2546,17 @@ sub all_vc { $table = $table eq "customer" ? "customer" : "vendor"; - my $query = qq|SELECT count(*) FROM $table|; + # build selection list + # 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}; + my $query = qq|SELECT count(*) FROM $table $obsolete|; 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 + FROM $table $obsolete ORDER BY name|; $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query); } @@ -3064,7 +2886,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 { @@ -3094,12 +2916,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'; @@ -3135,6 +2959,10 @@ sub lastname_used { # 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(); } @@ -3663,8 +3491,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. @@ -3785,61 +3613,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):