use Data::Dumper;
use CGI;
-use CGI::Ajax;
use Cwd;
+use Encode;
+use File::Copy;
use IO::File;
use SL::Auth;
use SL::Auth::DB;
use SL::Auth::LDAP;
use SL::AM;
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::MoreCommon qw(uri_encode uri_decode);
+use SL::OE;
+use SL::Request;
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);
+use List::MoreUtils qw(all any apply);
use strict;
undef $standard_dbh;
}
-sub _store_value {
- $main::lxdebug->enter_sub(2);
-
- my $self = shift;
- my $key = shift;
- my $value = shift;
-
- my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
-
- my $curr;
-
- if (scalar @tokens) {
- $curr = \ $self->{ shift @tokens };
- }
-
- while (@tokens) {
- my $sep = shift @tokens;
- my $key = shift @tokens;
-
- $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
- $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
- $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
- $curr = \ $$curr->{$key}
- }
-
- $$curr = $value;
-
- $main::lxdebug->leave_sub(2);
-
- return $curr;
-}
-
-sub _input_to_hash {
- $main::lxdebug->enter_sub(2);
-
- my $self = shift;
- my $input = shift;
-
- my @pairs = split(/&/, $input);
-
- foreach (@pairs) {
- my ($key, $value) = split(/=/, $_, 2);
- $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
- }
-
- $main::lxdebug->leave_sub(2);
-}
-
-sub _request_to_hash {
- $main::lxdebug->enter_sub(2);
-
- my $self = shift;
- my $input = shift;
-
- if (!$ENV{'CONTENT_TYPE'}
- || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
-
- $self->_input_to_hash($input);
-
- $main::lxdebug->leave_sub(2);
- return;
- }
-
- my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
-
- my $boundary = '--' . $1;
-
- foreach my $line (split m/\n/, $input) {
- last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
-
- if (($line eq $boundary) || ($line eq "$boundary\r")) {
- ${ $previous } =~ s|\r?\n$|| if $previous;
-
- undef $previous;
- undef $filename;
-
- $headers_done = 0;
- $content_type = "text/plain";
- $boundary_found = 1;
- $need_cr = 0;
-
- next;
- }
-
- next unless $boundary_found;
-
- if (!$headers_done) {
- $line =~ s/[\r\n]*$//;
-
- if (!$line) {
- $headers_done = 1;
- next;
- }
-
- if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
- if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
- $filename = $1;
- substr $line, $-[0], $+[0] - $-[0], "";
- }
-
- if ($line =~ m|name\s*=\s*"(.*?)"|i) {
- $name = $1;
- substr $line, $-[0], $+[0] - $-[0], "";
- }
-
- $previous = $self->_store_value($name, '') if ($name);
- $self->{FILENAME} = $filename if ($filename);
-
- next;
- }
-
- if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
- $content_type = $1;
- }
-
- next;
- }
-
- next unless $previous;
-
- ${ $previous } .= "${line}\n";
- }
-
- ${ $previous } =~ s|\r?\n$|| if $previous;
-
- $main::lxdebug->leave_sub(2);
-}
-
-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();
my $self = {};
+ no warnings 'once';
if ($LXDebug::watch_form) {
require SL::Watchdog;
tie %{ $self }, 'SL::Watchdog';
bless $self, $type;
- $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
- $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
-
- if ($ENV{CONTENT_LENGTH}) {
- my $content;
- read STDIN, $content, $ENV{CONTENT_LENGTH};
- $self->_request_to_hash($content);
- }
-
- my $db_charset = $main::dbcharset;
- $db_charset ||= Common::DEFAULT_CHARSET;
-
- my $encoding = $self->{INPUT_ENCODING} || $db_charset;
- delete $self->{INPUT_ENCODING};
-
- _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
-
- $self->{action} = lc $self->{action};
- $self->{action} =~ s/( |-|,|\#)/_/g;
-
- #$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} = <VERSION_FILE>;
- close VERSION_FILE;
+ 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();
return $self;
}
+sub read_cgi_input {
+ my ($self) = @_;
+ SL::Request::read_cgi_input($self);
+}
+
sub _flatten_variables_rec {
$main::lxdebug->enter_sub(2);
}
sub escape {
- $main::lxdebug->enter_sub(2);
-
my ($self, $str) = @_;
- $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
-
- $main::lxdebug->leave_sub(2);
-
- return $str;
+ return uri_encode($str);
}
sub unescape {
- $main::lxdebug->enter_sub(2);
-
my ($self, $str) = @_;
- $str =~ tr/+/ /;
- $str =~ s/\\$//;
-
- $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
-
- $main::lxdebug->leave_sub(2);
-
- return $str;
+ return uri_decode($str);
}
sub quote {
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();
}
+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/<br>/g;
$self->show_generic_error($msg);
print qq|
<p class="message_ok"><b>$msg</b></p>
-
+
<script type="text/javascript">
<!--
// If JavaScript is enabled, the whole thing will be reloaded.
- // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
+ // The reason is: When one changes his menu setup (HTML / CSS ...)
// it now loads the correct code into the browser instead of do nothing.
setTimeout("top.frames.location.href='login.pl'",500);
//-->
</script>
-
+
</body>
|;
my $self = shift;
my %params = @_;
- my $cgi = $main::cgi;
- $cgi ||= CGI->new('');
+ my $cgi = $::request->{cgi};
my $session_cookie;
if (defined $main::auth) {
pop @segments;
$uri->path_segments(@segments);
- my $session_cookie_value = $main::auth->get_session_id();
- $session_cookie_value ||= 'NO_SESSION';
+ my $session_cookie_value = $main::auth->get_session_id();
- $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
- '-value' => $session_cookie_value,
- '-path' => $uri->path,
- '-secure' => $ENV{HTTPS});
+ 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);
+
+ map { $cgi_params{'-' . $_} = $params{$_} if exists $params{$_} } qw(content_disposition content_length);
- my $output = $cgi->header('-cookie' => $session_cookie,
- %cgi_params);
+ my $output = $cgi->header(%cgi_params);
$main::lxdebug->leave_sub();
return $output;
}
+sub use_stylesheet {
+ my $self = shift;
-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}) {
- $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|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">\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|<link rel="stylesheet" href="css/$file" TYPE="text/css" TITLE="Lx-Office stylesheet">\n|;
- }
-
- $self->{favicon} = "favicon.ico" unless $self->{favicon};
-
- if ($self->{favicon} && (-f "$self->{favicon}")) {
- $favicon =
- qq|<LINK REL="shortcut icon" HREF="$self->{favicon}" TYPE="image/x-icon">
- |;
- }
-
- my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
+ $self->{stylesheet} = [ $self->{stylesheet} ] unless ref $self->{stylesheet} eq 'ARRAY';
+ $self->{stylesheet} = [ grep { -f }
+ map { m:^css/: ? $_ : "css/$_" }
+ grep { $_ }
+ (@{ $self->{stylesheet} }, @_)
+ ];
- if ($self->{landscape}) {
- $pagelayout = qq|<style type="text/css">
- \@page { size:landscape; }
- </style>|;
- }
+ return @{ $self->{stylesheet} };
+}
- my $fokus = qq|
- <script type="text/javascript">
- <!--
- function fokus() {
- document.$self->{fokus}.focus();
- }
- //-->
- </script>
- | if $self->{"fokus"};
+sub header {
+ $::lxdebug->enter_sub;
- my $title_hack = qq|
+ # 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, %params) = @_;
+ 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}++;
+
+ $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, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
+ }
+
+ push @header, map { qq|<link rel="stylesheet" href="$_" type="text/css" title="Lx-Office stylesheet">| } $self->use_stylesheet;
+
+ push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
+ push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
+ push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
+ '<script type="text/javascript" src="js/common.js"></script>',
+ '<link rel="stylesheet" type="text/css" href="js/jscalendar/calendar-win2k-1.css">',
+ '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
+ '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
+ '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
+ '<script type="text/javascript" src="js/part_selection.js"></script>',
+ '<script type="text/javascript" src="js/jquery-ui.js"></script>',
+ '<script type="text/javascript" src="js/jqModal.js"></script>',
+ '<link rel="stylesheet" type="text/css" href="css/ui-lightness/jquery-ui-1.8.12.custom.css">';
+ push @header, $self->{javascript} if $self->{javascript};
+ push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
+ push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
+ push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
+ 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|
<script type="text/javascript">
<!--
// Write a meaningful title-tag for our frameset.
- top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - Ver. | . $self->{"version"} . qq|";
+ top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
//-->
- </script>
- |;
-
- #Set Calendar
- my $jsscript = "";
- if ($self->{jsscript} == 1) {
-
- $jsscript = qq|
- <script type="text/javascript" src="js/jquery.js"></script>
- <script type="text/javascript" src="js/common.js"></script>
- <style type="text/css">\@import url(js/jscalendar/calendar-win2k-1.css);</style>
- <script type="text/javascript" src="js/jscalendar/calendar.js"></script>
- <script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>
- <script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>
- $self->{javascript}
- |;
- }
+ </script>|;
+ }
- $self->{titlebar} =
- ($self->{title})
- ? "$self->{title} - $self->{titlebar}"
- : $self->{titlebar};
- my $ajax = "";
- for my $item (@ { $self->{AJAX} || [] }) {
- $ajax .= $item->show_javascript();
- }
+ my %doctypes = (
+ strict => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">|,
+ transitional => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">|,
+ frameset => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">|,
+ );
- print $self->create_http_response('content_type' => 'text/html',
- 'charset' => $db_charset,);
- print qq|${doctype}<html>
-<head>
- <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=${db_charset}">
+ # output
+ print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
+ print $doctypes{$params{doctype} || 'transitional'}, $/;
+ print <<EOT;
+<html>
+ <head>
+ <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
<title>$self->{titlebar}</title>
- $stylesheet
- $pagelayout
- $favicon
- $jsscript
- $ajax
- $fokus
- $title_hack
-
- <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
-
- <meta name="robots" content="noindex,nofollow" />
- <script type="text/javascript" src="js/highlight_input.js"></script>
-
- <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
+EOT
+ print " $_\n" for @header;
+ print <<EOT;
+ <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css">
+ <meta name="robots" content="noindex,nofollow">
+ <link rel="stylesheet" type="text/css" href="css/tabcontent.css">
<script type="text/javascript" src="js/tabcontent.js">
/***********************************************
***********************************************/
</script>
+ $params{extra_code}
+ $title_hack
+ </head>
- $extra_code
-</head>
+EOT
-|;
- }
- $self->{header} = 1;
-
- $main::lxdebug->leave_sub();
+ $::lxdebug->leave_sub;
}
sub ajax_response_header {
my ($self) = @_;
- my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
- my $cgi = $main::cgi || CGI->new('');
- my $output = $cgi->header('-charset' => $db_charset);
+ my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
+ my $output = $::request->{cgi}->header('-charset' => $db_charset);
$main::lxdebug->leave_sub();
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 {
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|<pre>$info</pre>|);
- ::end_of_request();
- }
-
$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|<pre>$info</pre>|);
+ my $info = "Web page template '${file}' not found.\n";
+ print qq|<pre>$info</pre>|;
::end_of_request();
}
}
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;
+ $::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"} = $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;
- $additional_params->{"conf_show_best_before"} = $main::show_best_before;
+ $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset};
+ $additional_params->{"conf_webdav"} = $::lx_office_conf{features}->{webdav};
+ $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};
+ $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}}) {
sub init_template {
my $self = shift;
- return if $self->template;
+ return $self->template if $self->template;
return $self->template(Template->new({
'INTERPOLATE' => 0,
'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;
}
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,
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();
}
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');
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") {
$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 {
sub parse_template {
$main::lxdebug->enter_sub();
- my ($self, $myconfig, $userspath) = @_;
- my $out;
+ my ($self, $myconfig) = @_;
+ my ($out, $out_mode);
local (*IN, *OUT);
+ my $userspath = $::lx_office_conf{paths}->{userspath};
+
$self->{"cwd"} = getcwd();
$self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
$ext_for_format = 'xml';
} elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
- $template_type = 'xml';
+ $template_type = 'XML';
} elsif ( $self->{"format"} =~ /excel/i ) {
$template_type = 'Excel';
}
map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
+ map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
$self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
# OUT is used for the media, screen, printer, email
# for postscript we store a copy in a temporary file
- my $fileid = time;
- my $prepend_userspath;
-
- if (!$self->{tmpfile}) {
- $self->{tmpfile} = "${fileid}.$self->{IN}";
- $prepend_userspath = 1;
- }
-
- $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
-
- $self->{tmpfile} =~ s|.*/||;
- $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
- $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
+ my ($temp_fh, $suffix);
+ $suffix = $self->{IN};
+ $suffix =~ s/.*\.//;
+ ($temp_fh, $self->{tmpfile}) = File::Temp::tempfile(
+ 'lx-office-printXXXXXX',
+ SUFFIX => '.' . ($suffix || 'tex'),
+ DIR => $userspath,
+ UNLINK => 1,
+ );
+ close $temp_fh;
if ($template->uses_temp_file() || $self->{media} eq 'email') {
$out = $self->{OUT};
- $self->{OUT} = ">$self->{tmpfile}";
+ $out_mode = $self->{OUT_MODE} || '>';
+ $self->{OUT} = "$self->{tmpfile}";
+ $self->{OUT_MODE} = '>';
}
my $result;
if ($self->{OUT}) {
- open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
- $result = $template->parse(*OUT);
- close OUT;
-
+ open(OUT, $self->{OUT_MODE}, $self->{OUT}) or $self->error("error on opening $self->{OUT} with mode $self->{OUT_MODE} : $!");
} else {
+ *OUT = ($::dispatcher->get_standard_filehandles)[1];
$self->header;
- $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;
+ chdir("$self->{cwd}");
+
+ $::lxdebug->leave_sub();
+
+ return;
+ }
+
if ($template->uses_temp_file() || $self->{media} eq 'email') {
if ($self->{media} eq 'email') {
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.";
+ $mail->{fileid} = time() . '.' . $$ . '.';
$myconfig->{signature} =~ s/\r//g;
# if we send html or plain text inline
$myconfig->{signature} =~ s/\n/<br>\n/g;
$mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
- open(IN, $self->{tmpfile})
+ open(IN, "<", $self->{tmpfile})
or $self->error($self->cleanup . "$self->{tmpfile} : $!");
while (<IN>) {
$mail->{message} .= $_;
} else {
- $self->{OUT} = $out;
+ $self->{OUT} = $out;
+ $self->{OUT_MODE} = $out_mode;
my $numbytes = (-s $self->{tmpfile});
- open(IN, $self->{tmpfile})
+ open(IN, "<", $self->{tmpfile})
or $self->error($self->cleanup . "$self->{tmpfile} : $!");
+ binmode IN;
$self->{copies} = 1 unless $self->{media} eq 'printer';
#print(STDERR "OUT $self->{OUT}\n");
for my $i (1 .. $self->{copies}) {
if ($self->{OUT}) {
- open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
- print OUT while <IN>;
+ open OUT, $self->{OUT_MODE}, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
+ print OUT $_ while <IN>;
close OUT;
seek IN, 0, 0;
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'),
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'),
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 = <FH>;
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;
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
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
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();
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 "") {
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,
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"});
}
shiptocity = ?,
shiptocountry = ?,
shiptocontact = ?,
+ shiptocp_gender = ?,
shiptophone = ?,
shiptofax = ?,
shiptoemail = ?
shiptocity = ? AND
shiptocountry = ? AND
shiptocontact = ? AND
+ shiptocp_gender = ? AND
shiptophone = ? AND
shiptofax = ? AND
shiptoemail = ? AND
$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);
}
}
$key = $params;
}
- my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
+ my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : '';
my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
$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);
my $options = ref $key eq 'HASH' ? $key : { key => $key };
$options->{key} ||= "all_customers";
- my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
+ my $limit_clause = $options->{limit} ? "LIMIT $options->{limit}" : '';
my @where;
push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
$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} }) {
$table = $table eq "customer" ? "customer" : "vendor";
- my $query = qq|SELECT count(*) FROM $table|;
+ my $query = qq|SELECT count(*) FROM $table WHERE NOT obsolete|;
my ($count) = selectrow_query($self, $dbh, $query);
# build selection list
@{ $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);
# get languages
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);
}
# 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);
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
$self->{$key} = $ref->{$key};
}
+ # remove any trailing whitespace
+ $self->{currency} =~ s/\s*$//;
+
my $transdate = "current_date";
if ($self->{transdate}) {
$transdate = $dbh->quote($self->{transdate});
$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
if ($self->{"$self->{vc}_id"}) {
# only setup currency
- ($self->{currency}) = split(/:/, $self->{currencies});
+ ($self->{currency}) = split(/:/, $self->{currencies}) if !$self->{currency};
} else {
"a.department_id" => "department_id",
"d.description" => "department",
"ct.name" => $table,
+ "ct.curr" => "cv_curr",
"current_date + ct.terms" => "duedate",
);
if ($self->{type} =~ /delivery_order/) {
$arap = 'delivery_orders';
delete $column_map{"a.curr"};
+ delete $column_map{"ct.curr"};
} elsif ($self->{type} =~ /_order/) {
$arap = 'oe';
map { $self->{$_} = $ref->{$_} } values %column_map;
+ # remove any trailing whitespace
+ $self->{currency} =~ s/\s*$// if $self->{currency};
+ $self->{cv_curr} =~ s/\s*$// if $self->{cv_curr};
+
+ # if customer/vendor currency is set use this
+ $self->{currency} = $self->{cv_curr} if $self->{cv_curr};
+
$main::lxdebug->leave_sub();
}
# $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')
$main::lxdebug->leave_sub();
}
-1;
+sub prepare_for_printing {
+ my ($self) = @_;
-__END__
+ $self->{templates} ||= $::myconfig{templates};
+ $self->{formname} ||= $self->{type};
+ $self->{media} ||= 'email';
-=head1 NAME
+ die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
-SL::Form.pm - main data object.
+ # 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};
+ }
-=head1 SYNOPSIS
+ my $language = $self->{language} ? '_' . $self->{language} : '';
-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:
+ 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;
+ }
- - $form->error - renders a generic error in html. accepts an error message
- - $form->get_standard_dbh - returns a database connection for the
+ # Retrieve accounts for tax calculation.
+ IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
-=head1 SPECIAL FUNCTIONS
+ 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);
+ }
-=over 4
+ # 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';
+ }
-=item _store_value()
+ my $printer_code = $self->{printer_code} ? '_' . $self->{printer_code} : '';
+ my $email_extension = -f "$::myconfig{templates}/$self->{formname}_email${language}.${extension}" ? '_email' : '';
+ $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
-parses a complex var name, and stores it in the form.
+ # 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})));
-syntax:
- $form->_store_value($key, $value);
+ $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})));
-keys must start with a string, and can contain various tokens.
-supported key structures are:
+ $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
-1. simple access
- simple key strings work as expected
+ my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
- id => $form->{id}
+ if (scalar @{ $cvar_date_fields }) {
+ $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
+ }
-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.
+ while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
+ $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
+ }
- filter.description => $form->{filter}->{description}
+ return $self;
+}
-3. array+hashref access
+sub format_dates {
+ my ($self, $dateformat, $longformat, @indices) = @_;
- 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.
+ $dateformat ||= $::myconfig{dateformat};
- repeating these names in your template:
+ foreach my $idx (@indices) {
+ if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
+ for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
+ $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
+ }
+ }
- invoice.items[+].id
- invoice.items[].parts_id
+ next unless defined $self->{$idx};
- will result in:
+ if (!ref($self->{$idx})) {
+ $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
- $form->{invoice}->{items}->[
- {
- id => ...
- parts_id => ...
- },
- {
- id => ...
- parts_id => ...
+ } elsif (ref($self->{$idx}) eq "ARRAY") {
+ for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
+ $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
+ }
+ }
+ }
+}
+
+sub reformat_numbers {
+ my ($self, $numberformat, $places, @indices) = @_;
+
+ return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
+
+ foreach my $idx (@indices) {
+ if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
+ for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
+ $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
+ }
+ }
+
+ next unless defined $self->{$idx};
+
+ if (!ref($self->{$idx})) {
+ $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
+
+ } elsif (ref($self->{$idx}) eq "ARRAY") {
+ for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
+ $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
+ }
+ }
+ }
+
+ my $saved_numberformat = $::myconfig{numberformat};
+ $::myconfig{numberformat} = $numberformat;
+
+ foreach my $idx (@indices) {
+ if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
+ for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
+ $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
+ }
+ }
+
+ next unless defined $self->{$idx};
+
+ if (!ref($self->{$idx})) {
+ $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
+
+ } elsif (ref($self->{$idx}) eq "ARRAY") {
+ for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
+ $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
}
- ...
- ]
+ }
+ }
+
+ $::myconfig{numberformat} = $saved_numberformat;
+}
+
+1;
-4. arrays
+__END__
- 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.
+=head1 NAME
- filter.status[] => $form->{status}->[ val1, val2, ... ]
+SL::Form.pm - main data object.
-=item update_business PARAMS
+=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
+
+=head2 C<update_business> PARAMS
PARAMS (not named):
\%config, - config hashref
special behaviour for empty strings in customerinitnumber field:
will in this case not increase the value, and return undef.
-=item redirect_header $url
+=head2 C<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
print $::form->redirect_header('oe.pl?action=edit&id=1234');
print $::form->redirect_header('http://www.lx-office.org/');
+=head2 C<header>
+
+Generates a general purpose http/html header and includes most of the scripts
+and stylesheets needed. Stylesheets can be added with L<use_stylesheet>.
+
+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
+
+Either a scalar or an array ref. Will be inlined into the header. Add
+stylesheets with the L<use_stylesheet> function.
+
+=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
projects / kivitendo-erp.git / blobdiff