X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/mfinanz.git/blobdiff_plain/1db3214445fbc5144ebc62c314c11082a2d904c4..3b9a530196e7ecadfd5f8708d2f0025dda4613c7:/SL/Form.pm diff --git a/SL/Form.pm b/SL/Form.pm index 1a2573960..c7539354c 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -52,6 +52,7 @@ use SL::AM; use SL::Common; use SL::CVar; use SL::DB; +use SL::DBConnect; use SL::DBUtils; use SL::DO; use SL::IC; @@ -61,6 +62,7 @@ use SL::Menu; use SL::OE; use SL::Template; use SL::User; +use SL::X; use Template; use URI; use List::Util qw(first max min sum); @@ -249,6 +251,7 @@ sub new { my $self = {}; + no warnings 'once'; if ($LXDebug::watch_form) { require SL::Watchdog; tie %{ $self }, 'SL::Watchdog'; @@ -256,6 +259,16 @@ 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]; @@ -266,6 +279,12 @@ sub new { $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; @@ -445,11 +464,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(); @@ -457,7 +476,7 @@ sub hide_form { sub throw_on_error { my ($self, $code) = @_; - local $self->{__ERROR_HANDLER} = sub { die({ error => $_[0] }) }; + local $self->{__ERROR_HANDLER} = sub { die SL::X::FormError->new($_[0]) }; $code->(); } @@ -605,8 +624,7 @@ sub create_http_response { my $self = shift; my %params = @_; - my $cgi = $main::cgi; - $cgi ||= CGI->new(''); + my $cgi = $::request->{cgi}; my $session_cookie; if (defined $main::auth) { @@ -638,6 +656,18 @@ 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 header { $::lxdebug->enter_sub; @@ -660,18 +690,19 @@ sub header { push @header, ""; } - push @header, "" - for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets}; + push @header, map { qq|| } $self->use_stylesheet; push @header, "" if $self->{landscape}; push @header, "" if -f $self->{favicon}; push @header, '', '', - '', + '', '', '', '', - ''; + '', + '', + ''; push @header, $self->{javascript} if $self->{javascript}; push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] }; push @header, "" if $self->{fokus}; @@ -730,8 +761,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(); @@ -745,11 +775,10 @@ sub redirect_header { my $base_uri = $self->_get_request_uri; my $new_uri = URI->new_abs($new_url, $base_uri); - die "Headers already sent" if $::self->{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 { @@ -777,13 +806,6 @@ sub _prepare_html_template { $language = "de" unless ($language); if (-f "templates/webpages/${file}.html") { - if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) { - my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" . - "Please re-run 'locales.pl' in 'locale/${language}'."; - print(qq|
$info
|); - ::end_of_request(); - } - $file = "templates/webpages/${file}.html"; } else { @@ -813,7 +835,6 @@ sub _prepare_html_template { $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset}; $additional_params->{"conf_webdav"} = $::lx_office_conf{features}->{webdav}; - $additional_params->{"conf_lizenzen"} = $::lx_office_conf{features}->{lizenzen}; $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}; @@ -821,9 +842,11 @@ sub _prepare_html_template { $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; - 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}}) { @@ -860,7 +883,7 @@ sub parse_html_template { sub init_template { my $self = shift; - return if $self->template; + return $self->template if $self->template; return $self->template(Template->new({ 'INTERPOLATE' => 0, @@ -989,23 +1012,30 @@ sub write_trigger { return $jsscript; } #end sub write_trigger +sub _store_redirect_info_in_session { + my ($self) = @_; + + return unless $self->{callback} =~ m:^ ( [^\?/]+ \.pl ) \? (.+) :x; + + my ($controller, $params) = ($1, $2); + my $form = { map { map { $self->unescape($_) } split /=/, $_, 2 } split m/\&/, $params }; + $self->{callback} = "${controller}?RESTORE_FORM_FROM_SESSION_ID=" . $::auth->save_form_in_session(form => $form); +} + sub redirect { $main::lxdebug->enter_sub(); my ($self, $msg) = @_; if (!$self->{callback}) { - $self->info($msg); - ::end_of_request(); - } -# my ($script, $argv) = split(/\?/, $self->{callback}, 2); -# $script =~ s|.*/||; -# $script =~ s|[^a-zA-Z0-9_\.]||g; -# exec("perl", "$script", $argv); + } else { + $self->_store_redirect_info_in_session; + print $::form->redirect_header($self->{callback}); + } - print $::form->redirect_header($self->{callback}); + ::end_of_request(); $main::lxdebug->leave_sub(); } @@ -1087,8 +1117,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'); @@ -1162,7 +1191,7 @@ sub parse_amount { if ( ($myconfig->{numberformat} eq '1.000,00') || ($myconfig->{numberformat} eq '1000,00')) { $amount =~ s/\.//g; - $amount =~ s/,/\./; + $amount =~ s/,/\./g; } if ($myconfig->{numberformat} eq "1'000.00") { @@ -1173,7 +1202,9 @@ sub parse_amount { $main::lxdebug->leave_sub(2); - return ($amount * 1); + # Make sure no code wich is not a math expression ends up in eval(). + return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x; + return scalar(eval($amount)) * 1 ; } sub round_amount { @@ -1283,26 +1314,25 @@ sub parse_template { if ($template->uses_temp_file() || $self->{media} eq 'email') { $out = $self->{OUT}; - $self->{OUT} = ">$self->{tmpfile}"; + $self->{OUT} = "$self->{tmpfile}"; } my $result; if ($self->{OUT}) { - open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!"); - $result = $template->parse(*OUT); - close OUT; - + open(OUT, ">", $self->{OUT}) or $self->error("$self->{OUT} : $!"); } else { + *OUT = ($::dispatcher->get_standard_filehandles)[1]; $self->header; - $result = $template->parse(*STDOUT); } - if (!$result) { + if (!$template->parse(*OUT)) { $self->cleanup(); $self->error("$self->{IN} : " . $template->get_error()); } + 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; $self->cleanup; @@ -1336,7 +1366,7 @@ sub parse_template { $myconfig->{signature} =~ s/\n/
\n/g; $mail->{message} .= "
\n--
\n$myconfig->{signature}\n
"; - open(IN, $self->{tmpfile}) + open(IN, "<", $self->{tmpfile}) or $self->error($self->cleanup . "$self->{tmpfile} : $!"); while () { $mail->{message} .= $_; @@ -1366,7 +1396,7 @@ sub parse_template { $self->{OUT} = $out; my $numbytes = (-s $self->{tmpfile}); - open(IN, $self->{tmpfile}) + open(IN, "<", $self->{tmpfile}) or $self->error($self->cleanup . "$self->{tmpfile} : $!"); binmode IN; @@ -1377,7 +1407,7 @@ 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} : $!"); + open OUT, '>', $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!"); print OUT while ; close OUT; seek IN, 0, 0; @@ -1506,12 +1536,17 @@ sub generate_email_subject { sub cleanup { $main::lxdebug->enter_sub(); - my $self = shift; + my ($self, $application) = @_; + + my $error_code = $?; chdir("$self->{tmpdir}"); my @err = (); - if (-f "$self->{tmpfile}.err") { + if ((-1 == $error_code) || (127 == (($error_code) >> 8))) { + push @err, $::locale->text('The application "#1" was not found on the system.', $application || 'pdflatex') . ' ' . $::locale->text('Please contact your administrator.'); + + } elsif (-f "$self->{tmpfile}.err") { open(FH, "$self->{tmpfile}.err"); @err = ; close(FH); @@ -1582,7 +1617,7 @@ sub dbconnect { my ($self, $myconfig) = @_; # connect to database - my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options) + my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options) or $self->dberror; # set db options @@ -1601,7 +1636,7 @@ sub dbconnect_noauto { my ($self, $myconfig) = @_; # connect to database - my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0)) + my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0)) or $self->dberror; # set db options @@ -1639,7 +1674,24 @@ sub date_closed { my $dbh = $self->dbconnect($myconfig); my $query = "SELECT 1 FROM defaults WHERE ? < closedto"; - my $sth = prepare_execute_query($self, $dbh, $query, $date); + 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: + # Leere Datumseingabe i.O. + # SELECT 1 FROM defaults WHERE '' < closedto + # normale Zahlungsbuchung über Rechnungsmaske i.O. + # SELECT 1 FROM defaults WHERE '10.05.2011' < closedto + # 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. + # SELECT 1 FROM defaults WHERE '21.04.2011' < closedto + # 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 + my ($closed) = $sth->fetchrow_array; $main::lxdebug->leave_sub(); @@ -1854,12 +1906,12 @@ sub set_payment_options { my $dbh = $self->get_standard_dbh($myconfig); my $query = - qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | . + qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long , p.description | . qq|FROM payment_terms p | . qq|WHERE p.id = ?|; ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto}, - $self->{payment_terms}) = + $self->{payment_terms}, $self->{payment_description}) = selectrow_query($self, $dbh, $query, $self->{payment_id}); if ($transdate eq "") { @@ -1906,10 +1958,12 @@ sub set_payment_options { if ($self->{"language_id"}) { $query = - qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | . - qq|FROM translation_payment_terms t | . + qq|SELECT t.translation, l.output_numberformat, l.output_dateformat, l.output_longdates | . + qq|FROM generic_translations t | . qq|LEFT JOIN language l ON t.language_id = l.id | . - qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|; + qq|WHERE (t.language_id = ?) + AND (t.translation_id = ?) + AND (t.translation_type = 'SL::DB::PaymentTerm/description_long')|; my ($description_long, $output_numberformat, $output_dateformat, $output_longdates) = selectrow_query($self, $dbh, $query, @@ -2383,7 +2437,7 @@ $main::lxdebug->enter_sub(); $key = "all_payments" unless ($key); - my $query = qq|SELECT * FROM payment_terms ORDER BY id|; + my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|; $self->{$key} = selectall_hashref_query($self, $dbh, $query); @@ -2461,7 +2515,8 @@ sub _get_warehouses { $self->{$key} = selectall_hashref_query($self, $dbh, $query); if ($bins_key) { - $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|; + $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ? + ORDER BY description|; my $sth = prepare_query($self, $dbh, $query); foreach my $warehouse (@{ $self->{$key} }) { @@ -2699,19 +2754,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); @@ -2782,15 +2829,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); @@ -2830,11 +2871,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); @@ -2878,6 +2936,7 @@ sub create_links { a.duedate, a.ordnumber, a.taxincluded, a.curr 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, c.name AS $table, d.description AS department, e.name AS employee @@ -2892,6 +2951,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}); @@ -2934,7 +2996,7 @@ sub create_links { $query = qq|SELECT c.accno, c.description, - a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey, + a.acc_trans_id, a.source, a.amount, a.memo, a.transdate, a.gldate, a.cleared, a.project_id, a.taxkey, p.projectnumber, t.rate, t.id FROM acc_trans a @@ -3068,6 +3130,9 @@ sub lastname_used { map { $self->{$_} = $ref->{$_} } values %column_map; + # remove any trailing whitespace + $self->{currency} =~ s/\s*$// if $self->{currency}; + $main::lxdebug->leave_sub(); } @@ -3801,7 +3866,7 @@ Examples: =head2 C
Generates a general purpose http/html header and includes most of the scripts -ans stylesheets needed. +and stylesheets needed. Stylesheets can be added with L. Only one header will be generated. If the method was already called in this request it will not output anything and return undef. Also if no @@ -3821,9 +3886,8 @@ default to 3 seconds and the refering url. =item stylesheet -=item stylesheets - -If these are arrayrefs the contents will be inlined into the header. +Either a scalar or an array ref. Will be inlined into the header. Add +stylesheets with the L function. =item landscape