X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/mfinanz.git/blobdiff_plain/bc4337116357a3daf6232fb3d921574cd995da2a..9434c14ab2cb7d10cbe20276d08771c43f9fffc1:/SL/Form.pm diff --git a/SL/Form.pm b/SL/Form.pm index a2835a203..dfff9b4f7 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -49,17 +49,24 @@ use SL::Auth; use SL::Auth::DB; use SL::Auth::LDAP; use SL::AM; -use SL::DB; use SL::Common; +use SL::CVar; +use SL::DB; +use SL::DBConnect; use SL::DBUtils; +use SL::DO; +use SL::IC; +use SL::IS; use SL::Mailer; 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); -use List::MoreUtils qw(any apply); +use List::MoreUtils qw(all any apply); use strict; @@ -128,6 +135,7 @@ sub _request_to_hash { my $self = shift; my $input = shift; + my $uploads = {}; if (!$ENV{'CONTENT_TYPE'} || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) { @@ -135,7 +143,7 @@ sub _request_to_hash { $self->_input_to_hash($input); $main::lxdebug->leave_sub(2); - return; + return $uploads; } my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous); @@ -180,7 +188,7 @@ sub _request_to_hash { substr $line, $-[0], $+[0] - $-[0], ""; } - $previous = $self->_store_value($name, '') if ($name); + $previous = _store_value($uploads, $name, '') if ($name); $self->{FILENAME} = $filename if ($filename); next; @@ -201,6 +209,8 @@ sub _request_to_hash { ${ $previous } =~ s|\r?\n$|| if $previous; $main::lxdebug->leave_sub(2); + + return $uploads; } sub _recode_recursively { @@ -251,13 +261,14 @@ sub new { $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}; - $self->_request_to_hash($content); + $uploads = $self->_request_to_hash($content); } - my $db_charset = $main::dbcharset; + my $db_charset = $::lx_office_conf{system}->{dbcharset}; $db_charset ||= Common::DEFAULT_CHARSET; my $encoding = $self->{INPUT_ENCODING} || $db_charset; @@ -265,6 +276,8 @@ sub new { _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} = ; @@ -380,7 +393,7 @@ sub escape { 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; + $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge; $main::lxdebug->leave_sub(2); @@ -396,6 +409,7 @@ sub unescape { $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); @@ -443,13 +457,23 @@ sub hide_form { $main::lxdebug->leave_sub(); } +sub throw_on_error { + my ($self, $code) = @_; + local $self->{__ERROR_HANDLER} = sub { die SL::X::FormError->new($_[0]) }; + $code->(); +} + sub error { $main::lxdebug->enter_sub(); $main::lxdebug->show_backtrace(); my ($self, $msg) = @_; - if ($ENV{HTTP_USER_AGENT}) { + + if ($self->{__ERROR_HANDLER}) { + $self->{__ERROR_HANDLER}->($msg); + + } elsif ($ENV{HTTP_USER_AGENT}) { $msg =~ s/\n/
/g; $self->show_generic_error($msg); @@ -607,6 +631,8 @@ 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); + my $output = $cgi->header(%cgi_params); $main::lxdebug->leave_sub(); @@ -621,7 +647,7 @@ sub header { # extra code is 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) = @_; - my $db_charset = $::dbcharset || Common::DEFAULT_CHARSET; + my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET; my @header; $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++; @@ -705,7 +731,7 @@ sub ajax_response_header { my ($self) = @_; - my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET; + my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET; my $cgi = $main::cgi || CGI->new(''); my $output = $cgi->header('-charset' => $db_charset); @@ -721,7 +747,7 @@ 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(''); @@ -746,20 +772,13 @@ sub _prepare_html_template { my $language; if (!%::myconfig || !$::myconfig{"countrycode"}) { - $language = $main::language; + $language = $::lx_office_conf{system}->{language}; } else { $language = $main::myconfig{"countrycode"}; } $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 { @@ -787,16 +806,16 @@ sub _prepare_html_template { map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig; } - $additional_params->{"conf_dbcharset"} = $::dbcharset; - $additional_params->{"conf_webdav"} = $::webdav; - $additional_params->{"conf_lizenzen"} = $::lizenzen; - $additional_params->{"conf_latex_templates"} = $::latex; - $additional_params->{"conf_opendocument_templates"} = $::opendocument_templates; - $additional_params->{"conf_vertreter"} = $::vertreter; - $additional_params->{"conf_show_best_before"} = $::show_best_before; - $additional_params->{"conf_parts_image_css"} = $::parts_image_css; - $additional_params->{"conf_parts_listing_images"} = $::parts_listing_images; - $additional_params->{"conf_parts_show_image"} = $::parts_show_image; + $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}; + $additional_params->{"conf_show_best_before"} = $::lx_office_conf{features}->{show_best_before}; + $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}; if (%main::debug_options) { map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options; @@ -846,7 +865,7 @@ sub init_template { 'PLUGIN_BASE' => 'SL::Template::Plugin', 'INCLUDE_PATH' => '.:templates/webpages', 'COMPILE_EXT' => '.tcc', - 'COMPILE_DIR' => $::userspath . '/templates-cache', + 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache', })) || die; } @@ -861,6 +880,12 @@ sub show_generic_error { my ($self, $error, %params) = @_; + if ($self->{__ERROR_HANDLER}) { + $self->{__ERROR_HANDLER}->($error); + $main::lxdebug->leave_sub(); + return; + } + my $add_params = { 'title_error' => $params{title}, 'label_error' => $error, @@ -965,17 +990,13 @@ sub redirect { 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 { + print $::form->redirect_header($self->{callback}); + } - print $::form->redirect_header($self->{callback}); + ::end_of_request(); $main::lxdebug->leave_sub(); } @@ -1170,11 +1191,13 @@ sub round_amount { sub parse_template { $main::lxdebug->enter_sub(); - my ($self, $myconfig, $userspath) = @_; + my ($self, $myconfig) = @_; my $out; local (*IN, *OUT); + my $userspath = $::lx_office_conf{paths}->{userspath}; + $self->{"cwd"} = getcwd(); $self->{"tmpdir"} = $self->{cwd} . "/${userspath}"; @@ -1229,6 +1252,7 @@ sub parse_template { } map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid); + map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig }; $self->{copies} = 1 if (($self->{copies} *= 1) <= 0); @@ -1288,7 +1312,7 @@ sub parse_template { map { $mail->{$_} = $self->{$_} } qw(cc bcc subject message version format); - $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET; + $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."; @@ -1335,6 +1359,7 @@ sub parse_template { my $numbytes = (-s $self->{tmpfile}); open(IN, $self->{tmpfile}) or $self->error($self->cleanup . "$self->{tmpfile} : $!"); + binmode IN; $self->{copies} = 1 unless $self->{media} eq 'printer'; @@ -1483,7 +1508,7 @@ sub cleanup { close(FH); } - if ($self->{tmpfile} && ! $::keep_temp_files) { + if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) { $self->{tmpfile} =~ s|.*/||g; # strip extension $self->{tmpfile} =~ s/\.\w+$//g; @@ -1548,7 +1573,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 @@ -1567,7 +1592,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 @@ -1591,7 +1616,7 @@ sub get_standard_dbh { undef $standard_dbh; } - $standard_dbh ||= SL::DB::create->dbh; + $standard_dbh ||= $self->dbconnect_noauto($myconfig); $main::lxdebug->leave_sub(2); @@ -1605,7 +1630,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(); @@ -1872,10 +1914,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, @@ -2349,7 +2393,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); @@ -2427,7 +2471,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} }) { @@ -3507,6 +3552,89 @@ sub restore_vars { $main::lxdebug->leave_sub(); } +sub prepare_for_printing { + my ($self) = @_; + + $self->{templates} ||= $::myconfig{templates}; + $self->{formname} ||= $self->{type}; + $self->{media} ||= 'email'; + + die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/; + + # set shipto from billto unless set + my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact); + if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) { + $self->{shiptoname} = $::myconfig{company}; + $self->{shiptostreet} = $::myconfig{address}; + } + + my $language = $self->{language} ? '_' . $self->{language} : ''; + + my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates); + if ($self->{language_id}) { + ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id}); + } else { + $output_dateformat = $::myconfig{dateformat}; + $output_numberformat = $::myconfig{numberformat}; + $output_longdates = 1; + } + + # Retrieve accounts for tax calculation. + IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount}); + + if ($self->{type} =~ /_delivery_order$/) { + DO->order_details(); + } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) { + OE->order_details(\%::myconfig, $self); + } else { + IS->invoice_details(\%::myconfig, $self, $::locale); + } + + # Chose extension & set source file name + my $extension = 'html'; + if ($self->{format} eq 'postscript') { + $self->{postscript} = 1; + $extension = 'tex'; + } elsif ($self->{"format"} =~ /pdf/) { + $self->{pdf} = 1; + $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex'; + } elsif ($self->{"format"} =~ /opendocument/) { + $self->{opendocument} = 1; + $extension = 'odt'; + } elsif ($self->{"format"} =~ /excel/) { + $self->{excel} = 1; + $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}"; + $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}"; + + # Format dates. + $self->format_dates($output_dateformat, $output_longdates, + qw(invdate orddate quodate pldate duedate reqdate transdate 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}))); + + $self->reformat_numbers($output_numberformat, 2, + qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid), + grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self}))); + + $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self}))); + + my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_'); + + if (scalar @{ $cvar_date_fields }) { + $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields }); + } + + while (my ($precision, $field_list) = each %{ $cvar_number_fields }) { + $self->reformat_numbers($output_numberformat, $precision, @{ $field_list }); + } + + return $self; +} + sub format_dates { my ($self, $dateformat, $longformat, @indices) = @_;