X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FForm.pm;h=56e46f798d12f7aadc6f311bd1cf4626822ba00c;hb=b364553bd1c69d15999e3269649fa9a8b55eb8c3;hp=73a495a9ac6af23efa9708d04c2444b9d1420ca7;hpb=6826e7edeec9911b976fe54229f1e6275ee43c9e;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index 73a495a9a..56e46f798 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -36,6 +36,7 @@ #====================================================================== package Form; + use Data::Dumper; use CGI; @@ -53,15 +54,22 @@ use SL::Menu; use SL::Template; use SL::User; use Template; +use URI; use List::Util qw(first max min sum); +use List::MoreUtils qw(any); + +use strict; my $standard_dbh; -sub DESTROY { - if ($standard_dbh) { - $standard_dbh->disconnect(); - undef $standard_dbh; - } +END { + disconnect_standard_dbh(); +} + +sub disconnect_standard_dbh { + return unless $standard_dbh; + $standard_dbh->disconnect(); + undef $standard_dbh; } sub _store_value { @@ -71,30 +79,29 @@ sub _store_value { my $key = shift; my $value = shift; - my $curr = $self; + my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key; - while ($key =~ /\[\+?\]\.|\./) { - substr($key, 0, $+[0]) = ''; + my $curr; - if ($& eq '.') { - $curr->{$`} ||= { }; - $curr = $curr->{$`}; + if (scalar @tokens) { + $curr = \ $self->{ shift @tokens }; + } - } else { - $curr->{$`} ||= [ ]; - if (!scalar @{ $curr->{$`} } || $& eq '[+].') { - push @{ $curr->{$`} }, { }; - } + while (@tokens) { + my $sep = shift @tokens; + my $key = shift @tokens; - $curr = $curr->{$`}->[-1]; - } + $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->{$key} = $value; + $$curr = $value; $main::lxdebug->leave_sub(2); - return \$curr->{$key}; + return $curr; } sub _input_to_hash { @@ -107,7 +114,7 @@ sub _input_to_hash { foreach (@pairs) { my ($key, $value) = split(/=/, $_, 2); - $self->_store_value($self->unescape($key), $self->unescape($value)); + $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key); } $main::lxdebug->leave_sub(2); @@ -170,7 +177,7 @@ sub _request_to_hash { substr $line, $-[0], $+[0] - $-[0], ""; } - $previous = $self->_store_value($name, ''); + $previous = $self->_store_value($name, '') if ($name); $self->{FILENAME} = $filename if ($filename); next; @@ -193,6 +200,37 @@ sub _request_to_hash { $main::lxdebug->leave_sub(2); } +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(); @@ -205,24 +243,33 @@ sub new { tie %{ $self }, 'SL::Watchdog'; } - read(STDIN, $_, $ENV{CONTENT_LENGTH}); + bless $self, $type; - if ($ENV{QUERY_STRING}) { - $_ = $ENV{QUERY_STRING}; - } + $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING}; + $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0]; - if ($ARGV[0]) { - $_ = $ARGV[0]; + if ($ENV{CONTENT_LENGTH}) { + my $content; + read STDIN, $content, $ENV{CONTENT_LENGTH}; + $self->_request_to_hash($content); } - bless $self, $type; + my $db_charset = $main::dbcharset; + $db_charset ||= Common::DEFAULT_CHARSET; - $self->_request_to_hash($_); + my $encoding = $self->{INPUT_ENCODING} || $db_charset; + delete $self->{INPUT_ENCODING}; + + _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self); $self->{action} = lc $self->{action}; $self->{action} =~ s/( |-|,|\#)/_/g; - $self->{version} = "2.4.3"; + #$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; + $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code. $main::lxdebug->leave_sub(); @@ -355,28 +402,33 @@ sub unescape { } sub quote { + $main::lxdebug->enter_sub(); my ($self, $str) = @_; if ($str && !ref($str)) { $str =~ s/\"/"/g; } - $str; + $main::lxdebug->leave_sub(); + return $str; } sub unquote { + $main::lxdebug->enter_sub(); my ($self, $str) = @_; if ($str && !ref($str)) { $str =~ s/"/\"/g; } - $str; + $main::lxdebug->leave_sub(); + return $str; } sub hide_form { + $main::lxdebug->enter_sub(); my $self = shift; if (@_) { @@ -387,7 +439,7 @@ sub hide_form { print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } } - + $main::lxdebug->leave_sub(); } sub error { @@ -401,8 +453,8 @@ sub error { $self->show_generic_error($msg); } else { - - die "Error: $msg\n"; + print STDERR "Error: $msg\n"; + ::end_of_request(); } $main::lxdebug->leave_sub(); @@ -418,13 +470,22 @@ sub info { if (!$self->{header}) { $self->header; - print qq| - |; + print qq||; } print qq| - -

