SL/DBConnect.pm

   1 package SL::DBConnect;
   2
   3 use strict;
   4
   5 use DBI;
   6 use SL::DB;
   7 use SL::DBConnect::Cache;
   8
   9 my %dateformat_to_datestyle = (
  10   'yy-mm-dd'   => 'ISO',
  11   'yyyy-mm-dd' => 'ISO',
  12   'mm/dd/yy'   => 'SQL, US',
  13   'dd/mm/yy'   => 'SQL, EUROPEAN',
  14   'dd.mm.yy'   => 'GERMAN'
  15 );
  16
  17 sub _connect {
  18   my ($self, @args) = @_;
  19
  20   return DBI->connect(@args) unless $::lx_office_conf{debug} && $::lx_office_conf{debug}->{dbix_log4perl};
  21
  22   require Log::Log4perl;
  23   require DBIx::Log4perl;
  24
  25   my $filename =  $::lxdebug->file;
  26   my $config   =  $::lx_office_conf{debug}->{dbix_log4perl_config};
  27   $config      =~ s/LXDEBUGFILE/${filename}/g;
  28
  29   Log::Log4perl->init(\$config);
  30   return DBIx::Log4perl->connect(@args);
  31 }
  32
  33 sub connect {
  34   my ($self, @args) = @_;
  35   @args = $self->get_connect_args if !@args;
  36   my $initial_sql = $self->get_initial_sql;
  37
  38   if (my $cached_dbh = SL::DBConnect::Cache->get(@args, $initial_sql)) {
  39     return $cached_dbh;
  40   }
  41
  42   my $dbh = $self->_connect(@args);
  43   return undef if !$dbh;
  44
  45   if ($initial_sql) {
  46     $dbh->do($initial_sql);
  47     $dbh->commit if !$dbh->{AutoCommit};
  48   }
  49   SL::DBConnect::Cache->store($dbh, @args, $initial_sql);
  50
  51   return $dbh;
  52 }
  53
  54 sub get_datestyle {
  55   my ($self, $dateformat) = @_;
  56   return $dateformat_to_datestyle{ $dateformat || $::myconfig{dateformat} // '' };
  57 }
  58
  59 sub get_initial_sql {
  60   my ($self) = @_;
  61
  62   return undef if !%::myconfig || !$::myconfig{dateformat};
  63
  64   my $datestyle = $self->get_datestyle;
  65   return $datestyle ? qq|SET DateStyle to '${datestyle}'| : '';
  66 }
  67
  68 sub get_connect_args {
  69   my ($self, @args)   = @_;
  70   my ($domain, $type) = SL::DB::_register_db(SL::DB->default_domain, 'KIVITENDO');
  71   my $db_cfg          = SL::DB->registry->entry(domain => $domain, type => $type) || { };
  72
  73   return (
  74     'dbi:Pg:dbname=' . $db_cfg->{database} . ';host=' . ($db_cfg->{host} || 'localhost') . ';port=' . ($db_cfg->{port} || 5432),
  75     $db_cfg->{username},
  76     $db_cfg->{password},
  77     $self->get_options(%{ $db_cfg->{connect_options} || {} }, @args),
  78   );
  79 }
  80
  81 sub get_options {
  82   my $self    = shift;
  83   my $options = {
  84     pg_enable_utf8 => 1,
  85     @_
  86   };
  87
  88   return $options;
  89 }
  90
  91 1;
  92 __END__
  93
  94 =pod
  95
  96 =encoding utf8
  97
  98 =head1 NAME
  99
 100 SL::DBConnect - Connect to database for configured client/user,
 101 optionally routing through DBIx::Log4perl
 102
 103 =head1 SYNOPSIS
 104
 105   # Connect to default database of current user/client, disabling auto
 106   # commit mode:
 107   my @options_suitable_for_dbi_connect =
 108     SL::DBConnect->get_connect_args(AutoCommit => 0);
 109   my $dbh = SL::DBConnect->connect(@options_suitable_for_dbi_connect);
 110
 111   # Connect to a very specific database:
 112   my $dbh = SL::DBConnect->connect('dbi:Pg:dbname=demo', 'user', 'password');
 113
 114 =head1 FUNCTIONS
 115
 116 =over 4
 117
 118 =item C<connect [@dbi_args]>
 119
 120 Connects to the database. If the configuration parameter
 121 C<debug.dbix_log4perl> is set then the call is made through
 122 L<DBIx::Log4per/connect>. Otherwise L<DBI/connect> is called directly.
 123
 124 In each case C<@dbi_args> is passed through as-is.
 125
 126 If C<@dbi_args> are not given they're generated by a call to
 127 L</get_connect_args>.
 128
 129 =item C<get_connect_args [%options]>
 130
 131 Returns an array of database connection settings suitable to a call to
 132 L<DBI/connect> or L</connect>. The settings to use are retrieved by
 133 calling L<SL::DB/_register_db>.
 134
 135 This requires that a client has been set up with
 136 L<SL::Auth/set_client> or that C<%::myconfig> contains legacy
 137 connection settings.
 138
 139 C<%options> are optional database options like C<AutoCommit> (fourth
 140 parameter to L<DBI/connect>). They're merged with default settings by
 141 filtering them through L/get_options>.
 142
 143 =item C<get_datestyle [$dateformat]>
 144
 145 Returns the appropriate value for the C<SET DateStyle to...> SQL call
 146 depending on C<$dateformat> (e.g. C<SQL, EUROPEAN> if C<$dateformat>
 147 equals C<dd.mm.yy>). If C<$dateformat> is not given then it defaults
 148 to C<$::myconfig{dateformat}>.
 149
 150 =item C<get_initial_sql>
 151
 152 Returns SQL commands that should be executed right after a connection
 153 has been established. This is usually the call to configure the
 154 C<DateStyle> format used by the database.
 155
 156 =item C<get_options [%options]>
 157
 158 Returns a hash reference of database options (fourth parameter to
 159 L<DBI/connect>) merged with certain default options.
 160
 161 =back
 162
 163 =head1 BUGS
 164
 165 Nothing here yet.
 166
 167 =head1 AUTHOR
 168
 169 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 170
 171 =cut