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