File Coverage

blib/lib/Dancer/Plugin/Database/Core.pm
Criterion Covered Total %
statement 8 129 6.2
branch 0 68 0.0
condition 0 48 0.0
subroutine 3 12 25.0
pod 1 1 100.0
total 12 258 4.6


line stmt bran cond sub pod time code
1             package Dancer::Plugin::Database::Core;
2              
3 1     1   45023 use 5.006;
  1         3  
4 1     1   5 use strict;
  1         1  
  1         37  
5 1     1   5 use warnings FATAL => 'all';
  1         6  
  1         1102  
6              
7             =head1 NAME
8              
9             Dancer::Plugin::Database::Core - Shared core for D1 and D2 Database plugins
10              
11             =cut
12              
13             our $VERSION = '0.16';
14              
15             my %handles;
16             # Hashref used as key for default handle, so we don't have a magic value that
17             # the user could use for one of their connection names and cause problems
18             # (Kudos to Igor Bujna for the idea)
19             my $def_handle = {};
20              
21             =head1 SYNOPSIS
22              
23             This module should not be used directly. It is a shared library for
24             L and L modules.
25              
26             =head1 METHODS
27              
28             =head2 database
29              
30             Implements the C keyword.
31              
32             =cut
33              
34             sub database {
35 0     0 1   my %args = @_;
36 0   0       my $arg = $args{arg} || undef;
37 0   0       my $settings = $args{settings} || {};
38 0   0 0     my $logger = $args{logger} || sub {}; ## die?
39 0   0 0     my $hook_exec = $args{hook_exec} || sub {}; ## die?
40              
41             # The key to use to store this handle in %handles. This will be either the
42             # name supplied to database(), the hashref supplied to database() (thus, as
43             # long as the same hashref of settings is passed, the same handle will be
44             # reused) or $def_handle if database() is called without args:
45 0           my $handle_key;
46             my $conn_details; # connection settings to use.
47 0           my $handle;
48              
49             # Accept a hashref of settings to use, if desired. If so, we use this
50             # hashref to look for the handle, too, so as long as the same hashref is
51             # passed to the database() keyword, we'll reuse the same handle:
52 0 0         if (ref $arg eq 'HASH') {
53 0           $handle_key = $arg;
54 0           $conn_details = _merge_settings($arg, $settings, $logger);
55             } else {
56 0 0         $handle_key = defined $arg ? $arg : $def_handle;
57 0           $conn_details = _get_settings($arg, $settings, $logger);
58 0 0         if (!$conn_details) {
59 0   0       $logger->(error => "No DB settings for " . ($arg || "default connection"));
60 0           return (undef, $settings);
61             }
62             }
63              
64             # To be fork safe and thread safe, use a combination of the PID and TID (if
65             # running with use threads) to make sure no two processes/threads share
66             # handles. Implementation based on DBIx::Connector by David E. Wheeler.
67 0           my $pid_tid = $$;
68 0 0         $pid_tid .= '_' . threads->tid if $INC{'threads.pm'};
69              
70             # OK, see if we have a matching handle
71 0   0       $handle = $handles{$pid_tid}{$handle_key} || {};
72              
73 0 0         if ($handle->{dbh}) {
74             # If we should never check, go no further:
75 0 0         if (!$conn_details->{connection_check_threshold}) {
76 0           return ($handle->{dbh}, $settings);
77             }
78              
79 0 0 0       if ($handle->{dbh}{Active} && $conn_details->{connection_check_threshold} &&
      0        
80             time - $handle->{last_connection_check}
81             < $conn_details->{connection_check_threshold})
82             {
83 0           return ($handle->{dbh}, $settings);
84             } else {
85 0 0         if (_check_connection($handle->{dbh})) {
86 0           $handle->{last_connection_check} = time;
87 0           return ($handle->{dbh}, $settings);
88             } else {
89              
90 0           $logger->(debug => "Database connection went away, reconnecting");
91 0           $hook_exec->('database_connection_lost', $handle->{dbh});
92              
93 0 0         if ($handle->{dbh}) {
94 0           eval { $handle->{dbh}->disconnect }
  0            
95             }
96              
97             # Need a new handle.
98             # Fall through to the new connection codepath to get one.
99             }
100             }
101             }
102              
103             # Get a new connection
104 0           $handle->{dbh} = _get_connection($conn_details, $logger, $hook_exec);
105              
106 0 0         if ($handle->{dbh}) {
107              
108 0           $handle->{last_connection_check} = time;
109 0           $handles{$pid_tid}{$handle_key} = $handle;
110              
111 0 0 0       if (ref $handle_key && ref $handle_key ne ref $def_handle) {
112             # We were given a hashref of connection settings. Shove a
113             # reference to that hashref into the handle, so that the hashref
114             # doesn't go out of scope for the life of the handle.
115             # Otherwise, that area of memory could be re-used, and, given
116             # different DB settings in a hashref that just happens to have
117             # the same address, we'll happily hand back the original handle.
118             # See http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=665221
119             # Thanks to Sam Kington for suggesting this fix :)
120 0           $handle->{_orig_settings_hashref} = $handle_key;
121             }
122              
123 0           return ($handle->{dbh}, $settings);
124             } else {
125 0           return (undef, $settings);
126             }
127              
128             }
129              
130              
131             sub _merge_settings {
132 0     0     my ($arg, $settings, $logger) = @_;
133 0           $arg->{charset} = $settings->{charset};
134              
135 0           $arg = _set_defaults($arg);
136              
137 0           return $arg;
138             }
139              
140             sub _get_settings {
141 0     0     my ($name, $settings, $logger) = @_;
142 0           my $return_settings;
143              
144             # If no name given, just return the default settings
145 0 0         if (!defined $name) {
146 0           $return_settings = { %$settings };
147 0 0 0       if (!$return_settings->{driver} && !$return_settings->{dsn}) {
148 0           $logger->('error',
149             "Asked for default connection (no name given)"
150             ." but no default connection details found in config"
151             );
152             }
153             } else {
154             # If there are no named connections in the config, bail now:
155 0 0         return unless exists $settings->{connections};
156              
157              
158             # OK, find a matching config for this name:
159 0 0         if (my $named_settings = $settings->{connections}{$name}) {
160             # Take a (shallow) copy of the settings, so we don't change them
161 0           $return_settings = { %$named_settings };
162             } else {
163             # OK, didn't match anything
164 0           $logger->('error',
165             "Asked for a database handle named '$name' but no matching "
166             ."connection details found in config"
167             );
168             }
169             }
170              
171 0           $return_settings = _set_defaults($return_settings);
172              
173 0           return $return_settings;
174             }
175              
176             sub _set_defaults {
177 0     0     my $return_settings = shift;
178             # We should have something to return now; make sure we have a
179             # connection_check_threshold, then return what we found. In previous
180             # versions the documentation contained a typo mentioning
181             # connectivity-check-threshold, so support that as an alias.
182 0 0 0       if (exists $return_settings->{'connectivity-check-threshold'}
183             && !exists $return_settings->{connection_check_threshold})
184             {
185             $return_settings->{connection_check_threshold}
186 0           = delete $return_settings->{'connectivity-check-threshold'};
187             }
188              
189             # If the setting wasn't provided, default to 30 seconds; if a false value is
190             # provided, though, leave it alone. (Older versions just checked for
191             # truthiness, so a value of zero would still default to 30 seconds, which
192             # isn't ideal.)
193 0 0         if (!exists $return_settings->{connection_check_threshold}) {
194 0           $return_settings->{connection_check_threshold} = 30;
195             }
196              
197 0           return $return_settings;
198             }
199              
200              
201             # Given the settings to use, try to get a database connection
202             sub _get_connection {
203 0     0     my ($settings, $logger, $hook_exec) = @_;
204              
205 0 0 0       if (!$settings->{dsn} && !$settings->{driver}) {
206 0           die "Can't get a database connection without settings supplied!\n"
207             . "Please check you've supplied settings in config as per the "
208             . "Dancer::Plugin::Database documentation";
209             }
210              
211             # Assemble the DSN:
212 0           my $dsn = '';
213 0           my $driver = '';
214 0 0         if ($settings->{dsn}) {
215 0           $dsn = $settings->{dsn};
216 0           ($driver) = $dsn =~ m{^dbi:([^:]+)}i;
217             } else {
218 0           $dsn = "dbi:" . $settings->{driver};
219 0           $driver = $settings->{driver};
220 0           my @extra_args;
221              
222             # DBD::SQLite wants 'dbname', not 'database', so special-case this
223             # (DBI's documentation recommends that DBD::* modules should understand
224             # 'database', but older versions of DBD::SQLite didn't; let's make
225             # things easier for our users by handling this for them):
226             # (I asked in RT #61117 for DBD::SQLite to support 'database', too; this
227             # was included in DBD::SQLite 1.33, released Mon 20 May 2011.
228             # Special-casing may as well stay, rather than forcing dependency on
229             # DBD::SQLite 1.33.
230 0 0 0       if ($driver eq 'SQLite'
      0        
231             && $settings->{database} && !$settings->{dbname}) {
232 0           $settings->{dbname} = delete $settings->{database};
233             }
234              
235 0           for (qw(database dbname host port sid server)) {
236 0 0         if (exists $settings->{$_}) {
237 0           push @extra_args, $_ . "=" . $settings->{$_};
238             }
239             }
240 0 0         if (my $even_more_dsn_args = $settings->{dsn_extra}) {
241 0           foreach my $arg ( keys %$even_more_dsn_args ) {
242 0           push @extra_args, $arg . '=' . $even_more_dsn_args->{$arg};
243             }
244             }
245 0 0         $dsn .= ':' . join(';', @extra_args) if @extra_args;
246             }
247              
248             # If the app is configured to use UTF-8, the user will want text from the
249             # database in UTF-8 to Just Work, so if we know how to make that happen, do
250             # so, unless they've set the auto_utf8 plugin setting to a false value.
251 0   0       my $app_charset = $settings->{charset} || "";
252 0 0         my $auto_utf8 = exists $settings->{auto_utf8} ? $settings->{auto_utf8} : 1;
253              
254 0 0 0       if (lc $app_charset eq 'utf-8' && $auto_utf8) {
255             # The option to pass to the DBI->connect call depends on the driver:
256 0           my %param_for_driver = (
257             SQLite => 'sqlite_unicode',
258             mysql => 'mysql_enable_utf8',
259             Pg => 'pg_enable_utf8',
260             );
261              
262 0           my $param = $param_for_driver{$driver};
263              
264 0 0 0       if ($param && !$settings->{dbi_params}{$param}) {
265 0           $logger->(
266             debug => "Adding $param to DBI connection params"
267             . " to enable UTF-8 support"
268             );
269 0           $settings->{dbi_params}{$param} = 1;
270             }
271             }
272              
273             # To support the database_error hook, use DBI's HandleError option
274             $settings->{dbi_params}{HandleError} = sub {
275 0     0     my ($error, $handle) = @_;
276 0           $hook_exec->('database_error', $error, $handle);
277 0           };
278              
279             my $dbh = DBI->connect($dsn,
280             $settings->{username}, $settings->{password}, $settings->{dbi_params}
281 0           );
282              
283 0 0         if (!$dbh) {
    0          
284 0           $logger->(error => "Database connection failed - " . $DBI::errstr);
285 0           $hook_exec->('database_connection_failed', $settings);
286 0           return undef;
287             } elsif (exists $settings->{on_connect_do}) {
288             my $to_do = ref $settings->{on_connect_do} eq 'ARRAY'
289             ? $settings->{on_connect_do}
290 0 0         : [ $settings->{on_connect_do} ];
291 0           for (@$to_do) {
292 0 0         $dbh->do($_) or
293             $logger->(error => "Failed to perform on-connect command $_");
294             }
295             }
296              
297 0           $hook_exec->('database_connected', $dbh);
298              
299             # Indicate whether queries generated by quick_query() etc in
300             # Dancer::Plugin::Database::Core::Handle should be logged or not; this seemed a
301             # little dirty, but DBI's docs encourage it
302             # ("You can stash private data into DBI handles via $h->{private_..._*}..")
303             $dbh->{private_dancer_plugin_database} = {
304 0   0       log_queries => $settings->{log_queries} || 0,
305             logger => $logger,
306             };
307              
308              
309              
310             # Re-bless it as a Dancer::Plugin::Database::Core::Handle object, to provide nice
311             # extra features (unless the config specifies a different class; if it does,
312             # this should be a subclass of Dancer::Plugin::Database::Core::Handle in order to
313             # extend the features provided by it, or a direct subclass of DBI::db (or
314             # even DBI::db itself) to bypass the features provided by D::P::D::Handle)
315             my $handle_class =
316 0   0       $settings->{handle_class} || 'Dancer::Plugin::Database::Core::Handle';
317 0           my $package = $handle_class;
318 0           $package =~ s{::}{/}g;
319 0           $package .= '.pm';
320 0           require $package;
321              
322 0           return bless($dbh => $handle_class);
323             }
324              
325              
326              
327             # Check the connection is alive
328             sub _check_connection {
329 0     0     my $dbh = shift;
330 0 0         return unless $dbh;
331 0 0         if ($dbh->{Active}) {
332 0           my $result = eval { $dbh->ping };
  0            
333              
334 0 0         return 0 if $@;
335              
336 0 0         if (int($result)) {
337             # DB driver itself claims all is OK, trust it:
338 0           return 1;
339             } else {
340             # It was "0 but true", meaning the default DBI ping implementation
341             # Implement our own basic check, by performing a real simple query.
342 0           my $ok;
343 0           eval {
344 0           $ok = $dbh->do('select 1');
345             };
346 0           return $ok;
347             }
348             } else {
349 0           return;
350             }
351             }
352              
353              
354             =head1 AUTHOR
355              
356             David Precious, C<< >>
357              
358             =head1 BUGS
359              
360             Please report any bugs or feature requests to C, or through
361             the web interface at L. I will be notified, and then you'll
362             automatically be notified of progress on your bug as I make changes.
363              
364             =head1 SUPPORT
365              
366             You can find documentation for this module with the perldoc command.
367              
368             perldoc Dancer::Plugin::Database::Core
369              
370              
371             You can also look for information at:
372              
373             =over 4
374              
375             =item * RT: CPAN's request tracker (report bugs here)
376              
377             L
378              
379             =item * AnnoCPAN: Annotated CPAN documentation
380              
381             L
382              
383             =item * CPAN Ratings
384              
385             L
386              
387             =item * Search CPAN
388              
389             L
390              
391             =back
392              
393              
394             =head1 ACKNOWLEDGEMENTS
395              
396              
397             =head1 LICENSE AND COPYRIGHT
398              
399             Copyright 2016 David Precious.
400              
401             This program is free software; you can redistribute it and/or modify it
402             under the terms of the the Artistic License (2.0). You may obtain a
403             copy of the full license at:
404              
405             L
406              
407             Any use, modification, and distribution of the Standard or Modified
408             Versions is governed by this Artistic License. By using, modifying or
409             distributing the Package, you accept this license. Do not use, modify,
410             or distribute the Package, if you do not accept this license.
411              
412             If your Modified Version has been derived from a Modified Version made
413             by someone other than you, you are nevertheless required to ensure that
414             your Modified Version complies with the requirements of this license.
415              
416             This license does not grant you the right to use any trademark, service
417             mark, tradename, or logo of the Copyright Holder.
418              
419             This license includes the non-exclusive, worldwide, free-of-charge
420             patent license to make, have made, use, er to sell, sell, import and
421             otherwise transfer the Package with respect to any patent claims
422             licensable by the Copyright Holder that are necessarily infringed by the
423             Package. If you institute patent litigation (including a cross-claim or
424             counterclaim) against any party alleging that the Package constitutes
425             direct or contributory patent infringement, then this Artistic License
426             to you shall terminate on the date that such litigation is filed.
427              
428             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
429             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
430             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
431             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
432             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
433             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
434             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
435             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
436              
437              
438             =cut
439              
440             1; # End of Dancer::Plugin::Database::Core