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, $may_fail) = @_;
  45
  46   return if $self->dbh->do($query);
  47
  48   $self->db_error($query) unless $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, $may_fail>
 208
 209 Executes an SQL query. What the method does if the query fails depends
 210 on C<$may_fail>. If it is falsish then the method will simply die
 211 outputting the error message via L</db_error>. If C<$may_fail> is
 212 trueish then the current transaction will be rolled back, a new one
 213 will be started
 214
 215 =item C<execute_script>
 216
 217 Executes a named database upgrade script. This function is not
 218 supposed to be called from an upgrade script. Instead, the upgrade
 219 manager L<SL::DBUpgrade2> uses it in order to execute the actual
 220 database upgrade scripts.
 221
 222 =item C<is_coa_empty>
 223
 224 Returns trueish if no transactions have been recorded in the table
 225 C<acc_trans> yet.
 226
 227 =item C<run>
 228
 229 This method is the entry point for the actual upgrade. Each upgrade
 230 script must provide this method.
 231
 232 =back
 233
 234 =head1 BUGS
 235
 236 Nothing here yet.
 237
 238 =head1 AUTHOR
 239
 240 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 241
 242 =cut