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