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 1;
 147 __END__
 148
 149 =pod
 150
 151 =encoding utf8
 152
 153 =head1 NAME
 154
 155 SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
 156
 157 =head1 OVERVIEW
 158
 159 Database scripts written in Perl must be derived from this class and
 160 provide a method called C<run>.
 161
 162 The functions in this base class offer functionality for the upgrade
 163 scripts.
 164
 165 =head1 PROPERTIES
 166
 167 The following properties (which can be accessed with
 168 C<$self-E<gt>property_name>) are available to the database upgrade
 169 script:
 170
 171 =over 4
 172
 173 =item C<dbh>
 174
 175 The database handle; an Instance of L<DBI>. It is connected, and a
 176 transaction has been started right before the script (the method
 177 L</run>)) was executed.
 178
 179 =item C<myconfig>
 180
 181 The stripped-down version of the C<%::myconfig> hash: this hash
 182 reference only contains the database connection parameters applying to
 183 the current database.
 184
 185 =back
 186
 187 =head1 FUNCTIONS
 188
 189 =over 4
 190
 191 =item C<add_print_templates $source_dir, @files>
 192
 193 Adds (copies) new print templates to existing users. All existing
 194 users in the authentication database are read. The listed C<@files>
 195 are copied to each user's configured templates directory preserving
 196 sub-directory structure (non-existing sub-directories will be
 197 created). If a template with the same name exists it will be skipped.
 198
 199 The source file names must all be relative to the source directory
 200 C<$source_dir>. This way only the desired sub-directories are created
 201 in the users' template directories. Example:
 202
 203   $self->add_print_templates(
 204     'templates/print/Standard',
 205     qw(receipt.tex common.sty images/background.png)
 206   );
 207
 208 Let's assume a user's template directory is
 209 C<templates/big-money-inc>. The call above would trigger five actions:
 210
 211 =over 2
 212
 213 =item 1. Create the directory C<templates/big-money-inc> if it doesn't
 214 exist.
 215
 216 =item 2. Copy C<templates/print/Standard/receipt.tex> to
 217 C<templates/big-money-inc/receipt.tex> if there's no such file in that
 218 directory.
 219
 220 =item 3. Copy C<templates/print/Standard/common.sty> to
 221 C<templates/big-money-inc/common.sty> if there's no such file in that
 222 directory.
 223
 224 =item 4. Create the directory C<templates/big-money-inc/images> if it
 225 doesn't exist.
 226
 227 =item 5. Copy C<templates/print/Standard/images/background.png> to
 228 C<templates/big-money-inc/images/background.png> if there's no such
 229 file in that directory.
 230
 231 =back
 232
 233 =item C<check_coa $coa_name>
 234
 235 Returns trueish if the database uses the chart of accounts named
 236 C<$coa_name>.
 237
 238 =item C<db_error $message>
 239
 240 Outputs an error message C<$message> to the user and aborts execution.
 241
 242 =item C<db_query $query, %params>
 243
 244 Executes an SQL query. The following parameters are supported:
 245
 246 =over 2
 247
 248 =item C<may_fail>
 249
 250 What the method does if the query fails depends on this parameter. If
 251 it is falsish (the default) then the method will simply die outputting
 252 the error message via L</db_error>. If C<may_fail> is trueish then the
 253 current transaction will be rolled back, a new one will be started.
 254
 255 =item C<bind>
 256
 257 An optional array reference containing bind parameter for the query.
 258
 259 =item C<dbh>
 260
 261 The database handle to use. If undefined then C<$self-E<gt>dbh> will
 262 be used.
 263
 264 =back
 265
 266 =item C<db_errstr [$handle]>
 267
 268 Returns the last database from C<$handle> error message encoded in
 269 Perl's internal encoding. The PostgreSQL DBD before 2.16.1 leaves the
 270 UTF-8 flag off for error messages even if the C<pg_enable_utf8>
 271 attribute is set. For older versions the error string is already
 272 encoded correctly and is left unchanged.
 273
 274 C<$handle> is optional and can be one of three things:
 275
 276 =over 2
 277
 278 =item 1. A database or statement handle. In that case
 279 C<$handle-E<gt>errstr> is used.
 280
 281 =item 2. The string 'DBI'. In that case C<$DBI::errstr> is used.
 282
 283 =item 3. If it is undefined then C<$self-E<gt>dbh-E<gt>errstr> is
 284 used.
 285
 286 =back
 287
 288 =item C<drop_constraints %params>
 289
 290 Drops all constraints of a type (e.g. foreign keys) on a table. One
 291 parameter is mandatory: C<table>. Optional parameters include:
 292
 293 =over 2
 294
 295 =item * C<schema> -- if missing defaults to C<public>
 296
 297 =item * C<type> -- if missing defaults to C<FOREIGN KEY>. Must be one of
 298 the values contained in the C<information_schema.table_constraints>
 299 view in the C<constraint_type> column.
 300
 301 =back
 302
 303 =item C<execute_script>
 304
 305 Executes a named database upgrade script. This function is not
 306 supposed to be called from an upgrade script. Instead, the upgrade
 307 manager L<SL::DBUpgrade2> uses it in order to execute the actual
 308 database upgrade scripts.
 309
 310 =item C<is_coa_empty>
 311
 312 Returns trueish if no transactions have been recorded in the table
 313 C<acc_trans> yet.
 314
 315 =item C<run>
 316
 317 This method is the entry point for the actual upgrade. Each upgrade
 318 script must provide this method.
 319
 320 =back
 321
 322 =head1 BUGS
 323
 324 Nothing here yet.
 325
 326 =head1 AUTHOR
 327
 328 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 329
 330 =cut