X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FCommon.pm;h=bcaeb62c13f48795be25720f0f0df1a812e24cfe;hb=bebca3b60f8c019b9acbc436da7437d67dc19e67;hp=8cf4e85cfdd863b2097b680f3024db5817548b1e;hpb=66ddc388f22a78ff14f7705a0d3d601e81440e04;p=kivitendo-erp.git diff --git a/SL/Common.pm b/SL/Common.pm index 8cf4e85cf..bcaeb62c1 100644 --- a/SL/Common.pm +++ b/SL/Common.pm @@ -11,40 +11,42 @@ package Common; use utf8; use strict; +use Carp; +use English qw(-no_match_vars); use Time::HiRes qw(gettimeofday); use Data::Dumper; -use File::Copy; +use File::Copy (); +use File::stat; +use File::Slurp; +use File::Spec; +use List::MoreUtils qw(apply); +use POSIX (); +use Encode qw(decode); use SL::DBUtils; -use vars qw(@db_encodings %db_encoding_to_charset %charset_to_db_encoding); - -@db_encodings = ( - { "label" => "ASCII", "dbencoding" => "SQL_ASCII", "charset" => "ASCII" }, - { "label" => "UTF-8 Unicode", "dbencoding" => "UNICODE", "charset" => "UTF-8" }, - { "label" => "ISO 8859-1", "dbencoding" => "LATIN1", "charset" => "ISO-8859-1" }, - { "label" => "ISO 8859-2", "dbencoding" => "LATIN2", "charset" => "ISO-8859-2" }, - { "label" => "ISO 8859-3", "dbencoding" => "LATIN3", "charset" => "ISO-8859-3" }, - { "label" => "ISO 8859-4", "dbencoding" => "LATIN4", "charset" => "ISO-8859-4" }, - { "label" => "ISO 8859-5", "dbencoding" => "LATIN5", "charset" => "ISO-8859-5" }, - { "label" => "ISO 8859-15", "dbencoding" => "LATIN9", "charset" => "ISO-8859-15" }, - { "label" => "KOI8-R", "dbencoding" => "KOI8", "charset" => "KOI8-R" }, - { "label" => "Windows CP1251", "dbencoding" => "WIN", "charset" => "CP1251" }, - { "label" => "Windows CP866", "dbencoding" => "ALT", "charset" => "CP866" }, -); - -%db_encoding_to_charset = map { $_->{dbencoding}, $_->{charset} } @db_encodings; -%charset_to_db_encoding = map { $_->{charset}, $_->{dbencoding} } @db_encodings; - -use constant DEFAULT_CHARSET => 'ISO-8859-15'; - sub unique_id { my ($a, $b) = gettimeofday(); return "${a}-${b}-${$}"; } sub tmpname { - return "/tmp/lx-office-tmp-" . unique_id(); + return "/tmp/kivitendo-tmp-" . unique_id(); +} + +sub truncate { + my ($text, %params) = @_; + + $params{at} //= 50; + $params{at} = 3 if 3 > $params{at}; + + $params{strip} //= ''; + + $text =~ s/[\r\n]+$//g if $params{strip} =~ m/^(?: 1 | newlines? | full )$/x; + $text =~ s/[\r\n]+/ /g if $params{strip} =~ m/^(?: newlines? | full )$/x; + + return $text if length($text) <= $params{at}; + return substr($text, 0, $params{at} - 3) . '...'; } sub retrieve_parts { @@ -71,7 +73,7 @@ sub retrieve_parts { } if ($form->{no_services}) { - $filter .= qq| AND (inventory_accno_id is not NULL or assembly=TRUE)|; # @mb hier nochmal optimieren ... nach kurzer ruecksprache alles i.o. + $filter .= qq| AND (inventory_accno_id is not NULL or assembly=TRUE)|; } substr($filter, 1, 3) = "WHERE" if ($filter); @@ -80,7 +82,8 @@ sub retrieve_parts { $order_dir = $order_dir ? "ASC" : "DESC"; my $query = - qq|SELECT id, partnumber, description, ean | . + qq|SELECT id, partnumber, description, ean, | . + qq| warehouse_id, bin_id | . qq|FROM parts $filter | . qq|ORDER BY $order_by $order_dir|; my $sth = $dbh->prepare($query); @@ -331,34 +334,29 @@ sub mkdir_with_parents { $main::lxdebug->leave_sub(); } -# -# Legt ein entsprechendes Webdav-Verzeichnis an, falls -# Webdav als Option konfiguriert ist -# sub webdav_folder { $main::lxdebug->enter_sub(); my ($form) = @_; return $main::lxdebug->leave_sub() - unless ($::lx_office_conf{features}->{webdav} && $form->{id}); + unless ($::instance_conf->get_webdav && $form->{id}); + - my $path = get_webdav_folder($form); # ausgelagert, wg. D.R.Y. $form->{WEBDAV} = []; - return $main::lxdebug->leave_sub() unless ($path); + my ($path, $number) = get_webdav_folder($form); + return $main::lxdebug->leave_sub() unless ($path && $number); if (!-d $path) { mkdir_with_parents($path); } else { - my $base_path = substr($ENV{'SCRIPT_NAME'}, 1); + my $base_path = $ENV{'SCRIPT_NAME'}; $base_path =~ s|[^/]+$||; - $base_path =~ s|/$||; - # wo kommt der wert für dir her? es wird doch gar nichts übergeben? fix für strict my $dir jb 21.2. if (opendir my $dir, $path) { - foreach my $file (sort { lc $a cmp lc $b } readdir $dir) { + foreach my $file (sort { lc $a cmp lc $b } map { decode("UTF-8", $_) } readdir $dir) { next if (($file eq '.') || ($file eq '..')); my $fname = $file; @@ -371,7 +369,7 @@ sub webdav_folder { push @{ $form->{WEBDAV} }, { 'name' => $fname, - 'link' => "$base_path/$file", + 'link' => $base_path . $file, 'type' => $is_directory ? $main::locale->text('Directory') : $main::locale->text('File'), }; } @@ -399,11 +397,13 @@ sub get_vc_details { vc.*, pt.description AS payment_terms, b.description AS business, - l.description AS language + l.description AS language, + dt.description AS delivery_terms FROM ${vc} vc LEFT JOIN payment_terms pt ON (vc.payment_id = pt.id) LEFT JOIN business b ON (vc.business_id = b.id) LEFT JOIN language l ON (vc.language_id = l.id) + LEFT JOIN delivery_terms dt ON (vc.delivery_term_id = dt.id) WHERE vc.id = ?|; my $ref = selectfirst_hashref_query($form, $dbh, $query, $vc_id); @@ -423,6 +423,9 @@ sub get_vc_details { $query = qq|SELECT * FROM contacts WHERE (cp_cv_id = ?)|; $form->{CONTACTS} = selectall_hashref_query($form, $dbh, $query, $vc_id); + # Only show default pricegroup for customer, not vendor, which is why this is outside the main query + ($form->{pricegroup}) = selectrow_query($form, $dbh, qq|SELECT pricegroup FROM pricegroup WHERE id = ?|, $form->{klass}); + $dbh->disconnect(); $main::lxdebug->leave_sub(); @@ -465,6 +468,8 @@ sub save_email_status { } elsif ($form->{script} eq 'ir.pl') { $table = 'ap'; + } elsif ($form->{script} eq 'do.pl') { + $table = 'delivery_orders'; } return $main::lxdebug->leave_sub() if (!$form->{id} || !$table || !$form->{formname}); @@ -478,8 +483,8 @@ sub save_email_status { $intnotes .= "\n\n" if ($intnotes); - my $cc = $main::locale->text('Cc') . ": $form->{cc}\n" if $form->{cc}; - my $bcc = $main::locale->text('Bcc') . ": $form->{bcc}\n" if $form->{bcc}; + my $cc = $form->{cc} ? $main::locale->text('Cc') . ": $form->{cc}\n" : ''; + my $bcc = $form->{bcc} ? $main::locale->text('Bcc') . ": $form->{bcc}\n" : ''; my $now = scalar localtime; $intnotes .= $main::locale->text('[email]') . "\n" @@ -554,24 +559,16 @@ sub check_params_x { } } -# -# Diese Routine baut aus dem Masken-Typ und der -# Beleg-Nummer, das entsprechende Webdav-Verzeichnis zusammen -# Nimmt leider noch die ganze Form entgegen und den if-elsif-Block -# sollte man schöner "dispatchen" -# Ergänzung 6.5.2011, den else-Zweig defensiver gestaltet und mit -# -1 als n.i.O. Rückgabewert versehen -# sub get_webdav_folder { $main::lxdebug->enter_sub(); my ($form) = @_; - # TODO Ergänzung um check_params + croak "No client set in \$::auth" unless $::auth->client; my ($path, $number); - + # dispatch table if ($form->{type} eq "sales_quotation") { ($path, $number) = ("angebote", $form->{quonumber}); } elsif ($form->{type} eq "sales_order") { @@ -586,73 +583,138 @@ sub get_webdav_folder { ($path, $number) = ("einkaufslieferscheine", $form->{donumber}); } elsif ($form->{type} eq "credit_note") { ($path, $number) = ("gutschriften", $form->{invnumber}); + } elsif ($form->{type} eq "letter") { + ($path, $number) = ("briefe", $form->{letternumber} ); } elsif ($form->{vc} eq "customer") { ($path, $number) = ("rechnungen", $form->{invnumber}); } elsif ($form->{vc} eq "vendor") { ($path, $number) = ("einkaufsrechnungen", $form->{invnumber}); } else { - # wir befinden uns nicht in einer belegmaske - # scheinbar wird diese routine auch bspw. bei waren - # aufgerufen - naja, steuerung über Form.pm halt ... $main::lxdebug->leave_sub(); return undef; } - return $main::lxdebug->leave_sub() unless ($path && $number); - $number =~ s|[/\\]|_|g; - $path = "webdav/${path}/${number}"; + $path = "webdav/" . $::auth->client->{id} . "/${path}/${number}"; $main::lxdebug->leave_sub(); - return $path; - + return ($path, $number); } -# -# Falls Webdav aktiviert ist, auch den generierten Beleg in das -# Webdav-Verzeichnis kopieren -# -# sub copy_file_to_webdav_folder { - $main::lxdebug->enter_sub(); - - my ($form) = @_; - # leider die ganze form - # da get_webdav_folder die auch noch benötigt - # aber hier ein paar checks: - # OFFEN: check_params kann ich ja nicht eine - # abgespeckte $form übergeben, oder? - $form->{type} = ''; + $::lxdebug->enter_sub(); + + my ($form) = @_; + my ($last_mod_time, $latest_file_name, $complete_path); + + # checks foreach my $item (qw(tmpdir tmpfile type)){ - if (!$form->{$item}){ # wahr, bei undef oder '' - $main::lxdebug->message(0, 'Missing parameter'); - $main::form->error($main::locale->text("Missing parameter for webdav file copy")); - } + next if $form->{$item}; + $::lxdebug->message(LXDebug::WARN(), 'Missing parameter:' . $item); + $::form->error($::locale->text("Missing parameter for WebDAV file copy")); } - # Den Webdav-Ordner ÜBER exakt denselben Mechanismus wie beim - # Anlegen bestimmen - # leider ist das auch das Kriterium, ob überhaupt ein "Anlegen" - # erlaubt ist - my $webdav_folder = get_webdav_folder($form); + my ($webdav_folder, $document_name) = get_webdav_folder($form); - # hier auch nochmal prüfen if (! $webdav_folder){ - $main::lxdebug->leave_sub(); - return undef; # s.o. erstmal so ... - $main::form->error($main::locale->text("Cannot check correct webdav folder")); + $::lxdebug->leave_sub(); + $::lxdebug->message(LXDebug::WARN(), 'Cannot check correct WebDAV folder'); + $::form->error($::locale->text("Cannot check correct WebDAV folder")); + return undef; } - if(!copy(join('/', $form->{tmpdir}, $form->{tmpfile}), join('/', $form->{cwd}, $webdav_folder))){ - my $j = join('/', $form->{tmpdir}, $form->{tmpfile}); - my $k = join('/', $form->{cwd}, $webdav_folder); - $main::lxdebug->message(0, "Copy file from $j to $k failed"); - $main::form->error($main::locale->text("Copy file from #1 to #2 failed", $j, $k)); + $complete_path = File::Spec->catfile($form->{cwd}, $webdav_folder); + + # maybe the path does not exist (automatic printing), see #2446 + if (!-d $complete_path) { + # we need a chdir and restore old dir + my $current_dir = POSIX::getcwd(); + chdir("$form->{cwd}"); + mkdir_with_parents($webdav_folder); + chdir($current_dir); } - $main::lxdebug->leave_sub(); + opendir my $dh, $complete_path or die "Could not open $complete_path: $!"; + + my ($newest_name, $newest_time); + while ( defined( my $file = readdir( $dh ) ) ) { + my $path = File::Spec->catfile( $complete_path, $file ); + next if -d $path; # skip directories, or anything else you like + ( $newest_name, $newest_time ) = ( $file, -M _ ) if( ! defined $newest_time or -M $path < $newest_time ); + } + + closedir $dh; + + $latest_file_name = File::Spec->catfile($complete_path, $newest_name); + my $filesize = stat($latest_file_name)->size; + + my $current_file = File::Spec->catfile($form->{tmpdir}, apply { s:.*/:: } $form->{tmpfile}); + my $current_filesize = -f $current_file ? stat($current_file)->size : 0; + + if ($current_filesize == $filesize) { + $::lxdebug->leave_sub(); + return; + } + + my $timestamp = get_current_formatted_time(); + my $new_file = File::Spec->catfile($form->{cwd}, $webdav_folder, $form->generate_attachment_filename()); + $new_file =~ s{(.*)\.}{$1$timestamp\.}; + + if (!File::Copy::copy($current_file, $new_file)) { + $::lxdebug->message(LXDebug::WARN(), "Copy file from $current_file to $new_file failed: $ERRNO"); + $::form->error($::locale->text("Copy file from #1 to #2 failed: #3", $current_file, $new_file, $ERRNO)); + } + + $::lxdebug->leave_sub(); +} + +sub get_current_formatted_time { + return POSIX::strftime('_%Y%m%d_%H%M%S', localtime()); } 1; +__END__ + +=pod + +=encoding utf8 + +=head1 NAME + +Common - Common routines used in a lot of places. + +=head1 SYNOPSIS + + my $short_text = Common::truncate($long_text, at => 10); + +=head1 FUNCTIONS + +=over 4 + +=item C + +Truncates C<$text> at a position and insert an ellipsis if the text is +longer. The maximum number of characters to return is given with the +paramter C which defaults to 50. + +The optional parameter C can be used to remove unwanted line +feed/carriage return characters from the text before truncation. It +can be set to C<1> (only strip those at the end of C<$text>) or +C (replace consecutive line feed/carriage return characters in +the middle by a single space and remove tailing line feed/carriage +return characters). + +=back + +=head1 BUGS + +Nothing here yet. + +=head1 AUTHOR + +Moritz Bunkus Em.bunkus@linet-services.deE, +Sven Schöling Es.schoeling@linet-services.deE + +=cut