Merge branch 'b-3.6.1' into mebil
[kivitendo-erp.git] / 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::Log4perl/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