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