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