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