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