$self->{titlebar}

X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FForm.pm;h=6b1ee5009f2aeb16548934aa4319f63ded479a37;hb=fededc52e1b1c530a7e0f1e11c0268862d0c3581;hp=905c629dbdae887c4c1100d0e6570ed51c1aae0a;hpb=0519635df1f3b84e4c86acb3c251deb051055c3a;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index 905c629db..6b1ee5009 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -42,6 +42,7 @@ use Data::Dumper; use CGI; use CGI::Ajax; use Cwd; +use Encode; use IO::File; use SL::Auth; use SL::Auth::DB; @@ -54,18 +55,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 List::MoreUtils qw(any apply); use strict; my $standard_dbh; END { - if ($standard_dbh) { - $standard_dbh->disconnect(); - undef $standard_dbh; - } + disconnect_standard_dbh(); +} + +sub disconnect_standard_dbh { + return unless $standard_dbh; + $standard_dbh->disconnect(); + undef $standard_dbh; } sub _store_value { @@ -239,38 +244,30 @@ 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; - - $self->_request_to_hash($_); - my $db_charset = $main::dbcharset; $db_charset ||= Common::DEFAULT_CHARSET; - if ($self->{INPUT_ENCODING}) { - if (lc $self->{INPUT_ENCODING} ne lc $db_charset) { - require Text::Iconv; - my $iconv = Text::Iconv->new($self->{INPUT_ENCODING}, $db_charset); + my $encoding = $self->{INPUT_ENCODING} || $db_charset; + delete $self->{INPUT_ENCODING}; - _recode_recursively($iconv, $self); - } + _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self); - delete $self->{INPUT_ENCODING}; - } - - $self->{action} = lc $self->{action}; - $self->{action} =~ s/( |-|,|\#)/_/g; - - $self->{version} = "2.6.0"; + #$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(); @@ -380,6 +377,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; $main::lxdebug->leave_sub(2); @@ -396,6 +394,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); @@ -454,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(); @@ -471,13 +470,22 @@ sub info { if (!$self->{header}) { $self->header; - print qq| - |; + print qq||; } print qq| +

$msg

+ + -

$msg + |; } else { @@ -534,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(); @@ -543,33 +585,28 @@ 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 $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, - '-secure' => $ENV{HTTPS}); + 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(); + + if ($session_cookie_value) { + $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}); $cgi_params{'-charset'} = $params{charset} if ($params{charset}); + $cgi_params{'-cookie'} = $session_cookie if ($session_cookie); - my $output = $cgi->header('-cookie' => $session_cookie, - %cgi_params); + my $output = $cgi->header(%cgi_params); $main::lxdebug->leave_sub(); @@ -578,107 +615,71 @@ sub create_http_response { sub header { - $main::lxdebug->enter_sub(); + $::lxdebug->enter_sub; - # extra code ist currently only used by menuv3 and menuv4 to set their css. + # 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) = @_; - - if ($self->{header}) { - $main::lxdebug->leave_sub(); - return; - } - - my ($stylesheet, $favicon, $pagelayout); - - if ($ENV{HTTP_USER_AGENT}) { - my $doctype; - - if ($ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/) { - # Only set the DOCTYPE for Internet Explorer. Other browsers have problems displaying the menu otherwise. - $doctype = qq|\n|; - } - - my $stylesheets = "$self->{stylesheet} $self->{stylesheets}"; - - $stylesheets =~ s|^\s*||; - $stylesheets =~ s|\s*$||; - foreach my $file (split m/\s+/, $stylesheets) { - $file =~ s|.*/||; - next if (! -f "css/$file"); - - $stylesheet .= qq|\n|; - } - - $self->{favicon} = "favicon.ico" unless $self->{favicon}; - - if ($self->{favicon} && (-f "$self->{favicon}")) { - $favicon = - qq| - |; - } - - my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET; - - if ($self->{landscape}) { - $pagelayout = qq||; - } - - my $fokus = qq| + my $db_charset = $::dbcharset || Common::DEFAULT_CHARSET; + my @header; + + $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++; + + $self->{favicon} ||= "favicon.ico"; + $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title}; + + # build includes + if ($self->{refresh_url} || $self->{refresh_time}) { + my $refresh_time = $self->{refresh_time} || 3; + my $refresh_url = $self->{refresh_url} || $ENV{REFERER}; + push @header, ""; + } + + push @header, "" + for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets}; + + 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}; + push @header, sprintf "", + join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title}; + + # 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| - | if $self->{"fokus"}; - - #Set Calendar - my $jsscript = ""; - if ($self->{jsscript} == 1) { - - $jsscript = qq| - - - - - - - $self->{javascript} - |; - } - - $self->{titlebar} = - ($self->{title}) - ? "$self->{title} - $self->{titlebar}" - : $self->{titlebar}; - my $ajax = ""; - foreach my $item (@ { $self->{AJAX} }) { - $ajax .= $item->show_javascript(); - } + |; + } - print $self->create_http_response('content_type' => 'text/html', - 'charset' => $db_charset,); - print qq|${doctype} - - + # 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 < + + $self->{titlebar} - $stylesheet - $pagelayout - $favicon - $jsscript - $ajax - - $fokus - +EOT + print " $_\n" for @header; + print < - - - - $extra_code - + $title_hack + -|; - } - $self->{header} = 1; +EOT - $main::lxdebug->leave_sub(); + $::lxdebug->leave_sub; } sub ajax_response_header { @@ -714,38 +713,58 @@ 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); + my $info = "Web page template '${file}' not found.\n"; + print qq|

$info

|; + ::end_of_request(); } if ($self->{"DEBUG"}) { @@ -758,20 +777,25 @@ sub _prepare_html_template { } if (%main::myconfig) { - map({ $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys(%main::myconfig)); - my $jsc_dateformat = $main::myconfig{"dateformat"}; - $jsc_dateformat =~ s/d+/\%d/gi; - $jsc_dateformat =~ s/m+/\%m/gi; - $jsc_dateformat =~ s/y+/\%Y/gi; - $additional_params->{"myconfig_jsc_dateformat"} = $jsc_dateformat; - } - - $additional_params->{"conf_dbcharset"} = $main::dbcharset; - $additional_params->{"conf_webdav"} = $main::webdav; - $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; + $::myconfig{jsc_dateformat} = apply { + s/d+/\%d/gi; + s/m+/\%m/gi; + s/y+/\%Y/gi; + } $::myconfig{"dateformat"}; + $additional_params->{"myconfig"} ||= \%::myconfig; + 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; if (%main::debug_options) { map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options; @@ -795,41 +819,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 { @@ -861,9 +884,11 @@ sub show_generic_error { $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 { @@ -883,7 +908,7 @@ sub show_generic_information { $main::lxdebug->leave_sub(); - die("Information: $text\n"); + ::end_of_request(); } # write Trigger JavaScript-Code ($qty = quantity of Triggers) @@ -938,19 +963,19 @@ sub redirect { my ($self, $msg) = @_; - if ($self->{callback}) { - - my ($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(); } @@ -1145,7 +1170,7 @@ sub parse_template { $main::lxdebug->enter_sub(); my ($self, $myconfig, $userspath) = @_; - my ($template, $out); + my $out; local (*IN, *OUT); @@ -1154,28 +1179,30 @@ sub parse_template { 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); + $template_type = 'LaTeX'; $ext_for_format = 'pdf'; } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) { - $template = HTMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $template_type = 'HTML'; $ext_for_format = 'html'; } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) { - $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $template_type = 'XML'; $ext_for_format = 'xml'; - } elsif ( $self->{"format"} =~ /elsterwinston/i ) { - $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) { + $template_type = 'XML'; - } elsif ( $self->{"format"} =~ /elstertaxbird/i ) { - $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + } 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'}"); @@ -1187,6 +1214,12 @@ sub parse_template { $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" }; @@ -1219,20 +1252,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') { @@ -1288,6 +1324,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'; @@ -1296,8 +1333,11 @@ 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} @@ -1310,18 +1350,8 @@ Content-Length: $numbytes |; - open(OUT, ">-") or $self->error($self->cleanup . "$!: STDOUT"); - - } - - while () { - print OUT $_; - + $::locale->with_raw_io(\*STDOUT, sub { print while }); } - - close(OUT); - - seek IN, 0, 0; } close(IN); @@ -1345,7 +1375,6 @@ sub get_formname_translation { bin_list => $main::locale->text('Bin List'), credit_note => $main::locale->text('Credit Note'), invoice => $main::locale->text('Invoice'), - packing_list => $main::locale->text('Packing List'), pick_list => $main::locale->text('Pick List'), proforma => $main::locale->text('Proforma Invoice'), purchase_order => $main::locale->text('Purchase Order'), @@ -1353,7 +1382,6 @@ sub get_formname_translation { sales_order => $main::locale->text('Confirmation'), sales_quotation => $main::locale->text('Quotation'), storno_invoice => $main::locale->text('Storno Invoice'), - 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'), @@ -1384,6 +1412,7 @@ sub get_extension_for_format { 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" : ""; @@ -1495,15 +1524,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 @@ -1522,9 +1557,7 @@ sub dbconnect_noauto { my ($self, $myconfig) = @_; # connect to database - my $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 @@ -1540,7 +1573,8 @@ 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"); @@ -1741,8 +1775,9 @@ sub check_exchangerate { 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|; @@ -1812,6 +1847,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; @@ -1865,6 +1901,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(); } @@ -1931,7 +1969,7 @@ sub add_shipto { my @values; foreach my $item (qw(name department_1 department_2 street zipcode city country - contact phone fax email)) { + contact cp_gender phone fax email)) { if ($self->{"shipto$item"}) { $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"}); } @@ -1949,6 +1987,7 @@ sub add_shipto { shiptocity = ?, shiptocountry = ?, shiptocontact = ?, + shiptocp_gender = ?, shiptophone = ?, shiptofax = ?, shiptoemail = ? @@ -1964,6 +2003,7 @@ sub add_shipto { shiptocity = ? AND shiptocountry = ? AND shiptocontact = ? AND + shiptocp_gender = ? AND shiptophone = ? AND shiptofax = ? AND shiptoemail = ? AND @@ -1974,8 +2014,8 @@ sub add_shipto { $query = qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2, shiptostreet, shiptozipcode, shiptocity, shiptocountry, - shiptocontact, shiptophone, shiptofax, shiptoemail, module) - VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|; + shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module) + VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|; do_query($self, $dbh, $query, $id, @values, $module); } } @@ -2314,9 +2354,13 @@ 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 $where = $options->{business_is_salesman} ? qq| AND business_id IN (SELECT id FROM business WHERE salesman)| : ''; - my $query = qq|SELECT * FROM customer WHERE NOT obsolete $where 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) : ''; + + 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(); @@ -2578,7 +2622,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"; @@ -2986,8 +3030,8 @@ sub lastname_used { sub current_date { $main::lxdebug->enter_sub(); - my $self = shift; - my $myconfig = shift || \%::myconfig; + my $self = shift; + my $myconfig = shift || \%::myconfig; my ($thisdate, $days) = @_; my $dbh = $self->get_standard_dbh($myconfig); @@ -3180,7 +3224,6 @@ sub save_status { # $main::locale->text('invoice') # $main::locale->text('proforma') # $main::locale->text('sales_order') -# $main::locale->text('packing_list') # $main::locale->text('pick_list') # $main::locale->text('purchase_order') # $main::locale->text('bin_list') @@ -3190,8 +3233,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); @@ -3204,6 +3247,8 @@ sub save_history { $self->{addition}, $self->{what_done}, "$self->{snumbers}"); do_query($self, $dbh, $query, @values); + $dbh->commit; + $main::lxdebug->leave_sub(); } @@ -3471,9 +3516,7 @@ Points of interest for a beginner are: =head1 SPECIAL FUNCTIONS -=over 4 - -=item _store_value() +=head2 C<_store_value()> parses a complex var name, and stores it in the form. @@ -3528,7 +3571,7 @@ supported key structures are: filter.status[] => $form->{status}->[ val1, val2, ... ] -=item update_business PARAMS +=head2 C PARAMS PARAMS (not named): \%config, - config hashref @@ -3540,6 +3583,59 @@ 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. +=head2 C $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/'); + +=head2 C

+ +Generates a general purpose http/html header and includes most of the scripts +ans stylesheets needed. + +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 +HTTP_USER_AGENT is found, no header is generated. + +Although header does not accept parameters itself, it will honor special +hashkeys of its Form instance: + +=over 4 + +=item refresh_time + +=item refresh_url + +If one of these is set, a http-equiv refresh is generated. Missing parameters +default to 3 seconds and the refering url. + +=item stylesheet + +=item stylesheets + +If these are arrayrefs the contents will be inlined into the header. + +=item landscape + +If true, a css snippet will be generated that sets the page in landscape mode. + +=item favicon + +Used to override the default favicon. + +=item title + +A html page title will be generated from this + =back =cut