SL/DBUpgrade2/Base.pm

   1 package SL::DBUpgrade2::Base;
   2
   3 use strict;
   4
   5 use parent qw(Rose::Object);
   6
   7 use Carp;
   8 use Encode;
   9 use English qw(-no_match_vars);
  10 use File::Basename ();
  11 use File::Copy ();
  12 use File::Path ();
  13 use List::MoreUtils qw(uniq);
  14 use SL::DBUtils qw(selectfirst_hashref_query);
  15 use SL::Presenter::EscapedText qw(escape);
  16 use version;
  17
  18 use Rose::Object::MakeMethods::Generic (
  19   scalar => [ qw(dbh myconfig) ],
  20 );
  21
  22 use SL::DBUtils;
  23
  24 sub execute_script {
  25   my (%params) = @_;
  26
  27   my $file_name = delete $params{file_name};
  28
  29   if (!eval { require $file_name }) {
  30     delete $INC{$file_name};
  31     die $EVAL_ERROR;
  32   }
  33
  34   my $auth    =  $file_name =~ m{/Pg-upgrade2-auth/} ? 'Auth::' : '';
  35   my $package =  delete $params{tag};
  36   $package    =~ s/[^a-zA-Z0-9_]+/_/g;
  37   $package    =  "SL::DBUpgrade2::${auth}${package}";
  38
  39   $package->new(%params)->run;
  40 }
  41
  42 sub db_error {
  43   my ($self, $msg) = @_;
  44
  45   die $::locale->text("Database update error:") . "<br>$msg<br>" . $self->db_errstr('DBI');
  46 }
  47
  48 sub db_query {
  49   my ($self, $query, %params) = @_;
  50
  51   my $dbh = $params{dbh} || $self->dbh;
  52
  53   return if $dbh->do($query, undef, @{ $params{bind} || [] });
  54
  55   $self->db_error($query) unless $params{may_fail};
  56
  57   $dbh->rollback;
  58   $dbh->begin_work;
  59 }
  60
  61 sub db_errstr {
  62   my ($self, $handle) = @_;
  63
  64   # DBD::Pg before 2.16.1 doesn't set the UTF-8 flag for error
  65   # messages even if the connection has UTF-8 enabled. Therefore we
  66   # have to convert it to Perl's internal encoding ourselves. See
  67   # https://rt.cpan.org/Public/Bug/Display.html?id=53854
  68
  69   my $error = $handle ? $handle->errstr : $self->dbh->errstr;
  70
  71   return $error if version->new("$DBD::Pg::VERSION")->numify >= version->new("2.16.1")->numify;
  72   return Encode::decode('utf-8', $error);
  73 }
  74
  75 sub check_coa {
  76   my ($self, $wanted_coa) = @_;
  77
  78   my ($have_coa)          = selectrow_query($::form, $self->dbh, q{ SELECT count(*) FROM defaults WHERE coa = ? }, $wanted_coa);
  79
  80   return $have_coa;
  81 }
  82
  83 sub is_coa_empty {
  84   my ($self) = @_;
  85
  86   my $query = q{ SELECT count(*)
  87                  FROM ar, ap, gl, invoice, acc_trans, customer, vendor, parts
  88                };
  89   my ($empty) = selectrow_query($::form, $self->dbh, $query);
  90
  91   return !$empty;
  92 }
  93
  94 sub add_print_templates {
  95   my ($self, $src_dir, @files) = @_;
  96
  97   $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: src_dir $src_dir files " . join('  ', @files));
  98
  99   foreach (@files) {
 100     croak "File '${src_dir}/$_' does not exist" unless -f "${src_dir}/$_";
 101   }
 102
 103   # can't use Rose or InstanceConf here because defaults might not be fully upgraded yet.
 104   my $defaults = selectfirst_hashref_query($::form, $::form->get_standard_dbh, "SELECT * FROM defaults");
 105   return 1 unless my $template_dir = $defaults->{template};
 106   $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: template_dir $template_dir");
 107
 108   foreach my $src_file (@files) {
 109     my $dest_file = $template_dir . '/' . $src_file;
 110
 111     if (-f $dest_file) {
 112       $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: dest_file exists, skipping: ${dest_file}");
 113       next;
 114     }
 115
 116     my $dest_dir = File::Basename::dirname($dest_file);
 117
 118     if ($dest_dir && !-d $dest_dir) {
 119       File::Path::make_path($dest_dir) or die "Cannot create directory '${dest_dir}': $!";
 120     }
 121
 122     File::Copy::copy($src_dir . '/' . $src_file, $dest_file) or die "Cannot copy '${src_dir}/${src_file}' to '${dest_file}': $!";
 123
 124     $::lxdebug->message(LXDebug::DEBUG1(), "add_print_templates: copied '${src_dir}/${src_file}' to '${dest_file}'");
 125   }
 126
 127   return 1;
 128 }
 129
 130 sub drop_constraints {
 131   my ($self, %params) = @_;
 132
 133   croak "Missing parameter 'table'" unless $params{table};
 134   $params{type}   ||= 'FOREIGN KEY';
 135   $params{schema} ||= 'public';
 136
 137   my $constraints = $self->dbh->selectall_arrayref(<<SQL, undef, $params{type}, $params{schema}, $params{table});
 138     SELECT constraint_name
 139     FROM information_schema.table_constraints
 140     WHERE (constraint_type = ?)
 141       AND (table_schema    = ?)
 142       AND (table_name      = ?)
 143 SQL
 144
 145   $self->db_query(qq|ALTER TABLE $params{schema}."$params{table}" DROP CONSTRAINT "${_}"|) for map { $_->[0] } @{ $constraints };
 146 }
 147
 148 sub convert_column_to_html {
 149   my ($self, $table, $column) = @_;
 150
 151   my $sth = $self->dbh->prepare(qq|UPDATE $table SET $column = ? WHERE id = ?|) || $self->dberror;
 152
 153   foreach my $row (selectall_hashref_query($::form, $self->dbh, qq|SELECT id, $column FROM $table WHERE $column IS NOT NULL|)) {
 154     next if !$row->{$column} || (($row->{$column} =~ m{^<[a-z]+>}) && ($row->{$column} =~ m{</[a-z]+>$}));
 155
 156     my $new_content = "" . escape($row->{$column});
 157     $new_content    =~ s{\r}{}g;
 158     $new_content    =~ s{\n\n+}{</p><p>}g;
 159     $new_content    =~ s{\n}{<br />}g;
 160     $new_content    =  "<p>${new_content}</p>" if $new_content;
 161
 162     $sth->execute($new_content, $row->{id}) if $new_content ne $row->{$column};
 163   }
 164
 165   $sth->finish;
 166 }
 167
 168 1;
 169 __END__
 170
 171 =pod
 172
 173 =encoding utf8
 174
 175 =head1 NAME
 176
 177 SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
 178
 179 =head1 OVERVIEW
 180
 181 Database scripts written in Perl must be derived from this class and
 182 provide a method called C<run>.
 183
 184 The functions in this base class offer functionality for the upgrade
 185 scripts.
 186
 187 =head1 PROPERTIES
 188
 189 The following properties (which can be accessed with
 190 C<$self-E<gt>property_name>) are available to the database upgrade
 191 script:
 192
 193 =over 4
 194
 195 =item C<dbh>
 196
 197 The database handle; an Instance of L<DBI>. It is connected, and a
 198 transaction has been started right before the script (the method
 199 L</run>)) was executed.
 200
 201 =item C<myconfig>
 202
 203 The stripped-down version of the C<%::myconfig> hash: this hash
 204 reference only contains the database connection parameters applying to
 205 the current database.
 206
 207 =back
 208
 209 =head1 FUNCTIONS
 210
 211 =over 4
 212
 213 =item C<add_print_templates $source_dir, @files>
 214
 215 Adds (copies) new print templates to existing users. All existing
 216 users in the authentication database are read. The listed C<@files>
 217 are copied to each user's configured templates directory preserving
 218 sub-directory structure (non-existing sub-directories will be
 219 created). If a template with the same name exists it will be skipped.
 220
 221 The source file names must all be relative to the source directory
 222 C<$source_dir>. This way only the desired sub-directories are created
 223 in the users' template directories. Example:
 224
 225   $self->add_print_templates(
 226     'templates/print/Standard',
 227     qw(receipt.tex common.sty images/background.png)
 228   );
 229
 230 Let's assume a user's template directory is
 231 C<templates/big-money-inc>. The call above would trigger five actions:
 232
 233 =over 2
 234
 235 =item 1. Create the directory C<templates/big-money-inc> if it doesn't
 236 exist.
 237
 238 =item 2. Copy C<templates/print/Standard/receipt.tex> to
 239 C<templates/big-money-inc/receipt.tex> if there's no such file in that
 240 directory.
 241
 242 =item 3. Copy C<templates/print/Standard/common.sty> to
 243 C<templates/big-money-inc/common.sty> if there's no such file in that
 244 directory.
 245
 246 =item 4. Create the directory C<templates/big-money-inc/images> if it
 247 doesn't exist.
 248
 249 =item 5. Copy C<templates/print/Standard/images/background.png> to
 250 C<templates/big-money-inc/images/background.png> if there's no such
 251 file in that directory.
 252
 253 =back
 254
 255 =item C<check_coa $coa_name>
 256
 257 Returns trueish if the database uses the chart of accounts named
 258 C<$coa_name>.
 259
 260 =item C<db_error $message>
 261
 262 Outputs an error message C<$message> to the user and aborts execution.
 263
 264 =item C<db_query $query, %params>
 265
 266 Executes an SQL query. The following parameters are supported:
 267
 268 =over 2
 269
 270 =item C<may_fail>
 271
 272 What the method does if the query fails depends on this parameter. If
 273 it is falsish (the default) then the method will simply die outputting
 274 the error message via L</db_error>. If C<may_fail> is trueish then the
 275 current transaction will be rolled back, a new one will be started.
 276
 277 =item C<bind>
 278
 279 An optional array reference containing bind parameter for the query.
 280
 281 =item C<dbh>
 282
 283 The database handle to use. If undefined then C<$self-E<gt>dbh> will
 284 be used.
 285
 286 =back
 287
 288 =item C<db_errstr [$handle]>
 289
 290 Returns the last database from C<$handle> error message encoded in
 291 Perl's internal encoding. The PostgreSQL DBD before 2.16.1 leaves the
 292 UTF-8 flag off for error messages even if the C<pg_enable_utf8>
 293 attribute is set. For older versions the error string is already
 294 encoded correctly and is left unchanged.
 295
 296 C<$handle> is optional and can be one of three things:
 297
 298 =over 2
 299
 300 =item 1. A database or statement handle. In that case
 301 C<$handle-E<gt>errstr> is used.
 302
 303 =item 2. The string 'DBI'. In that case C<$DBI::errstr> is used.
 304
 305 =item 3. If it is undefined then C<$self-E<gt>dbh-E<gt>errstr> is
 306 used.
 307
 308 =back
 309
 310 =item C<drop_constraints %params>
 311
 312 Drops all constraints of a type (e.g. foreign keys) on a table. One
 313 parameter is mandatory: C<table>. Optional parameters include:
 314
 315 =over 2
 316
 317 =item * C<schema> -- if missing defaults to C<public>
 318
 319 =item * C<type> -- if missing defaults to C<FOREIGN KEY>. Must be one of
 320 the values contained in the C<information_schema.table_constraints>
 321 view in the C<constraint_type> column.
 322
 323 =back
 324
 325 =item C<execute_script>
 326
 327 Executes a named database upgrade script. This function is not
 328 supposed to be called from an upgrade script. Instead, the upgrade
 329 manager L<SL::DBUpgrade2> uses it in order to execute the actual
 330 database upgrade scripts.
 331
 332 =item C<is_coa_empty>
 333
 334 Returns trueish if no transactions have been recorded in the table
 335 C<acc_trans> yet.
 336
 337 =item C<run>
 338
 339 This method is the entry point for the actual upgrade. Each upgrade
 340 script must provide this method.
 341
 342 =item C<convert_column_to_html $table, $column>
 343
 344 Converts the content of a single column from text to HTML suitable for
 345 use with the ckeditor.
 346
 347 =back
 348
 349 =head1 BUGS
 350
 351 Nothing here yet.
 352
 353 =head1 AUTHOR
 354
 355 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 356
 357 =cut