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