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