SL/DBUpgrade2/Base.pm

   1 package SL::DBUpgrade2::Base;
   2
   3 use strict;
   4
   5 use parent qw(Rose::Object);
   6
   7 use English qw(-no_match_vars);
   8 use Rose::Object::MakeMethods::Generic (
   9   scalar => [ qw(dbh myconfig) ],
  10 );
  11
  12 use SL::DBUtils;
  13
  14 sub execute_script {
  15   my (%params) = @_;
  16
  17   my $file_name = delete $params{file_name};
  18
  19   if (!eval { require $file_name }) {
  20     delete $INC{$file_name};
  21     die $EVAL_ERROR;
  22   }
  23
  24   my $package =  delete $params{tag};
  25   $package    =~ s/[^a-zA-Z0-9_]+/_/g;
  26   $package    =  "SL::DBUpgrade2::${package}";
  27
  28   $package->new(%params)->run;
  29 }
  30
  31 sub db_error {
  32   my ($self, $msg) = @_;
  33
  34   die $self->locale->text("Database update error:") . "<br>$msg<br>" . $DBI::errstr;
  35 }
  36
  37 sub db_query {
  38   my ($self, $query, $may_fail) = @_;
  39
  40   return if $self->dbh->do($query);
  41
  42   $self->db_error($query) unless $may_fail;
  43
  44   $self->dbh->rollback;
  45   $self->dbh->begin_work;
  46 }
  47
  48 sub check_coa {
  49   my ($self, $wanted_coa) = @_;
  50
  51   my ($have_coa)          = selectrow_query($::form, $self->dbh, q{ SELECT count(*) FROM defaults WHERE coa = ? }, $wanted_coa);
  52
  53   return $have_coa;
  54 }
  55
  56 sub is_coa_empty {
  57   my ($self) = @_;
  58
  59   my $query = q{ SELECT count(*)
  60                  FROM ar, ap, gl, invoice, acc_trans, customer, vendor, parts
  61                };
  62   my ($empty) = selectrow_query($::form, $self->dbh, $query);
  63
  64   return !$empty;
  65 }
  66
  67 1;
  68 __END__
  69
  70 =pod
  71
  72 =encoding utf8
  73
  74 =head1 NAME
  75
  76 SL::DBUpgrade2::Base - Base class for Perl-based database upgrade files
  77
  78 =head1 OVERVIEW
  79
  80 Database scripts written in Perl must be derived from this class and
  81 provide a method called C<run>.
  82
  83 The functions in this base class offer functionality for the upgrade
  84 scripts.
  85
  86 =head1 PROPERTIES
  87
  88 The following properties (which can be accessed with
  89 C<$self-E<gt>property_name>) are available to the database upgrade
  90 script:
  91
  92 =over 4
  93
  94 =item C<dbh>
  95
  96 The database handle; an Instance of L<DBI>. It is connected, and a
  97 transaction has been started right before the script (the method
  98 L</run>)) was executed.
  99
 100 =item C<myconfig>
 101
 102 The stripped-down version of the C<%::myconfig> hash: this hash
 103 reference only contains the database connection parameters applying to
 104 the current database.
 105
 106 =back
 107
 108
 109 =head1 FUNCTIONS
 110
 111 =over 4
 112
 113 =item C<check_coa $coa_name>
 114
 115 Returns trueish if the database uses the chart of accounts named
 116 C<$coa_name>.
 117
 118 =item C<db_error $message>
 119
 120 Outputs an error message C<$message> to the user and aborts execution.
 121
 122 =item C<db_query $query, $may_fail>
 123
 124 Executes an SQL query. What the method does if the query fails depends
 125 on C<$may_fail>. If it is falsish then the method will simply die
 126 outputting the error message via L</db_error>. If C<$may_fail> is
 127 trueish then the current transaction will be rolled back, a new one
 128 will be started
 129
 130 =item C<execute_script>
 131
 132 Executes a named database upgrade script. This function is not
 133 supposed to be called from an upgrade script. Instead, the upgrade
 134 manager L<SL::DBUpgrade2> uses it in order to execute the actual
 135 database upgrade scripts.
 136
 137 =item C<is_coa_empty>
 138
 139 Returns trueish if no transactions have been recorded in the table
 140 C<acc_trans> yet.
 141
 142 =item C<run>
 143
 144 This method is the entry point for the actual upgrade. Each upgrade
 145 script must provide this method.
 146
 147 =back
 148
 149 =head1 BUGS
 150
 151 Nothing here yet.
 152
 153 =head1 AUTHOR
 154
 155 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 156
 157 =cut