Dancer-Plugin-Database-Core-0.14/000755 000765 000024 00000000000 12651227234 016547 5ustar00ambsstaff000000 000000 Dancer-Plugin-Database-Core-0.14/Changes000644 000765 000024 00000003651 12651227167 020054 0ustar00ambsstaff000000 000000 Revision history for Dancer-Plugin-Database-Core 0.14 2016-01-24 [ BUGFIXES ] - wrap the call to DBI ping in eval and handle results. (thanks to James Russo) - skip author tests (thanks to Stefan Hornburg) 0.13 2015-10-07 [ BUGFIXES ] - use consistent version numbering (kwaliteee++) 0.12 2015-08-16 [ BUGFIXES ] - use logger correctly for log_queries (thanks aka-raj for bug report) 0.11 2015-06-16 [ BUGFIXES ] - add correct license name (thanks Jens for poking) 0.10 2015-05-14 [ BUGFIXES ] - fix bug with hash key randomization (thanks to Nuno Carvalho) 0.09 2015-04-30 [ BUGFIXES ] - fix dsn regexp (thanks to Michael R. Davis) - Scalarrefs for raw SQL / SQL function calls - Refactor SQL generation and add tests for correctness of generated SQL 0.08 2014-10-13 [ ENHANCEMENTS ] - Support dsn_extra option (Thanks to Michael J South) 0.07 2014-09-01 [ BUILD SYSTEM ] - Added metainformation for metacpan. 0.06 2014-04-01 [ ENHANCEMENTS ] - New server config option (thanks Collin Seaton) [ BUGFIXES ] - Fix date for 0.05 release - Fix version numbers on documentation 0.05 2013-12-22 [ ENHANCEMENTS ] - New offset param [ BUGFIXES] - Cache handle after reconnection (PR-44, @jmazon) - Check for definedness for options (PR-45, e11it) 0.04 Sun Sep 1 13:51:26 WEST 2013 [ ENHANCEMENTS ] - Add quick_count method (Thanks to Colin Ewen) 0.03 Mon Aug 5 21:11:23 WEST 2013 - Fix issue when using named databases (thanks to Michael J South for reporting it) 0.02 Mon Jul 29 12:05:28 WEST 2013 - Fix DBI dependency. 0.01 Sat Jul 27 18:24:32 WEST 2013 - Module creation with D1/D2 shared stuff Dancer-Plugin-Database-Core-0.14/lib/000755 000765 000024 00000000000 12651227234 017315 5ustar00ambsstaff000000 000000 Dancer-Plugin-Database-Core-0.14/Makefile.PL000644 000765 000024 00000002275 12540063100 020512 0ustar00ambsstaff000000 000000 use 5.006; use strict; use warnings FATAL => 'all'; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Dancer::Plugin::Database::Core', AUTHOR => q{David Precious }, VERSION_FROM => 'lib/Dancer/Plugin/Database/Core.pm', ABSTRACT_FROM => 'lib/Dancer/Plugin/Database/Core.pm', LICENSE => 'artistic_2', PL_FILES => {}, MIN_PERL_VERSION => 5.006, CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => 0, }, BUILD_REQUIRES => { 'Test::More' => 0, }, PREREQ_PM => { 'DBI' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Dancer-Plugin-Database-Core-*' }, META_MERGE => { "meta-spec" => { version => 2 }, bugtracker => { web => 'https://github.com/bigpresh/Dancer-Plugin-Database/issues', }, resources => { repository => { type => 'git', web => 'https://github.com/bigpresh/Dancer-Plugin-Database', }, }, }, ); Dancer-Plugin-Database-Core-0.14/MANIFEST000644 000765 000024 00000000574 12651227234 017706 0ustar00ambsstaff000000 000000 Changes lib/Dancer/Plugin/Database/Core.pm lib/Dancer/Plugin/Database/Core/Handle.pm Makefile.PL MANIFEST This list of files README t/00-load.t t/01-handle.t t/manifest.t t/pod-coverage.t t/pod.t MANIFEST.SKIP META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Dancer-Plugin-Database-Core-0.14/MANIFEST.SKIP000644 000765 000024 00000000014 12651227153 020440 0ustar00ambsstaff000000 000000 .*\.tar\.gz Dancer-Plugin-Database-Core-0.14/META.json000644 000765 000024 00000002330 12651227234 020166 0ustar00ambsstaff000000 000000 { "abstract" : "Shared core for D1 and D2 Database plugins", "author" : [ "David Precious " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.1, CPAN::Meta::Converter version 2.150005", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Dancer-Plugin-Database-Core", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "DBI" : "0", "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "web" : "https://github.com/bigpresh/Dancer-Plugin-Database" } }, "version" : "0.14", "x_bugtracker" : { "web" : "https://github.com/bigpresh/Dancer-Plugin-Database/issues" }, "x_serialization_backend" : "JSON::PP version 2.27300" } Dancer-Plugin-Database-Core-0.14/META.yml000644 000765 000024 00000001357 12651227234 020026 0ustar00ambsstaff000000 000000 --- abstract: 'Shared core for D1 and D2 Database plugins' author: - 'David Precious ' build_requires: Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.1, CPAN::Meta::Converter version 2.150005' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Dancer-Plugin-Database-Core no_index: directory: - t - inc requires: DBI: '0' perl: '5.006' resources: repository: https://github.com/bigpresh/Dancer-Plugin-Database version: '0.14' x_bugtracker: web: https://github.com/bigpresh/Dancer-Plugin-Database/issues x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Dancer-Plugin-Database-Core-0.14/README000644 000765 000024 00000006476 12540061050 017431 0ustar00ambsstaff000000 000000 NAME Dancer::Plugin::Database::Core - Shared core for D1 and D2 Database plugins SYNOPSIS This module should not be used directly. It is a shared library for Dancer::Plugin::Database and Dancer2::Plugin::Database modules. METHODS database Implements the `database' keyword. AUTHOR David Precious, `' BUGS Please report any bugs or feature requests to `bug-dancer-plugin-database-core at rt.cpan.org', or through the web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Dancer-Plugin-Database-Co re. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. SUPPORT You can find documentation for this module with the perldoc command. perldoc Dancer::Plugin::Database::Core You can also look for information at: * RT: CPAN's request tracker (report bugs here) http://rt.cpan.org/NoAuth/Bugs.html?Dist=Dancer-Plugin-Database-Core * AnnoCPAN: Annotated CPAN documentation http://annocpan.org/dist/Dancer-Plugin-Database-Core * CPAN Ratings http://cpanratings.perl.org/d/Dancer-Plugin-Database-Core * Search CPAN http://search.cpan.org/dist/Dancer-Plugin-Database-Core/ ACKNOWLEDGEMENTS LICENSE AND COPYRIGHT Copyright 2013 David Precious. This program is free software; you can redistribute it and/or modify it under the terms of the the Artistic License (2.0). You may obtain a copy of the full license at: http://www.perlfoundation.org/artistic_license_2_0 Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, er to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Dancer-Plugin-Database-Core-0.14/t/000755 000765 000024 00000000000 12651227234 017012 5ustar00ambsstaff000000 000000 Dancer-Plugin-Database-Core-0.14/t/00-load.t000644 000765 000024 00000000553 12175515777 020353 0ustar00ambsstaff000000 000000 #!perl -T use 5.006; use strict; use warnings FATAL => 'all'; use Test::More; plan tests => 2; BEGIN { use_ok( 'Dancer::Plugin::Database::Core' ) || print "Bail out!\n"; use_ok( 'Dancer::Plugin::Database::Core::Handle' ) || print "Bail out!\n"; } diag( "Testing Dancer::Plugin::Database::Core $Dancer::Plugin::Database::Core::VERSION, Perl $], $^X" ); Dancer-Plugin-Database-Core-0.14/t/01-handle.t000644 000765 000024 00000007533 12500565374 020663 0ustar00ambsstaff000000 000000 #!perl use Test::More; use DBI; use Dancer::Plugin::Database::Core::Handle; use List::Util; diag( "Testing Dancer::Plugin::Database::Core::Handle " . "$Dancer::Plugin::Database::Core::Handle::VERSION, Perl $], $^X" ); # A few tests that poke directly at the internals of D::P::D::C::Handle. # For this to work, we'll need a dummy DBI handle to rebless. # DBD::Sponge ships with DBI, and should be sufficient for our needs. my $handle = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); bless $handle => 'Dancer::Plugin::Database::Core::Handle'; # Test the construction of ORDER BY clauses. my @order_by_tests = ( [ 'foo' => 'ORDER BY "foo"' ], [ ['foo','bar'] => 'ORDER BY "foo", "bar"' ], [ { asc => 'foo' } => 'ORDER BY "foo" ASC' ], [ [ { asc => 'foo' }, { desc => 'bar' } ] => 'ORDER BY "foo" ASC, "bar" DESC' ], ); my %quoting_tests = ( 'foo' => '"foo"', 'foo.bar' => '"foo"."bar"', ); # SQL-generation tests. Each test is an arrayref consisting of an arrayref of # params to pass to _generate_sql(), the SQL to expect, and the bind columns to # expect. my @sql_tests = ( { name => "Simple SELECT, no WHERE", params => [ 'SELECT', 'tablename', {} ], expect_sql => qq{SELECT * FROM "tablename"}, expect_bind_params => [], }, { name => "SELECT with named columns, no WHERE", params => ['SELECT', 'tablename', { columns => [qw(one two) ] } ], expect_sql => qq{SELECT "one","two" FROM "tablename"}, expect_bind_params => [], }, { name => "SELECT with literal string WHERE", params => ['SELECT', 'tablename', undef, 'BEER IS GOOD' ], expect_sql => qq{SELECT * FROM "tablename" WHERE BEER IS GOOD}, expect_bind_params => [], }, { name => "SELECT with simple WHERE values", params => [ 'SELECT', 'tablename', undef, { foo => 'One', bar => 'Two' } ], # Expected order differs - columns alphabetical expect_sql => qq{SELECT * FROM "tablename" WHERE "bar"=? AND "foo"=?}, expect_bind_params => ['Two','One'], }, { name => "INSERT with scalarrefs untouched", params => ['INSERT', 'tablename', { one => \'NOW()', two => '2' } ], expect_sql => qq{INSERT INTO "tablename" ("one","two") VALUES (NOW(),?)}, expect_bind_params => [ 2 ], }, { name => "UPDATE with scalarrefs untouched", params => ['UPDATE', 'tablename', { foo => 'Foo', counter => \'counter+1' }, { id => 42 }, ], expect_sql => qq{UPDATE "tablename" SET "counter"=counter+1,"foo"=?} . qq{ WHERE "id"=?}, expect_bind_params => ['Foo',42], }, ); my $sqlgen_test_count = List::Util::sum( map { exists $_->{expect_bind_params} ? 2 : 1 } @sql_tests ); plan tests => scalar @order_by_tests + scalar keys(%quoting_tests) + $sqlgen_test_count; my $i; for my $test (@order_by_tests) { $i++; my $res = $handle->_build_order_by_clause($test->[0]); is($res, $test->[1], sprintf "Order by test %d/%d : %s", $i, scalar @order_by_tests, $res ); } for my $identifier (keys %quoting_tests) { is( $handle->_quote_identifier($identifier), $quoting_tests{$identifier}, "Quoted '$identifier' as '$quoting_tests{$identifier}'" ); } for my $test (@sql_tests) { my ($sql, @bind_params) = $handle->_generate_sql(@{ $test->{params} }); is($sql, $test->{expect_sql}, "Got expected SQL for $test->{name}"); if (exists $test->{expect_bind_params}) { is_deeply( \@bind_params, $test->{expect_bind_params}, "Got expected bind params for $test->{name}", ); } } Dancer-Plugin-Database-Core-0.14/t/manifest.t000644 000765 000024 00000000507 12175515777 021024 0ustar00ambsstaff000000 000000 #!perl -T use 5.006; use strict; use warnings FATAL => 'all'; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } my $min_tcm = 0.9; eval "use Test::CheckManifest $min_tcm"; plan skip_all => "Test::CheckManifest $min_tcm required" if $@; ok_manifest(); Dancer-Plugin-Database-Core-0.14/t/pod-coverage.t000644 000765 000024 00000001267 12647720516 021566 0ustar00ambsstaff000000 000000 #!perl -T use 5.006; use strict; use warnings FATAL => 'all'; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); Dancer-Plugin-Database-Core-0.14/t/pod.t000644 000765 000024 00000000401 12175515777 017771 0ustar00ambsstaff000000 000000 #!perl -T use 5.006; use strict; use warnings FATAL => 'all'; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); Dancer-Plugin-Database-Core-0.14/lib/Dancer/000755 000765 000024 00000000000 12651227234 020511 5ustar00ambsstaff000000 000000 Dancer-Plugin-Database-Core-0.14/lib/Dancer/Plugin/000755 000765 000024 00000000000 12651227234 021747 5ustar00ambsstaff000000 000000 Dancer-Plugin-Database-Core-0.14/lib/Dancer/Plugin/Database/000755 000765 000024 00000000000 12651227234 023453 5ustar00ambsstaff000000 000000 Dancer-Plugin-Database-Core-0.14/lib/Dancer/Plugin/Database/Core/000755 000765 000024 00000000000 12651227234 024343 5ustar00ambsstaff000000 000000 Dancer-Plugin-Database-Core-0.14/lib/Dancer/Plugin/Database/Core.pm000644 000765 000024 00000036122 12651226613 024705 0ustar00ambsstaff000000 000000 package Dancer::Plugin::Database::Core; use 5.006; use strict; use warnings FATAL => 'all'; =head1 NAME Dancer::Plugin::Database::Core - Shared core for D1 and D2 Database plugins =cut our $VERSION = '0.14'; my %handles; # Hashref used as key for default handle, so we don't have a magic value that # the user could use for one of their connection names and cause problems # (Kudos to Igor Bujna for the idea) my $def_handle = {}; =head1 SYNOPSIS This module should not be used directly. It is a shared library for L and L modules. =head1 METHODS =head2 database Implements the C keyword. =cut sub database { my %args = @_; my $arg = $args{arg} || undef; my $settings = $args{settings} || {}; my $logger = $args{logger} || sub {}; ## die? my $hook_exec = $args{hook_exec} || sub {}; ## die? # The key to use to store this handle in %handles. This will be either the # name supplied to database(), the hashref supplied to database() (thus, as # long as the same hashref of settings is passed, the same handle will be # reused) or $def_handle if database() is called without args: my $handle_key; my $conn_details; # connection settings to use. my $handle; # Accept a hashref of settings to use, if desired. If so, we use this # hashref to look for the handle, too, so as long as the same hashref is # passed to the database() keyword, we'll reuse the same handle: if (ref $arg eq 'HASH') { $handle_key = $arg; $conn_details = _merge_settings($arg, $settings, $logger); } else { $handle_key = defined $arg ? $arg : $def_handle; $conn_details = _get_settings($arg, $settings, $logger); if (!$conn_details) { $logger->(error => "No DB settings for " . ($arg || "default connection")); return (undef, $settings); } } # To be fork safe and thread safe, use a combination of the PID and TID (if # running with use threads) to make sure no two processes/threads share # handles. Implementation based on DBIx::Connector by David E. Wheeler. my $pid_tid = $$; $pid_tid .= '_' . threads->tid if $INC{'threads.pm'}; # OK, see if we have a matching handle $handle = $handles{$pid_tid}{$handle_key} || {}; if ($handle->{dbh}) { # If we should never check, go no further: if (!$conn_details->{connection_check_threshold}) { return ($handle->{dbh}, $settings); } if ($handle->{dbh}{Active} && $conn_details->{connection_check_threshold} && time - $handle->{last_connection_check} < $conn_details->{connection_check_threshold}) { return ($handle->{dbh}, $settings); } else { if (_check_connection($handle->{dbh})) { $handle->{last_connection_check} = time; return ($handle->{dbh}, $settings); } else { $logger->(debug => "Database connection went away, reconnecting"); $hook_exec->('database_connection_lost', $handle->{dbh}); if ($handle->{dbh}) { eval { $handle->{dbh}->disconnect } } # Need a new handle. # Fall through to the new connection codepath to get one. } } } # Get a new connection $handle->{dbh} = _get_connection($conn_details, $logger, $hook_exec); if ($handle->{dbh}) { $handle->{last_connection_check} = time; $handles{$pid_tid}{$handle_key} = $handle; if (ref $handle_key && ref $handle_key ne ref $def_handle) { # We were given a hashref of connection settings. Shove a # reference to that hashref into the handle, so that the hashref # doesn't go out of scope for the life of the handle. # Otherwise, that area of memory could be re-used, and, given # different DB settings in a hashref that just happens to have # the same address, we'll happily hand back the original handle. # See http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=665221 # Thanks to Sam Kington for suggesting this fix :) $handle->{_orig_settings_hashref} = $handle_key; } return ($handle->{dbh}, $settings); } else { return (undef, $settings); } } sub _merge_settings { my ($arg, $settings, $logger) = @_; $arg->{charset} = $settings->{charset}; $arg = _set_defaults($arg); return $arg; } sub _get_settings { my ($name, $settings, $logger) = @_; my $return_settings; # If no name given, just return the default settings if (!defined $name) { $return_settings = { %$settings }; if (!$return_settings->{driver} && !$return_settings->{dsn}) { $logger->('error', "Asked for default connection (no name given)" ." but no default connection details found in config" ); } } else { # If there are no named connections in the config, bail now: return unless exists $settings->{connections}; # OK, find a matching config for this name: if (my $named_settings = $settings->{connections}{$name}) { # Take a (shallow) copy of the settings, so we don't change them $return_settings = { %$named_settings }; } else { # OK, didn't match anything $logger->('error', "Asked for a database handle named '$name' but no matching " ."connection details found in config" ); } } $return_settings = _set_defaults($return_settings); return $return_settings; } sub _set_defaults { my $return_settings = shift; # We should have something to return now; make sure we have a # connection_check_threshold, then return what we found. In previous # versions the documentation contained a typo mentioning # connectivity-check-threshold, so support that as an alias. if (exists $return_settings->{'connectivity-check-threshold'} && !exists $return_settings->{connection_check_threshold}) { $return_settings->{connection_check_threshold} = delete $return_settings->{'connectivity-check-threshold'}; } # If the setting wasn't provided, default to 30 seconds; if a false value is # provided, though, leave it alone. (Older versions just checked for # truthiness, so a value of zero would still default to 30 seconds, which # isn't ideal.) if (!exists $return_settings->{connection_check_threshold}) { $return_settings->{connection_check_threshold} = 30; } return $return_settings; } # Given the settings to use, try to get a database connection sub _get_connection { my ($settings, $logger, $hook_exec) = @_; if (!$settings->{dsn} && !$settings->{driver}) { die "Can't get a database connection without settings supplied!\n" . "Please check you've supplied settings in config as per the " . "Dancer::Plugin::Database documentation"; } # Assemble the DSN: my $dsn = ''; my $driver = ''; if ($settings->{dsn}) { $dsn = $settings->{dsn}; ($driver) = $dsn =~ m{^dbi:([^:]+)}i; } else { $dsn = "dbi:" . $settings->{driver}; $driver = $settings->{driver}; my @extra_args; # DBD::SQLite wants 'dbname', not 'database', so special-case this # (DBI's documentation recommends that DBD::* modules should understand # 'database', but older versions of DBD::SQLite didn't; let's make # things easier for our users by handling this for them): # (I asked in RT #61117 for DBD::SQLite to support 'database', too; this # was included in DBD::SQLite 1.33, released Mon 20 May 2011. # Special-casing may as well stay, rather than forcing dependency on # DBD::SQLite 1.33. if ($driver eq 'SQLite' && $settings->{database} && !$settings->{dbname}) { $settings->{dbname} = delete $settings->{database}; } for (qw(database dbname host port sid server)) { if (exists $settings->{$_}) { push @extra_args, $_ . "=" . $settings->{$_}; } } if (my $even_more_dsn_args = $settings->{dsn_extra}) { foreach my $arg ( keys %$even_more_dsn_args ) { push @extra_args, $arg . '=' . $even_more_dsn_args->{$arg}; } } $dsn .= ':' . join(';', @extra_args) if @extra_args; } # If the app is configured to use UTF-8, the user will want text from the # database in UTF-8 to Just Work, so if we know how to make that happen, do # so, unless they've set the auto_utf8 plugin setting to a false value. my $app_charset = $settings->{charset} || ""; my $auto_utf8 = exists $settings->{auto_utf8} ? $settings->{auto_utf8} : 1; if (lc $app_charset eq 'utf-8' && $auto_utf8) { # The option to pass to the DBI->connect call depends on the driver: my %param_for_driver = ( SQLite => 'sqlite_unicode', mysql => 'mysql_enable_utf8', Pg => 'pg_enable_utf8', ); my $param = $param_for_driver{$driver}; if ($param && !$settings->{dbi_params}{$param}) { $logger->( debug => "Adding $param to DBI connection params" . " to enable UTF-8 support" ); $settings->{dbi_params}{$param} = 1; } } # To support the database_error hook, use DBI's HandleError option $settings->{dbi_params}{HandleError} = sub { my ($error, $handle) = @_; $hook_exec->('database_error', $error, $handle); }; my $dbh = DBI->connect($dsn, $settings->{username}, $settings->{password}, $settings->{dbi_params} ); if (!$dbh) { $logger->(error => "Database connection failed - " . $DBI::errstr); $hook_exec->('database_connection_failed', $settings); return undef; } elsif (exists $settings->{on_connect_do}) { my $to_do = ref $settings->{on_connect_do} eq 'ARRAY' ? $settings->{on_connect_do} : [ $settings->{on_connect_do} ]; for (@$to_do) { $dbh->do($_) or $logger->(error => "Failed to perform on-connect command $_"); } } $hook_exec->('database_connected', $dbh); # Indicate whether queries generated by quick_query() etc in # Dancer::Plugin::Database::Core::Handle should be logged or not; this seemed a # little dirty, but DBI's docs encourage it # ("You can stash private data into DBI handles via $h->{private_..._*}..") $dbh->{private_dancer_plugin_database} = { log_queries => $settings->{log_queries} || 0, logger => $logger, }; # Re-bless it as a Dancer::Plugin::Database::Core::Handle object, to provide nice # extra features (unless the config specifies a different class; if it does, # this should be a subclass of Dancer::Plugin::Database::Core::Handle in order to # extend the features provided by it, or a direct subclass of DBI::db (or # even DBI::db itself) to bypass the features provided by D::P::D::Handle) my $handle_class = $settings->{handle_class} || 'Dancer::Plugin::Database::Core::Handle'; my $package = $handle_class; $package =~ s{::}{/}g; $package .= '.pm'; require $package; return bless($dbh => $handle_class); } # Check the connection is alive sub _check_connection { my $dbh = shift; return unless $dbh; if ($dbh->{Active}) { my $result = eval { $dbh->ping }; return 0 if $@; if (int($result)) { # DB driver itself claims all is OK, trust it: return 1; } else { # It was "0 but true", meaning the default DBI ping implementation # Implement our own basic check, by performing a real simple query. my $ok; eval { $ok = $dbh->do('select 1'); }; return $ok; } } else { return; } } =head1 AUTHOR David Precious, C<< >> =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Dancer::Plugin::Database::Core You can also look for information at: =over 4 =item * RT: CPAN's request tracker (report bugs here) L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS =head1 LICENSE AND COPYRIGHT Copyright 2013 David Precious. This program is free software; you can redistribute it and/or modify it under the terms of the the Artistic License (2.0). You may obtain a copy of the full license at: L Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, er to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. =cut 1; # End of Dancer::Plugin::Database::Core Dancer-Plugin-Database-Core-0.14/lib/Dancer/Plugin/Database/Core/Handle.pm000644 000765 000024 00000046703 12651226613 026106 0ustar00ambsstaff000000 000000 package Dancer::Plugin::Database::Core::Handle; use strict; use Carp; use DBI; use base qw(DBI::db); our $VERSION = '0.14'; =head1 NAME Dancer::Plugin::Database::Core::Handle - subclassed DBI connection handle =head1 DESCRIPTION Subclassed DBI connection handle with added convenience features =head1 SYNOPSIS # in your Dancer app: database->quick_insert($tablename, \%data); # Updating a record where id = 42: database->quick_update($tablename, { id => 42 }, { foo => 'New value' }); # Fetching a single row quickly in scalar context my $employee = database->quick_select('employees', { id => $emp_id }); # Fetching multiple rows in list context - passing an empty hashref to signify # no where clause (i.e. return all rows - so "select * from $table_name"): my @all_employees = database->quick_select('employees', {}); # count number of male employees my $count = database->quick_count('employees', { gender => 'male' }); =head1 Added features A C object is a subclassed L L database handle, with the following added convenience methods: =over 4 =item quick_insert database->quick_insert('mytable', { foo => 'Bar', baz => 5 }); Given a table name and a hashref of data (where keys are column names, and the values are, well, the values), insert a row in the table. If you need any of the values to be interpolated straight into the SQL, for instance if you need to use a function call like C or similar, then you can provide them as a scalarref: database->quick_insert('mytable', { foo => 'Bar', timestamp => \'NOW()' }); Of course, if you do that, you must be careful to avoid SQL injection attacks! =cut sub quick_insert { my ($self, $table_name, $data) = @_; return $self->_quick_query('INSERT', $table_name, $data); } =item quick_update database->quick_update('mytable', { id => 42 }, { foo => 'Baz' }); Given a table name, a hashref describing a where clause and a hashref of changes, update a row. As per quick_insert, if you need any of the values to be interpolated straight in the SQL, for e.g. to use a function call, provide a scalarref: database->quick_update('mytable', { id => 42 }, { counter => \'counter + 1' }); Of course, if you do that, you must be careful to avoid SQL injection attacks! =cut sub quick_update { my ($self, $table_name, $where, $data) = @_; return $self->_quick_query('UPDATE', $table_name, $data, $where); } =item quick_delete database->quick_delete($table, { id => 42 }); Given a table name and a hashref to describe the rows which should be deleted (the where clause - see below for further details), delete them. =cut sub quick_delete { my ($self, $table_name, $where) = @_; return $self->_quick_query('DELETE', $table_name, undef, $where); } =item quick_select my $row = database->quick_select($table, { id => 42 }); my @rows = database->quick_select($table, { id => 42 }); Given a table name and a hashref of where clauses (see below for explanation), and an optional hashref of options, returns either the first matching row as a hashref if called in scalar context, or a list of matching rows as hashrefs if called in list context. The third argument is a hashref of options to allow additional control, as documented below. For backwards compatibility, it can also be an arrayref of column names, which acts in the same way as the C option. The options you can provide are: =over 4 =item C An arrayref of column names to return, if you only want certain columns returned =item C Specify how the results should be ordered. This option can take various values: =over 4 =item * a straight scalar or arrayref sorts by the given column(s): { order_by => 'foo' } # equivalent to "ORDER BY foo" { order_by => [ qw(foo bar) ] } # equiv to "ORDER BY foo,bar" =item * a hashref of C column name>, e.g.: { order_by => { desc => 'foo' } } # equiv to ORDER BY foo DESC { order_by => [ { desc => 'foo' }, { asc => 'bar' } ] } # above is equiv to ORDER BY foo DESC, bar ASC =back =item C Limit how many records will be returned; equivalent to e.g. C in an SQL query. If called in scalar context, an implicit LIMIT 1 will be added to the query anyway, so you needn't add it yourself. An example of using options to control the results you get back: # Get the name & phone number of the 10 highest-paid men: database->quick_select( 'employees', { gender => 'male' }, { order_by => 'salary', limit => 10, columns => [qw(name phone)] } ); =cut =item C number C says to skip that many rows before beginning to return rows (postgresql). Example: # Get the name & phone number of the 10 highest-paid men starting from 11th: database->quick_select( 'employees', { gender => 'male' }, { order_by => 'salary', offset => 10, limit => 10, columns => [qw(name phone)] } ); =cut sub quick_select { my ($self, $table_name, $where, $opts) = @_; # For backwards compatibility, accept an arrayref of column names as the 3rd # arg, instead of an arrayref of options: if ($opts && ref $opts eq 'ARRAY') { $opts = { columns => $opts }; } # Make sure to call _quick_query in the same context we were called. # This is a little ugly, rewrite this perhaps. if (wantarray) { return ($self->_quick_query('SELECT', $table_name, $opts, $where)); } else { return $self->_quick_query('SELECT', $table_name, $opts, $where); } } =back =item quick_lookup my $id = database->quick_lookup($table, { email => $params->{'email'} }, 'userid' ); This is a bit of syntactic sugar when you just want to lookup a specific field, such as when you're converting an email address to a userid (say during a login handler.) This call always returns a single scalar value, not a hashref of the entire row (or partial row) like most of the other methods in this library. Returns undef when there's no matching row or no such field found in the results. =cut sub quick_lookup { my ($self, $table_name, $where, $data) = @_; my $opts = { columns => [$data] }; my $row = $self->_quick_query('SELECT', $table_name, $opts, $where); return ( $row && exists $row->{$data} ) ? $row->{$data} : undef; } =item quick_count my $count = database->quick_count($table, { email => $params->{'email'} }); This is syntactic sugar to return a count of all rows which match your parameters, useful for pagination. This call always returns a single scalar value, not a hashref of the entire row (or partial row) like most of the other methods in this library. =cut sub quick_count { my ($self, $table_name, $where) = @_; my $opts = {}; #Options are irrelevant for a count. my @row = $self->_quick_query('COUNT', $table_name, $opts, $where); return ( @row ) ? $row[0] : undef ; } # The 3rd arg, $data, has a different meaning depending on the type of query # (no, I don't like that much; I may refactor this soon to use named params). # For INSERT/UPDATE queries, it'll be a hashref of field => value. # For SELECT queries, it'll be a hashref of additional options. # For DELETE queries, it's unused. sub _quick_query { my ($self, $type, $table_name, $data, $where) = @_; # Basic sanity checks first... if ($type !~ m{^ (SELECT|INSERT|UPDATE|DELETE|COUNT) $}x) { carp "Unrecognised query type $type!"; return; } if (!$table_name || ref $table_name) { carp "Expected table name as a straight scalar"; return; } if (($type eq 'INSERT' || $type eq 'UPDATE') && (!$data || ref $data ne 'HASH')) { carp "Expected a hashref of changes"; return; } if (($type =~ m{^ (SELECT|UPDATE|DELETE|COUNT) $}x) && (!$where)) { carp "Expected where conditions"; return; } # OK, get the SQL we're going to need # TODO: can we replace our own generation with e.g. SQL::Abstract? How much # backwards-incompatible change would that incur? my ($sql, @bind_params) = $self->_generate_sql( $type, $table_name, $data, $where ); # Dancer::Plugin::Database will have looked at the log_queries setting and # stashed it away for us to see: if ($self->{private_dancer_plugin_database}{log_queries}) { $self->{private_dancer_plugin_database}{logger}->(debug => "Executing $type query $sql with params " . join ',', map { defined $_ ? $_ =~ /^[[:ascii:]]+$/ ? length $_ > 50 ? substr($_, 0, 47) . '...' : $_ : "[non-ASCII data not logged]" : 'undef' } @bind_params ); } # Select queries, in scalar context, return the first matching row; in list # context, they return a list of matching rows. if ($type eq 'SELECT') { if (wantarray) { return @{ $self->selectall_arrayref( $sql, { Slice => {} }, @bind_params ) }; } else { return $self->selectrow_hashref($sql, undef, @bind_params); } } elsif ($type eq 'COUNT') { return $self->selectrow_array($sql, undef, @bind_params); } else { # INSERT/UPDATE/DELETE queries just return the result of DBI's do() return $self->do($sql, undef, @bind_params); } } sub _generate_sql { my ($self, $type, $table_name, $data, $where) = @_; my $which_cols = '*'; my $opts = $type eq 'SELECT' && $data ? $data : {}; if ($opts->{columns}) { my @cols = (ref $opts->{columns}) ? @{ $opts->{columns} } : $opts->{columns} ; $which_cols = join(',', map { $self->_quote_identifier($_) } @cols); } $table_name = $self->_quote_identifier($table_name); my @bind_params; my $sql = { SELECT => "SELECT $which_cols FROM $table_name", INSERT => "INSERT INTO $table_name ", UPDATE => "UPDATE $table_name SET ", DELETE => "DELETE FROM $table_name ", COUNT => "SELECT COUNT(*) FROM $table_name", }->{$type}; if ($type eq 'INSERT') { my (@keys, @values); for my $key (sort keys %$data) { my $value = $data->{$key}; push @keys, $self->_quote_identifier($key); if (ref $value eq 'SCALAR') { # If it's a scalarref it goes in the SQL as it is; this is a # potential SQL injection risk, but is documented as such - it # allows the user to include arbitrary SQL, at their own risk. push @values, $$value; } else { push @values, "?"; push @bind_params, $value; } } $sql .= sprintf "(%s) VALUES (%s)", join(',', @keys), join(',', @values); } if ($type eq 'UPDATE') { my @sql; for (sort keys %$data) { push @sql, $self->_quote_identifier($_) . '=' . (ref $data->{$_} eq 'SCALAR' ? ${$data->{$_}} : "?"); push @bind_params, $data->{$_} if (ref $data->{$_} ne 'SCALAR'); } $sql .= join ',', @sql; } if ($type eq 'UPDATE' || $type eq 'DELETE' || $type eq 'SELECT' || $type eq 'COUNT') { if ($where && !ref $where) { $sql .= " WHERE " . $where; } elsif ( ref $where eq 'HASH' ) { my @stmts; foreach my $k ( sort keys %$where ) { my $v = $where->{$k}; if ( ref $v eq 'HASH' ) { my $not = delete $v->{'not'}; while (my($op,$value) = each %$v ) { my ($cond, $add_bind_param) = $self->_get_where_sql($op, $not, $value); push @stmts, $self->_quote_identifier($k) . $cond; push @bind_params, $v->{$op} if $add_bind_param; } } else { my $clause .= $self->_quote_identifier($k); if ( ! defined $v ) { $clause .= ' IS NULL'; } elsif ( ! ref $v ) { $clause .= '=?'; push @bind_params, $v; } elsif ( ref $v eq 'ARRAY' ) { $clause .= ' IN (' . (join ',', map { '?' } @$v) . ')'; push @bind_params, @$v; } push @stmts, $clause; } } $sql .= " WHERE " . join " AND ", @stmts if keys %$where; } elsif (ref $where) { carp "Can't handle ref " . ref $where . " for where"; return; } } # Add an ORDER BY clause, if we want to: if (exists $opts->{order_by} and defined $opts->{order_by}) { $sql .= ' ' . $self->_build_order_by_clause($opts->{order_by}); } # Add a LIMIT clause if we want to: if (exists $opts->{limit} and defined $opts->{limit}) { my $limit = $opts->{limit}; $limit =~ s/\s+//g; # Check the limit clause is sane - just a number, or two numbers with a # comma between (if using offset,limit ) if ($limit =~ m{ ^ \d+ (?: , \d+)? $ }x) { # Checked for sanity above so safe to interpolate $sql .= " LIMIT $limit"; } else { die "Invalid LIMIT param $opts->{limit} !"; } } elsif ($type eq 'SELECT' && !wantarray) { # We're only returning one row in scalar context, so don't ask for any # more than that $sql .= " LIMIT 1"; } if (exists $opts->{offset} and defined $opts->{offset}) { my $offset = $opts->{offset}; $offset =~ s/\s+//g; if ($offset =~ /^\d+$/) { $sql .= " OFFSET $offset"; } else { die "Invalid OFFSET param $opts->{offset} !"; } } return ($sql, @bind_params); } sub _get_where_sql { my ($self, $op, $not, $value) = @_; $op = lc $op; # "IS" needs special-casing, as it will be either "IS NULL" or "IS NOT NULL" # - there's no need to return a bind param for that. if ($op eq 'is') { if (defined $value) { $self->{private_dancer_plugin_database}{logger}->(warning => "Using the 'IS' operator only makes sense to test for nullness," ." but a non-undef value was passed. Did you mean eq/ne?" ); } return $not ? 'IS NOT NULL' : 'IS NULL'; } my %st = ( 'like' => ' LIKE ?', 'is' => ' IS ?', 'ge' => ' >= ?', 'gt' => ' > ?', 'le' => ' <= ?', 'lt' => ' < ?', 'eq' => ' = ?', 'ne' => ' != ?', ); # Return the appropriate SQL, and indicate that the value should be added to # the bind params return (($not ? ' NOT' . $st{$op} : $st{$op}), 1); } # Given either a column name, or a hashref of e.g. { asc => 'colname' }, # or an arrayref of either, construct an ORDER BY clause (quoting col names) # e.g.: # 'foo' => ORDER BY foo # { asc => 'foo' } => ORDER BY foo ASC # ['foo', 'bar'] => ORDER BY foo, bar # [ { asc => 'foo' }, { desc => 'bar' } ] # => 'ORDER BY foo ASC, bar DESC sub _build_order_by_clause { my ($self, $in) = @_; # Input could be a straight scalar, or a hashref, or an arrayref of either # straight scalars or hashrefs. Turn a straight scalar into an arrayref to # avoid repeating ourselves. $in = [ $in ] unless ref $in eq 'ARRAY'; # Now, for each of the fields given, add them to the clause my @sort_fields; for my $field (@$in) { if (!ref $field) { push @sort_fields, $self->_quote_identifier($field); } elsif (ref $field eq 'HASH') { my ($order, $name) = %$field; $order = uc $order; if ($order ne 'ASC' && $order ne 'DESC') { die "Invalid sort order $order used in order_by option!"; } # $order has been checked to be 'ASC' or 'DESC' above, so safe to # interpolate push @sort_fields, $self->_quote_identifier($name) . " $order"; } } return "ORDER BY " . join ', ', @sort_fields; } # A wrapper around DBI's quote_identifier which first splits on ".", so that # e.g. database.table gets quoted as `database`.`table`, not `database.table` sub _quote_identifier { my ($self, $identifier) = @_; return join '.', map { $self->quote_identifier($_) } split /\./, $identifier; } =back All of the convenience methods provided take care to quote table and column names using DBI's C, and use parameterised queries to avoid SQL injection attacks. See L for why this is important, if you're not familiar with it. =head1 WHERE clauses as hashrefs C, C and C take a hashref of WHERE clauses. This is a hashref of field => 'value', each of which will be included in the WHERE clause used, for instance: { id => 42 } Will result in an SQL query which would include: WHERE id = 42 When more than one field => value pair is given, they will be ANDed together: { foo => 'Bar', bar => 'Baz' } Will result in: WHERE foo = 'Bar' AND bar = 'Baz' (Actually, parameterised queries will be used, with placeholders, so SQL injection attacks will not work, but it's easier to illustrate as though the values were interpolated directly. Don't worry, they're not.) With the same idea in mind, you can check if a value is NULL with: { foo => undef } This will be correctly rewritten to C. You can pass an empty hashref if you want all rows, e.g.: database->quick_select('mytable', {}); ... is the same as C<"SELECT * FROM 'mytable'"> If you pass in an arrayref as the value, you can get a set clause as in the following example: { foo => [ 'bar', 'baz', 'quux' ] } ... it's the same as C If you need additional flexibility, you can build fairly complex where clauses by passing a hashref of condition operators and values as the value to the column field key. Currently recognized operators are: =over =item 'like' { foo => { 'like' => '%bar%' } } ... same as C =item 'gt' / 'ge' 'greater than' or 'greater or equal to' { foo => { 'ge' => '42' } } ... same as C= '42'> =item 'lt' / 'le' 'less than' or 'less or equal to' { foo => { 'lt' => '42' } } ... same as C '42'> =item 'eq' / 'ne' / 'is' 'equal' or 'not equal' or 'is' { foo => { 'ne' => 'bar' } } ... same as C =back You can also include a key named 'not' with a true value in the hashref which will (attempt) to negate the other operator(s). { foo => { 'like' => '%bar%', 'not' => 1 } } ... same as C If you use undef as the value for an operator hashref it will be replaced with 'NULL' in the query. If that's not flexible enough, you can pass in your own scalar WHERE clause string B there's no automatic sanitation on that - if you suffer from a SQL injection attack - don't blame me! Don't forget to use C/C on it then. =head1 AUTHOR David Precious C< <> > =head1 ACKNOWLEDGEMENTS See L =head1 SEE ALSO L and L L and L L =cut 1; __END__