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