$msg +

$msg

+ + + + |; } else { @@ -481,6 +542,40 @@ sub isblank { $main::lxdebug->leave_sub(); } +sub _get_request_uri { + my $self = shift; + + return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR}; + + my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http'; + my $port = $ENV{SERVER_PORT} || ''; + $port = undef if (($scheme eq 'http' ) && ($port == 80)) + || (($scheme eq 'https') && ($port == 443)); + + my $uri = URI->new("${scheme}://"); + $uri->scheme($scheme); + $uri->port($port); + $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR}); + $uri->path_query($ENV{REQUEST_URI}); + $uri->query(''); + + return $uri; +} + +sub _add_to_request_uri { + my $self = shift; + + my $relative_new_path = shift; + my $request_uri = shift || $self->_get_request_uri; + my $relative_new_uri = URI->new($relative_new_path); + my @request_segments = $request_uri->path_segments; + + my $new_uri = $request_uri->clone; + $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments); + + return $new_uri; +} + sub create_http_response { $main::lxdebug->enter_sub(); @@ -490,25 +585,20 @@ sub create_http_response { my $cgi = $main::cgi; $cgi ||= CGI->new(''); - my $base_path; - - if ($ENV{HTTP_X_FORWARDED_FOR}) { - $base_path = $ENV{HTTP_REFERER}; - $base_path =~ s|^.*?://.*?/|/|; - } else { - $base_path = $ENV{REQUEST_URI}; - } - $base_path =~ s|[^/]+$||; - $base_path =~ s|/$||; - my $session_cookie; if (defined $main::auth) { + my $uri = $self->_get_request_uri; + my @segments = $uri->path_segments; + pop @segments; + $uri->path_segments(@segments); + 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' => $uri->path, + '-secure' => $ENV{HTTPS}); } my %cgi_params = ('-type' => $params{content_type}); @@ -526,6 +616,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}) { @@ -533,7 +625,7 @@ sub header { return; } - my ($stylesheet, $favicon); + my ($stylesheet, $favicon, $pagelayout); if ($ENV{HTTP_USER_AGENT}) { my $doctype; @@ -570,13 +662,36 @@ sub header { |; } - my $fokus = qq| document.$self->{fokus}.focus();| if ($self->{"fokus"}); + my $fokus = qq| + + | if $self->{"fokus"}; + + # if there is a title, we put some JavaScript in to the page, wich writes a + # meaningful title-tag for our frameset. + my $title_hack; + if ($self->{"title"}){ + $title_hack = qq| + + |; + } #Set Calendar my $jsscript = ""; if ($self->{jsscript} == 1) { $jsscript = qq| + @@ -591,7 +706,7 @@ sub header { ? "$self->{title} - $self->{titlebar}" : $self->{titlebar}; my $ajax = ""; - foreach $item (@ { $self->{AJAX} }) { + for my $item (@ { $self->{AJAX} || [] }) { $ajax .= $item->show_javascript(); } @@ -606,26 +721,21 @@ sub header { $favicon $jsscript $ajax + $fokus + $title_hack - + - - + @@ -653,38 +763,59 @@ sub ajax_response_header { return $output; } +sub redirect_header { + my $self = shift; + my $new_url = shift; + + my $base_uri = $self->_get_request_uri; + my $new_uri = URI->new_abs($new_url, $base_uri); + + die "Headers already sent" if $::self->{header}; + $self->{header} = 1; + + my $cgi = $main::cgi || CGI->new(''); + return $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} .= "- $::myconfig{name}" if $::myconfig{name}; + $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name}; + + $::lxdebug->leave_sub; +} + sub _prepare_html_template { $main::lxdebug->enter_sub(); 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"}; } $language = "de" unless ($language); - if (-f "templates/webpages/${file}_${language}.html") { - if ((-f ".developer") && - (-f "templates/webpages/${file}_master.html") && - ((stat("templates/webpages/${file}_master.html"))[9] > - (stat("templates/webpages/${file}_${language}.html"))[9])) { - my $info = "Developer information: templates/webpages/${file}_master.html is newer than the localized version.\n" . + 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
|); - die($info); + ::end_of_request(); } - $file = "templates/webpages/${file}_${language}.html"; - } elsif (-f "templates/webpages/${file}.html") { $file = "templates/webpages/${file}.html"; + } else { my $info = "Web page template '${file}' not found.\n" . "Please re-run 'locales.pl' in 'locale/${language}'."; print(qq|
$info
|); - die($info); + ::end_of_request(); } if ($self->{"DEBUG"}) { @@ -703,6 +834,7 @@ sub _prepare_html_template { $jsc_dateformat =~ s/m+/\%m/gi; $jsc_dateformat =~ s/y+/\%Y/gi; $additional_params->{"myconfig_jsc_dateformat"} = $jsc_dateformat; + $additional_params->{"myconfig"} ||= \%::myconfig; } $additional_params->{"conf_dbcharset"} = $main::dbcharset; @@ -710,6 +842,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; @@ -733,41 +867,40 @@ sub parse_html_template { $additional_params ||= { }; - $file = $self->_prepare_html_template($file, $additional_params); - - my $template = Template->new({ 'INTERPOLATE' => 0, - 'EVAL_PERL' => 0, - 'ABSOLUTE' => 1, - 'CACHE_SIZE' => 0, - 'PLUGIN_BASE' => 'SL::Template::Plugin', - 'INCLUDE_PATH' => '.:templates/webpages', - }) || die; + my $real_file = $self->_prepare_html_template($file, $additional_params); + my $template = $self->template || $self->init_template; map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self }; - my $in = IO::File->new($file, 'r'); + my $output; + $template->process($real_file, $additional_params, \$output) || die $template->error; - if (!$in) { - print STDERR "Error opening template file: $!"; - $main::lxdebug->leave_sub(); - return ''; - } + $main::lxdebug->leave_sub(); - my $input = join('', <$in>); - $in->close(); + return $output; +} - if ($main::locale) { - $input = $main::locale->{iconv}->convert($input); - } +sub init_template { + my $self = shift; - my $output; - if (!$template->process(\$input, $additional_params, \$output)) { - print STDERR $template->error(); - } + return if $self->template; - $main::lxdebug->leave_sub(); + return $self->template(Template->new({ + 'INTERPOLATE' => 0, + 'EVAL_PERL' => 0, + 'ABSOLUTE' => 1, + 'CACHE_SIZE' => 0, + 'PLUGIN_BASE' => 'SL::Template::Plugin', + 'INCLUDE_PATH' => '.:templates/webpages', + 'COMPILE_EXT' => '.tcc', + 'COMPILE_DIR' => $::userspath . '/templates-cache', + })) || die; +} - return $output; +sub template { + my $self = shift; + $self->{template_object} = shift if @_; + return $self->{template_object}; } sub show_generic_error { @@ -794,14 +927,16 @@ sub show_generic_error { $add_params->{SHOW_BACK_BUTTON} = 1; } - $self->{title} = $title if ($title); + $self->{title} = $params{title} if $params{title}; $self->header(); print $self->parse_html_template("generic/error", $add_params); + print STDERR "Error: $error\n"; + $main::lxdebug->leave_sub(); - die("Error: $error\n"); + ::end_of_request(); } sub show_generic_information { @@ -821,7 +956,7 @@ sub show_generic_information { $main::lxdebug->leave_sub(); - die("Information: $error\n"); + ::end_of_request(); } # write Trigger JavaScript-Code ($qty = quantity of Triggers) @@ -844,8 +979,8 @@ sub write_trigger { "yyyy-mm-dd" => "%Y-%m-%d", ); - my $ifFormat = defined($dateformats{$myconfig{"dateformat"}}) ? - $dateformats{$myconfig{"dateformat"}} : "%d.%m.%Y"; + my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ? + $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y"; my @triggers; while ($#_ >= 2) { @@ -876,19 +1011,19 @@ sub redirect { my ($self, $msg) = @_; - if ($self->{callback}) { - - ($script, $argv) = split(/\?/, $self->{callback}, 2); - $script =~ s|.*/||; - $script =~ s|[^a-zA-Z0-9_\.]||g; - exec("perl", "$script", $argv); - - } else { + if (!$self->{callback}) { $self->info($msg); - exit; + ::end_of_request(); } +# my ($script, $argv) = split(/\?/, $self->{callback}, 2); +# $script =~ s|.*/||; +# $script =~ s|[^a-zA-Z0-9_\.]||g; +# exec("perl", "$script", $argv); + + print $::form->redirect_header($self->{callback}); + $main::lxdebug->leave_sub(); } @@ -911,12 +1046,12 @@ sub format_amount { if ($amount eq "") { $amount = 0; } - + # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13 - + my $neg = ($amount =~ s/^-//); my $exp = ($amount =~ m/[e]/) ? 1 : 0; - + if (defined($places) && ($places ne '')) { if (not $exp) { if ($places < 0) { @@ -940,9 +1075,9 @@ sub format_amount { $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne ''); $amount = do { - ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) : - ($dash =~ /DRCR/) ? ($neg ? "$amount DR" : "$amount CR" ) : - ($neg ? "-$amount" : "$amount" ) ; + ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) : + ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) : + ($neg ? "-$amount" : "$amount" ) ; }; @@ -988,6 +1123,7 @@ sub format_amount_units { $amount *= $conv_unit->{factor}; my @values; + my $num; foreach my $unit (@$conv_units) { my $last = $unit->{name} eq $part_unit->{name}; @@ -1063,13 +1199,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); @@ -1082,36 +1218,56 @@ sub parse_template { $main::lxdebug->enter_sub(); my ($self, $myconfig, $userspath) = @_; - my ($template, $out); + my $out; local (*IN, *OUT); $self->{"cwd"} = getcwd(); $self->{"tmpdir"} = $self->{cwd} . "/${userspath}"; + my $ext_for_format; + + my $template_type; if ($self->{"format"} =~ /(opendocument|oasis)/i) { - $template = OpenDocumentTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $template_type = 'OpenDocument'; + $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt'; + } elsif ($self->{"format"} =~ /(postscript|pdf)/i) { $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"}; - $template = LaTeXTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); - } elsif (($self->{"format"} =~ /html/i) || - (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) { - $template = HTMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); - } elsif (($self->{"format"} =~ /xml/i) || - (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) { - $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); - } elsif ( $self->{"format"} =~ /elsterwinston/i ) { - $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); - } elsif ( $self->{"format"} =~ /elstertaxbird/i ) { - $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $template_type = 'LaTeX'; + $ext_for_format = 'pdf'; + + } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) { + $template_type = 'HTML'; + $ext_for_format = 'html'; + + } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) { + $template_type = 'XML'; + $ext_for_format = 'xml'; + + } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) { + $template_type = 'xml'; + + } elsif ( $self->{"format"} =~ /excel/i ) { + $template_type = 'Excel'; + $ext_for_format = 'xls'; + } elsif ( defined $self->{'format'}) { $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}"); + } elsif ( $self->{'format'} eq '' ) { $self->error("No Outputformat given: $self->{'format'}"); + } else { #Catch the rest $self->error("Outputformat not defined: $self->{'format'}"); } + my $template = SL::Template::create(type => $template_type, + file_name => $self->{IN}, + form => $self, + myconfig => $myconfig, + userspath => $userspath); + # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be. $self->{"notes"} = $self->{ $self->{"formname"} . "notes" }; @@ -1119,9 +1275,7 @@ sub parse_template { map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns); } - map({ $self->{"${_}"} = $myconfig->{$_}; } - qw(co_ustid)); - + map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid); $self->{copies} = 1 if (($self->{copies} *= 1) <= 0); @@ -1146,20 +1300,23 @@ sub parse_template { $self->{OUT} = ">$self->{tmpfile}"; } + my $result; + if ($self->{OUT}) { - open(OUT, "$self->{OUT}") or $self->error("$self->{OUT} : $!"); + open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!"); + $result = $template->parse(*OUT); + close OUT; + } else { - open(OUT, ">-") or $self->error("STDOUT : $!"); $self->header; + $result = $template->parse(*STDOUT); } - if (!$template->parse(*OUT)) { + if (!$result) { $self->cleanup(); $self->error("$self->{IN} : " . $template->get_error()); } - close(OUT); - if ($template->uses_temp_file() || $self->{media} eq 'email') { if ($self->{media} eq 'email') { @@ -1194,10 +1351,10 @@ sub parse_template { } else { if (!$self->{"do_not_attach"}) { - @{ $mail->{attachments} } = - ({ "filename" => $self->{"tmpfile"}, - "name" => $self->{"attachment_filename"} ? - $self->{"attachment_filename"} : $self->{"tmpfile"} }); + my $attachment_name = $self->{attachment_filename} || $self->{tmpfile}; + $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format); + $mail->{attachments} = [{ "filename" => $self->{tmpfile}, + "name" => $attachment_name }]; } $mail->{message} =~ s/\r//g; @@ -1223,10 +1380,13 @@ 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; + } else { - $self->{attachment_filename} = ($self->{attachment_filename}) + $self->{attachment_filename} = ($self->{attachment_filename}) ? $self->{attachment_filename} : $self->generate_attachment_filename(); @@ -1237,17 +1397,8 @@ Content-Length: $numbytes |; - open(OUT, ">-") or $self->error($self->cleanup . "$!: STDOUT"); - + $::locale->with_raw_io(\*STDOUT, sub { print while }); } - - while () { - print OUT $_; - } - - close(OUT); - - seek IN, 0, 0; } close(IN); @@ -1262,6 +1413,7 @@ Content-Length: $numbytes } sub get_formname_translation { + $main::lxdebug->enter_sub(); my ($self, $formname) = @_; $formname ||= $self->{formname}; @@ -1281,12 +1433,15 @@ sub get_formname_translation { storno_packing_list => $main::locale->text('Storno Packing List'), sales_delivery_order => $main::locale->text('Delivery Order'), purchase_delivery_order => $main::locale->text('Delivery Order'), + dunning => $main::locale->text('Dunning'), ); + $main::lxdebug->leave_sub(); return $formname_translations{$formname} } sub get_number_prefix_for_type { + $main::lxdebug->enter_sub(); my ($self) = @_; my $prefix = @@ -1295,22 +1450,27 @@ sub get_number_prefix_for_type { : ($self->{type} =~ /_delivery_order$/) ? 'do' : 'ord'; + $main::lxdebug->leave_sub(); return $prefix; } sub get_extension_for_format { + $main::lxdebug->enter_sub(); my ($self) = @_; 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" : ""; + $main::lxdebug->leave_sub(); return $extension; } sub generate_attachment_filename { + $main::lxdebug->enter_sub(); my ($self) = @_; my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation()); @@ -1329,10 +1489,12 @@ sub generate_attachment_filename { $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename); $attachment_filename =~ s|[\s/\\]+|_|g; + $main::lxdebug->leave_sub(); return $attachment_filename; } sub generate_email_subject { + $main::lxdebug->enter_sub(); my ($self) = @_; my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation()); @@ -1342,6 +1504,7 @@ sub generate_email_subject { $subject .= " " . $self->{"${prefix}number"} } + $main::lxdebug->leave_sub(); return $subject; } @@ -1359,7 +1522,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; @@ -1378,6 +1541,7 @@ sub datetonum { $main::lxdebug->enter_sub(); my ($self, $date, $myconfig) = @_; + my ($yy, $mm, $dd); if ($date && $date =~ /\D/) { @@ -1409,15 +1573,21 @@ sub datetonum { # Database routines used throughout +sub _dbconnect_options { + my $self = shift; + my $options = { pg_enable_utf8 => $::locale->is_utf8, + @_ }; + + return $options; +} + sub dbconnect { $main::lxdebug->enter_sub(2); my ($self, $myconfig) = @_; # connect to database - my $dbh = - DBI->connect($myconfig->{dbconnect}, - $myconfig->{dbuser}, $myconfig->{dbpasswd}) + my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options) or $self->dberror; # set db options @@ -1434,11 +1604,9 @@ sub dbconnect_noauto { $main::lxdebug->enter_sub(); my ($self, $myconfig) = @_; - + # connect to database - $dbh = - DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, - $myconfig->{dbpasswd}, { AutoCommit => 0 }) + my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0)) or $self->dberror; # set db options @@ -1454,10 +1622,11 @@ sub dbconnect_noauto { sub get_standard_dbh { $main::lxdebug->enter_sub(2); - my ($self, $myconfig) = @_; + my $self = shift; + my $myconfig = shift || \%::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; } @@ -1515,7 +1684,7 @@ sub update_exchangerate { if ($curr eq '') { $main::lxdebug->leave_sub(); return; - } + } $query = qq|SELECT curr FROM defaults|; my ($currency) = selectrow_query($self, $dbh, $query); @@ -1556,7 +1725,7 @@ sub update_exchangerate { SET $set WHERE curr = ? AND transdate = ?|; - + } else { $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate) VALUES (?, $buy, $sell, ?)|; @@ -1625,6 +1794,10 @@ sub check_exchangerate { my ($self, $myconfig, $currency, $transdate, $fld) = @_; + if ($fld !~/^buy|sell$/) { + $self->error('Fatal: check_exchangerate called with invalid buy/sell argument'); + } + unless ($transdate) { $main::lxdebug->leave_sub(); return ""; @@ -1648,22 +1821,33 @@ sub check_exchangerate { return $exchangerate; } -sub get_default_currency { +sub get_all_currencies { $main::lxdebug->enter_sub(); - my ($self, $myconfig) = @_; - my $dbh = $self->get_standard_dbh($myconfig); + my $self = shift; + my $myconfig = shift || \%::myconfig; + my $dbh = $self->get_standard_dbh($myconfig); 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(); @@ -1712,6 +1896,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; @@ -1765,6 +1950,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(); } @@ -1867,7 +2054,7 @@ sub add_shipto { shiptophone = ? AND shiptofax = ? AND shiptoemail = ? AND - module = ? AND + module = ? AND trans_id = ?|; my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id); if(!$insert_check){ @@ -1889,6 +2076,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; @@ -1929,13 +2118,17 @@ sub get_employee_data { sub get_duedate { $main::lxdebug->enter_sub(); - my ($self, $myconfig) = @_; + my ($self, $myconfig, $reference_date) = @_; - my $dbh = $self->get_standard_dbh($myconfig); - my $query = qq|SELECT current_date + terms_netto FROM payment_terms WHERE id = ?|; - ($self->{duedate}) = selectrow_query($self, $dbh, $query, $self->{payment_id}); + $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}); $main::lxdebug->leave_sub(); + + return $duedate; } sub _get_contacts { @@ -2050,6 +2243,7 @@ sub _get_charts { $main::lxdebug->enter_sub(); my ($self, $dbh, $params) = @_; + my ($key); $key = $params->{key}; $key = "all_charts" unless ($key); @@ -2057,7 +2251,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 | . @@ -2073,11 +2267,27 @@ sub _get_charts { sub _get_taxcharts { $main::lxdebug->enter_sub(); - my ($self, $dbh, $key) = @_; + my ($self, $dbh, $params) = @_; - $key = "all_taxcharts" unless ($key); + my $key = "all_taxcharts"; + my @where; - my $query = qq|SELECT * FROM tax ORDER BY taxkey|; + if (ref $params eq 'HASH') { + $key = $params->{key} if ($params->{key}); + if ($params->{module} eq 'AR') { + push @where, 'taxkey NOT IN (8, 9, 18, 19)'; + + } elsif ($params->{module} eq 'AP') { + push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)'; + } + + } elsif ($params) { + $key = $params; + } + + my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where); + + my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|; $self->{$key} = selectall_hashref_query($self, $dbh, $query); @@ -2114,9 +2324,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(); } @@ -2157,7 +2373,7 @@ $main::lxdebug->enter_sub(); $key = "all_currencies" unless ($key); my $query = qq|SELECT curr AS currency FROM defaults|; - + $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})]; $main::lxdebug->leave_sub(); @@ -2171,7 +2387,7 @@ $main::lxdebug->enter_sub(); $key = "all_payments" unless ($key); my $query = qq|SELECT * FROM payment_terms ORDER BY id|; - + $self->{$key} = selectall_hashref_query($self, $dbh, $query); $main::lxdebug->leave_sub(); @@ -2180,14 +2396,19 @@ $main::lxdebug->enter_sub(); sub _get_customers { $main::lxdebug->enter_sub(); - my ($self, $dbh, $key, $limit) = @_; + my ($self, $dbh, $key) = @_; - $key = "all_customers" unless ($key); - $limit_clause = "LIMIT $limit" if $limit; + my $options = ref $key eq 'HASH' ? $key : { key => $key }; + $options->{key} ||= "all_customers"; + my $limit_clause = "LIMIT $options->{limit}" if $options->{limit}; - my $query = qq|SELECT * FROM customer WHERE NOT obsolete ORDER BY name $limit_clause|; + my @where; + push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman}; + push @where, qq|NOT obsolete| if !$options->{with_obsolete}; + my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : ''; - $self->{$key} = selectall_hashref_query($self, $dbh, $query); + my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|; + $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query); $main::lxdebug->leave_sub(); } @@ -2273,19 +2494,19 @@ sub _get_simple { $main::lxdebug->leave_sub(); } -sub _get_groups { - $main::lxdebug->enter_sub(); - - my ($self, $dbh, $key) = @_; - - $key ||= "all_groups"; - - my $groups = $main::auth->read_groups(); - - $self->{$key} = selectall_hashref_query($self, $dbh, $query); - - $main::lxdebug->leave_sub(); -} +#sub _get_groups { +# $main::lxdebug->enter_sub(); +# +# my ($self, $dbh, $key) = @_; +# +# $key ||= "all_groups"; +# +# my $groups = $main::auth->read_groups(); +# +# $self->{$key} = selectall_hashref_query($self, $dbh, $query); +# +# $main::lxdebug->leave_sub(); +#} sub get_lists { $main::lxdebug->enter_sub(); @@ -2336,7 +2557,7 @@ sub get_lists { if ($params{"employees"}) { $self->_get_employees($dbh, "all_employees", $params{"employees"}); } - + if ($params{"salesmen"}) { $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"}); } @@ -2348,19 +2569,15 @@ sub get_lists { if ($params{"dunning_configs"}) { $self->_get_dunning_configs($dbh, $params{"dunning_configs"}); } - + if($params{"currencies"}) { $self->_get_currencies($dbh, $params{"currencies"}); } - + 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"}) { if (ref $params{"vendors"} eq 'HASH') { $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit}); @@ -2368,7 +2585,7 @@ sub get_lists { $self->_get_vendors($dbh, $params{"vendors"}); } } - + if($params{"payments"}) { $self->_get_payments($dbh, $params{"payments"}); } @@ -2385,9 +2602,10 @@ sub get_lists { $self->_get_warehouses($dbh, $params{warehouses}); } - if ($params{groups}) { - $self->_get_groups($dbh, $params{groups}); - } +# if ($params{groups}) { +# $self->_get_groups($dbh, $params{groups}); +# } + if ($params{partsgroup}) { $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} }); } @@ -2451,7 +2669,7 @@ sub all_vc { my ($self, $myconfig, $table, $module) = @_; my $ref; - my $dbh = $self->get_standard_dbh($myconfig); + my $dbh = $self->get_standard_dbh; $table = $table eq "customer" ? "customer" : "vendor"; @@ -2459,7 +2677,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|; @@ -2579,7 +2797,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(); } @@ -2626,7 +2844,7 @@ sub create_links { do_statement($self, $sth, $query, '%' . $module . '%'); $self->{accounts} = ""; - while ($ref = $sth->fetchrow_hashref(NAME_lc)) { + while ($ref = $sth->fetchrow_hashref("NAME_lc")) { foreach my $key (split(/:/, $ref->{link})) { if ($key =~ /\Q$module\E/) { @@ -2673,7 +2891,7 @@ sub create_links { WHERE a.id = ?|; $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id}); - foreach $key (keys %$ref) { + foreach my $key (keys %$ref) { $self->{$key} = $ref->{$key}; } @@ -2695,7 +2913,7 @@ sub create_links { do_statement($self, $sth, $query, "%$module%"); $self->{accounts} = ""; - while ($ref = $sth->fetchrow_hashref(NAME_lc)) { + while ($ref = $sth->fetchrow_hashref("NAME_lc")) { foreach my $key (split(/:/, $ref->{link})) { if ($key =~ /\Q$module\E/) { @@ -2735,7 +2953,7 @@ sub create_links { (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1)) WHERE a.trans_id = ? AND a.fx_transaction = '0' - ORDER BY a.oid, a.transdate|; + ORDER BY a.acc_trans_id, a.transdate|; $sth = $dbh->prepare($query); do_statement($self, $sth, $query, $self->{id}); @@ -2745,7 +2963,7 @@ sub create_links { my $index = 0; # store amounts in {acc_trans}{$key} for multiple accounts - while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { + while (my $ref = $sth->fetchrow_hashref("NAME_lc")) { $ref->{exchangerate} = $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld); if (!($xkeyref{ $ref->{accno} } =~ /tax/)) { @@ -2859,7 +3077,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; @@ -2911,7 +3131,7 @@ sub redo_rows { # fill rows foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) { $i++; - $j = $item->{ndx} - 1; + my $j = $item->{ndx} - 1; map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds}; } @@ -3061,8 +3281,8 @@ sub save_status { sub save_history { $main::lxdebug->enter_sub(); - my $self = shift(); - my $dbh = shift(); + my $self = shift; + my $dbh = shift || $self->get_standard_dbh; if(!exists $self->{employee_id}) { &get_employee($self, $dbh); @@ -3075,6 +3295,8 @@ sub save_history { $self->{addition}, $self->{what_done}, "$self->{snumbers}"); do_query($self, $dbh, $query, @values); + $dbh->commit; + $main::lxdebug->leave_sub(); } @@ -3091,10 +3313,9 @@ sub get_history { qq|SELECT h.employee_id, h.itime::timestamp(0) AS itime, h.addition, h.what_done, emp.name, h.snumbers, h.trans_id AS id | . qq|FROM history_erp h | . qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | . - qq|WHERE trans_id = | . $trans_id - . $restriction . qq| | - . $order; - + qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | . + $order; + my $sth = $dbh->prepare($query) || $self->dberror($query); $sth->execute() || $self->dberror("$query"); @@ -3105,7 +3326,7 @@ sub get_history { $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g; $tempArray[$i++] = $hash_ref; } - $main::lxdebug->leave_sub() and return \@tempArray + $main::lxdebug->leave_sub() and return \@tempArray if ($i > 0 && $tempArray[0] ne ""); } $main::lxdebug->leave_sub(); @@ -3168,6 +3389,8 @@ sub update_business { WHERE id = ? FOR UPDATE|; my ($var) = selectrow_query($self, $dbh, $query, $business_id); + return undef unless $var; + if ($var =~ m/\d+$/) { my $new_var = (substr $var, $-[0]) * 1 + 1; my $len_diff = length($var) - $-[0] - length($new_var); @@ -3306,7 +3529,7 @@ sub backup_vars { my $self = shift; my @vars = @_; - map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if $self->{$_} } @vars; + map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars; $main::lxdebug->leave_sub(); } @@ -3317,9 +3540,113 @@ sub restore_vars { my $self = shift; my @vars = @_; - map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if $self->{_VAR_BACKUP}->{$_} } @vars; + map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars; $main::lxdebug->leave_sub(); } 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. + +=item redirect_header $url + +Generates a HTTP redirection header for the new C<$url>. Constructs an +absolute URL including scheme, host name and port. If C<$url> is a +relative URL then it is considered relative to Lx-Office base URL. + +This function Cs if headers have already been created with +C<$::form-Eheader>. + +Examples: + + print $::form->redirect_header('oe.pl?action=edit&id=1234'); + print $::form->redirect_header('http://www.lx-office.org/'); + +=back + +=cut