X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FDBUpgrade2%2FBase.pm;h=cd698c5e59b8d9b0c4cbecc3a878233858665bbc;hb=9c2d09b80c7fe80982c4e63b5fb051002a152411;hp=25e0777d4b2b95d010a27bb9c06ec14717635fc6;hpb=347f2cff58f8d798bb0fe52495fb09b4e08db036;p=kivitendo-erp.git diff --git a/SL/DBUpgrade2/Base.pm b/SL/DBUpgrade2/Base.pm index 25e0777d4..cd698c5e5 100644 --- a/SL/DBUpgrade2/Base.pm +++ b/SL/DBUpgrade2/Base.pm @@ -4,7 +4,17 @@ use strict; use parent qw(Rose::Object); +use Carp; +use Encode; use English qw(-no_match_vars); +use File::Basename (); +use File::Copy (); +use File::Path (); +use List::MoreUtils qw(uniq); +use SL::DBUtils qw(selectfirst_hashref_query); +use SL::Presenter::EscapedText qw(escape); +use version; + use Rose::Object::MakeMethods::Generic ( scalar => [ qw(dbh myconfig) ], ); @@ -21,9 +31,10 @@ sub execute_script { die $EVAL_ERROR; } + my $auth = $file_name =~ m{/Pg-upgrade2-auth/} ? 'Auth::' : ''; my $package = delete $params{tag}; $package =~ s/[^a-zA-Z0-9_]+/_/g; - $package = "SL::DBUpgrade2::${package}"; + $package = "SL::DBUpgrade2::${auth}${package}"; $package->new(%params)->run; } @@ -31,18 +42,34 @@ sub execute_script { sub db_error { my ($self, $msg) = @_; - die $self->locale->text("Database update error:") . "
$msg
" . $DBI::errstr; + die $::locale->text("Database update error:") . "
$msg
" . $self->db_errstr('DBI'); } sub db_query { - my ($self, $query, $may_fail) = @_; + my ($self, $query, %params) = @_; + + my $dbh = $params{dbh} || $self->dbh; + + return if $dbh->do($query, undef, @{ $params{bind} || [] }); + + $self->db_error($query) unless $params{may_fail}; + + $dbh->rollback; + $dbh->begin_work; +} + +sub db_errstr { + my ($self, $handle) = @_; - return if $self->dbh->do($query); + # DBD::Pg before 2.16.1 doesn't set the UTF-8 flag for error + # messages even if the connection has UTF-8 enabled. Therefore we + # have to convert it to Perl's internal encoding ourselves. See + # https://rt.cpan.org/Public/Bug/Display.html?id=53854 - $self->db_error($query) unless $may_fail; + my $error = $handle ? $handle->errstr : $self->dbh->errstr; - $self->dbh->rollback; - $self->dbh->begin_work; + return $error if version->new("$DBD::Pg::VERSION")->numify >= version->new("2.16.1")->numify; + return Encode::decode('utf-8', $error); } sub check_coa { @@ -64,6 +91,80 @@ sub is_coa_empty { return !$empty; } +sub add_print_templates { + my ($self, $src_dir, @files) = @_; + + $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: src_dir $src_dir files " . join(' ', @files)); + + foreach (@files) { + croak "File '${src_dir}/$_' does not exist" unless -f "${src_dir}/$_"; + } + + # can't use Rose or InstanceConf here because defaults might not be fully upgraded yet. + my $defaults = selectfirst_hashref_query($::form, $::form->get_standard_dbh, "SELECT * FROM defaults"); + return 1 unless my $template_dir = $defaults->{template}; + $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dir $template_dir"); + + foreach my $src_file (@files) { + my $dest_file = $template_dir . '/' . $src_file; + + if (-f $dest_file) { + $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}"); + next; + } + + my $dest_dir = File::Basename::dirname($dest_file); + + if ($dest_dir && !-d $dest_dir) { + File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!"; + } + + File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!"; + + $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'"); + } + + return 1; +} + +sub drop_constraints { + my ($self, %params) = @_; + + croak "Missing parameter 'table'" unless $params{table}; + $params{type} ||= 'FOREIGN KEY'; + $params{schema} ||= 'public'; + + my $constraints = $self->dbh->selectall_arrayref(<db_query(qq|ALTER TABLE $params{schema}."$params{table}" DROP CONSTRAINT "${_}"|) for map { $_->[0] } @{ $constraints }; +} + +sub convert_column_to_html { + my ($self, $table, $column) = @_; + + my $sth = $self->dbh->prepare(qq|UPDATE $table SET $column = ? WHERE id = ?|) || $self->dberror; + + foreach my $row (selectall_hashref_query($::form, $self->dbh, qq|SELECT id, $column FROM $table WHERE $column IS NOT NULL|)) { + next if !$row->{$column} || (($row->{$column} =~ m{^<[a-z]+>}) && ($row->{$column} =~ m{$})); + + my $new_content = "" . escape($row->{$column}); + $new_content =~ s{\r}{}g; + $new_content =~ s{\n\n+}{

}g; + $new_content =~ s{\n}{
}g; + $new_content = "

${new_content}

" if $new_content; + + $sth->execute($new_content, $row->{id}) if $new_content ne $row->{$column}; + } + + $sth->finish; +} + 1; __END__ @@ -105,11 +206,52 @@ the current database. =back - =head1 FUNCTIONS =over 4 +=item C + +Adds (copies) new print templates to existing users. All existing +users in the authentication database are read. The listed C<@files> +are copied to each user's configured templates directory preserving +sub-directory structure (non-existing sub-directories will be +created). If a template with the same name exists it will be skipped. + +The source file names must all be relative to the source directory +C<$source_dir>. This way only the desired sub-directories are created +in the users' template directories. Example: + + $self->add_print_templates( + 'templates/print/Standard', + qw(receipt.tex common.sty images/background.png) + ); + +Let's assume a user's template directory is +C. The call above would trigger five actions: + +=over 2 + +=item 1. Create the directory C if it doesn't +exist. + +=item 2. Copy C to +C if there's no such file in that +directory. + +=item 3. Copy C to +C if there's no such file in that +directory. + +=item 4. Create the directory C if it +doesn't exist. + +=item 5. Copy C to +C if there's no such +file in that directory. + +=back + =item C Returns trueish if the database uses the chart of accounts named @@ -119,13 +261,66 @@ C<$coa_name>. Outputs an error message C<$message> to the user and aborts execution. -=item C +=item C + +Executes an SQL query. The following parameters are supported: + +=over 2 + +=item C + +What the method does if the query fails depends on this parameter. If +it is falsish (the default) then the method will simply die outputting +the error message via L. If C is trueish then the +current transaction will be rolled back, a new one will be started. + +=item C + +An optional array reference containing bind parameter for the query. + +=item C + +The database handle to use. If undefined then C<$self-Edbh> will +be used. -Executes an SQL query. What the method does if the query fails depends -on C<$may_fail>. If it is falsish then the method will simply die -outputting the error message via L. If C<$may_fail> is -trueish then the current transaction will be rolled back, a new one -will be started +=back + +=item C + +Returns the last database from C<$handle> error message encoded in +Perl's internal encoding. The PostgreSQL DBD before 2.16.1 leaves the +UTF-8 flag off for error messages even if the C +attribute is set. For older versions the error string is already +encoded correctly and is left unchanged. + +C<$handle> is optional and can be one of three things: + +=over 2 + +=item 1. A database or statement handle. In that case +C<$handle-Eerrstr> is used. + +=item 2. The string 'DBI'. In that case C<$DBI::errstr> is used. + +=item 3. If it is undefined then C<$self-Edbh-Eerrstr> is +used. + +=back + +=item C + +Drops all constraints of a type (e.g. foreign keys) on a table. One +parameter is mandatory: C. Optional parameters include: + +=over 2 + +=item * C -- if missing defaults to C + +=item * C -- if missing defaults to C. Must be one of +the values contained in the C +view in the C column. + +=back =item C @@ -144,6 +339,11 @@ C yet. This method is the entry point for the actual upgrade. Each upgrade script must provide this method. +=item C + +Converts the content of a single column from text to HTML suitable for +use with the ckeditor. + =back =head1 BUGS