DBI-Test-0.001/000755 000765 000024 00000000000 12200131036 012753 5ustar00snostaff000000 000000 DBI-Test-0.001/ChangeLog000644 000765 000024 00000000053 12140704166 014540 0ustar00snostaff000000 000000 0.001 - 03 May 2013 * Initial release DBI-Test-0.001/DBI-TEST.SKIP000644 000765 000024 00000000016 12200130344 014614 0ustar00snostaff000000 000000 t/basic/.*\.t DBI-Test-0.001/DESIGN.md000644 000765 000024 00000020566 12162056267 014302 0ustar00snostaff000000 000000 # DESIGN Currently this is a list of open issues and discussion points... Topics can be removed once they're settled and the relevant docs have been updated. ## DBI::Test as a DBD author's tool This is the principle use-case for DBI::Test: to provide a common suite of tests for multiple drivers. We need to consider how evolution of DBI::Test will affect driver authors. Specifically, as DBI::Test add new tests it's quite likely that some drivers will fail that test, but that failure is not a regression for the driver. So it seems reasonable for DBI::Test to be primarily a developer tool and not run as a standard part of the drivers' test suite, at least for now. In other words, DBI::Test would only be run if AUTHOR_TESTING is true. That also allows us to duck the issue of whether DBD's should list DBI::Test as a dependency. At least for now. ## DBI::Test as a DBI developer's tool The goal here would be to test the methods the DBI implements itself and the services the DBI provides to drivers, and also to test the various drivers shipped with the DBI. This is a secondary goal, but is important because DBI::Test will probably become the primary test suite for the drivrs that ship with DBI. ## Define what DBI::Test is NOT trying to do * It's not trying to test the database SQL behaviour (ORDER BY, JOINs etc). Databases (an drivers that implement their own databases) should have their own test suite for that. * It's not trying to test the database SQL syntax. As many tests as possible should be usable even for databases that don't use SQL at all. ## List some minimum and other edge cases we want to handle Example: Using the DBM with SQL::Nano parser. This means that, as far as possible, all tests should use very simple SQL and only one or two string columns. Obviously some tests will need to use more than two columns, or columns of different type, but they should be the exception. Tests that require other types or more columns (which should be rare) can use $dbh->type_info and $dbh->get_info(SQL_MAXIMUM_COLUMNS_IN_TABLE) to check if the test should be skipped for the current driver. ## Creating and populating test data tables (the fixtures) If the test code creates and populates the test data tables (the fixtures) then it'll be hard for drivers that don't use SQL, or use a strange variant, to make use of the test suite. So creation and population of fixtures should be abstracted out into separate module(s) that can be overridden in some way if needed. We shouldn't need many fixture tables. Most of the test suite could use a table with two string columns that's populated with either zero or three rows. The interface from the test modules could be something like: $table_name = init_fixture_table(types => 'str,str', rows => 2); ## Should the test code construct statements itself? As with the previous topic about test tables, if the tests have SQL embedded in them then they'll be limited to testing drivers that support that syntax. The DBI never parses the $statement (except for providing some support for finding placeholders). So it seems reasonable that construction of the $statement used for a given test should be abstracted out into separate module(s) that can be overridden in some way if needed. The interface from the test modules could be something like: $statement = get_test_statement('name for statement', $table); Where 'name for statement' is an identifier for the kind of statement needed and get_test_statement() maps that to suitable SQL. This is similar to the %SQLS in lib/DBI/Test/Case/basic/do.pm, for example. ## Should we create .t files at all, and if so, how many? There's a need to have a separate process for some test cases, like testing DBI vs DBI::PurePerl. But others, like Gofer (DBI_AUTOPROXY) don't need a separate process. Let's keep the generation of test files for now, but keep in mind the possibility that some 'context combinations' might be handled dynamically in future, i.e., inside the run_test() subroutine. ## Should test modules execute on load or require a subroutine call? Execute on load seems like a poor choice to me. I'd rather see something like a sub run { ... } in each test module. ## How and where should database connections be made? I think the modules that implement tests should not perform connections. The $dbh to use should be provided as an argument. ## How and where should test tables be created? I think that creating the test tables, like connecting, should be kept out of the main test modules. So I envisage two kinds of test modules. Low-level ones that are given a $dbh and run tests using that, and higher-level modules that handle connecting and test table creation. The needs of each are different. ## Should subtests should be used? I think subtests would be useful for non-trivial test files. See subtests in https://metacpan.org/module/Test::More The run() sub could look something like this: our $dbh; sub run { $dbh = shift; subtest '...', \&foo; subtest '...', \&bar; subtest '...', \&baz; } to invoke a set of tests. Taking that a step further, the run() function could automatically detect what test functions exist in a package and call each in turn. It could also call setup and teardown subs that could control fixtures. Then test modules would look something like this: package DBI::Test::...; use DBI::Test::ModuleTestsRunner qw(run); sub test__setup { ... } sub test__teardown { ... } sub test_foo { ... } sub test_bar { ... } sub test_baz { ... } The imported run() could also do things like randomize the execution order of the test_* subs. The test__setup sub should be able to skip the entire module of tests if they're not applicable for the current $dbh and test context. E.g., transaction tests on a driver that doesn't support transactions. The test__teardown sub should aim to restore everything to how it was before test__setup was called. This may become useful for things like leak checking. ## Is there a need for some kind of 'test context' object? The low-level test modules should gather as much of the info they need from the $dbh and $dbh->get_info. If extra information is needed in oder to implement tests we at least these options: 1. Use a $dbh->{dbi_test_foo} handle attribute (and $dbh->{Driver}{dbi_test_bar}) 2. Subclass the DBI and add a new method $dbh->dbi_test_foo(...) 3. Pass an extra argument to the run() function 4. Use a global, managed by a higher-level module Which of those suits best would become more clear further down the road. ## Handling expected failures/limitations Some combinations of driver and context will have limitations that will cause some tests to fail. For example, the DBI test suite has quite a few special cases for gofer: $ ack -li gofer t t/03handle.t t/08keeperr.t t/10examp.t t/48dbi_dbd_sqlengine.t t/49dbd_file.t t/50dbm_simple.t t/51dbm_file.t t/52dbm_complex.t t/65transact.t t/72childhandles.t Some mechanism will be needed to either skip affected tests or mark them as TODO's. This seems like a good use for some kind of 'test context' object that would indicate which kinds of tests to skip. Something like: sub test_attr_Kids { plan skip_all => '' if $test_context->{skip_test_attr_Kids}; ... } Note that the mechanism should be very specific to the test and not copy the current "skip if using gofer" design, which is too broard. Umm. Given that design it's possible that run() could and should automate the $test_context->{"skip_$test_sub_name"} check so it doesn't have to be written out in each test whenever a new skip is needed. There might be value in supporting TODO tests in a similar way. ## Using the test suite results to summarize driver behaviour It would be useful to be able to store for later display the results of running the tests on different drivers and in different contexts (gofer, nano sql, pure-perl etc). Then it would be possible to render visualizations to compare tests vs contexts and compare drivers across tests and contexts. Something similar to the cpantesters and perl6 compiler features results: http://matrix.cpantesters.org/?dist=DBI http://perl6.org/compilers/features This would be another win for using a smart run() sub and subtests The details() method in https://metacpan.org/module/Test::Builder#Test-Status-and-Info should be able to provide the raw info. DBI-Test-0.001/lib/000755 000765 000024 00000000000 12200131036 013521 5ustar00snostaff000000 000000 DBI-Test-0.001/Makefile.PL000644 000765 000024 00000003625 12177426751 014763 0ustar00snostaff000000 000000 use 5.008_001; use strict; use warnings; use ExtUtils::MakeMaker; use lib qw(lib); use DBI::Test::Conf (); my @generated_tests = DBI::Test::Conf->setup( AUTHOR_TESTS => 0, SKIP_FILE => "DBI-TEST.SKIP" ); my %eumm_opt = ( MIN_PERL_VERSION => '5.008001', META_MERGE => { resources => { repository => 'https://github.com/perl5-dbi/DBI-Test', license => 'http://dev.perl.org/licenses/', }, }, NAME => 'DBI::Test', VERSION_FROM => 'lib/DBI/Test.pm', ABSTRACT_FROM => 'lib/DBI/Test.pm', dist => { SUFFIX => '.gz', DIST_DEFAULT => 'manifest tardist', COMPRESS => 'gzip -9vf', }, BUILD_REQUIRES => { 'Test::Simple' => '0.90', }, LICENSE => 'perl', AUTHOR => 'The DBI team ', clean => { FILES => join( " " => @generated_tests ), }, test => { TESTS => join (' ' => 'xt/*.t', @generated_tests), }, ); # Backward compatibility issues for EU::MM { my $eumm_version = $ExtUtils::MakeMaker::VERSION; $eumm_version =~ s/[^0-9.].*//; # Strip devel part $eumm_version < 6.5503 and #EUMM 6.5502 has problems with BUILD_REQUIRES $eumm_opt{PREREQ_PM} = { %{$eumm_opt{PREREQ_PM} || {}}, %{delete $eumm_opt{BUILD_REQUIRES}}, }; $eumm_version < 6.48 and delete $eumm_opt{MIN_PERL_VERSION}; $eumm_version < 6.46 and delete $eumm_opt{META_MERGE}; $eumm_version < 6.31 and delete $eumm_opt{LICENSE}; } WriteMakefile (%eumm_opt); package MY; sub postamble { join "\n" => 'cover:', ' ccache -C', ' -@rm -f *.gc??', ' cover -test', '', 'spellcheck:', ' pod-spell-check --aspell --ispell', '', 'tgzdist: spellcheck $(DISTVNAME).tar.gz distcheck', ' -@mv -f $(DISTVNAME).tar.gz $(DISTVNAME).tgz', ' -@cpants_lint.pl $(DISTVNAME).tgz', ' -@rm -f Debian_CPANTS.txt'; } # postamble DBI-Test-0.001/MANIFEST000644 000765 000024 00000001470 12200131036 014106 0ustar00snostaff000000 000000 ChangeLog DBI-TEST.SKIP DESIGN.md lib/DBI/Mock.pm lib/DBI/Test.pm lib/DBI/Test/Case.pm lib/DBI/Test/Case/attributes/PrintError.pm lib/DBI/Test/Case/attributes/Warn.pm lib/DBI/Test/Case/basic/bind_columns.pm lib/DBI/Test/Case/basic/connect.pm lib/DBI/Test/Case/basic/disconnect.pm lib/DBI/Test/Case/basic/do.pm lib/DBI/Test/Case/basic/execute.pm lib/DBI/Test/Case/basic/prepare.pm lib/DBI/Test/Case/basic/type_info.pm lib/DBI/Test/Conf.pm lib/DBI/Test/DSN/Provider.pm lib/DBI/Test/DSN/Provider/Base.pm lib/DBI/Test/DSN/Provider/Config.pm lib/DBI/Test/DSN/Provider/Dir.pm lib/DBI/Test/DSN/Provider/File.pm lib/DBI/Test/List.pm Makefile.PL MANIFEST README.md META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) DBI-Test-0.001/META.json000644 000765 000024 00000002026 12200131036 014374 0ustar00snostaff000000 000000 { "abstract" : "Test suite for DBI API", "author" : [ "The DBI team " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.72, CPAN::Meta::Converter version 2.131560", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "DBI-Test", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::Simple" : "0.90" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.008001" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/perl5-dbi/DBI-Test" } }, "version" : "0.001" } DBI-Test-0.001/META.yml000644 000765 000024 00000001103 12200131036 014217 0ustar00snostaff000000 000000 --- abstract: 'Test suite for DBI API' author: - 'The DBI team ' build_requires: Test::Simple: 0.90 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.72, CPAN::Meta::Converter version 2.131560' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: DBI-Test no_index: directory: - t - inc requires: perl: 5.008001 resources: license: http://dev.perl.org/licenses/ repository: https://github.com/perl5-dbi/DBI-Test version: 0.001 DBI-Test-0.001/README.md000644 000765 000024 00000006656 12161737237 014274 0ustar00snostaff000000 000000 # DBI::Test - The DBI/DBD API Test Suite [![Build Status](https://travis-ci.org/perl5-dbi/DBI-Test.png?branch=master)](https://travis-ci.org/perl5-dbi/DBI-Test) ## Description This module aims at a transparent test suite for the DBI API to be used from both sides of the API (DBI and DBD) to check if the provided functionality is working and complete. ## Copying Copyright (C) 2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. Recent changes can be (re)viewed in the public GIT repository at GitHub https://github.com/perl5-dbi/DBI-Test Feel free to fork and/or clone your own copy: $ git clone https://github.com/perl5-dbi/DBI-Test.git DBI-Test ## Contributing We share our thoughts on the following public channels: 1. DBI development mailing list - http://lists.perl.org/list/dbi-dev.html 2. IRC: irc.perl.org/6667 #dbi ## Build/Installation Though this module should validate against itself, its use is only visible when used as subset of the testsuite for DBI or a DBD. ## Authors This module is a team-effort. The current team members are * H.Merijn Brand (Tux) * Jens Rehsack (Sno) * Peter Rabbitson (ribasushi) * Joakim Tørmoen (trmjoa) ## Some background and plans Several of use DBI/DBD developers were playing with an idea for a long time to come to a new way of testing DBI and DBD and especially the API as defined by the DBI. We have noticed in several occasions that the DBI defines the API, where testing the API is hard because there is not (yet) an actual database on the backend (no functional DBD) and from the other side (the DBD) some of these tests are quite the same, just to test if the API as documented from the DBI is working as expected from the DBD point of view. The plan has grown to create a new module that would replace the API tests in the DBI test suite and that can also be used without modification in the DBD test suites. This way we can assure that all documented API is tested the same way from both sides. As a bonus, we can have the DBD check that ALL DBI functionality is implemented (or documented not to be) and that all functionality (like logging) are dealt with in the way the end-user is expecting the DBI/DBD to work. As the Lancaster Consensus has come to the conclusion that the new toolchain can expect a minimum of perl-5.8.1 (which might be raised to 5.8.4 when the need arises), we have set the lower bound for DBI::Test to be 5.8.1, which includes the use of recent Test::More and the use of `done_testing();` (no plans). What the end-user sees: [![End-user view](http://tux.nl/Talks/DBI-Test/images/dbi-dbd.png)](http://tux.nl/Talks/DBI-Test/images/dbi-dbd.png) How that is currently tested: [![Current testing view](http://tux.nl/Talks/DBI-Test/images/testing.png)](http://tux.nl/Talks/DBI-Test/images/testing.png) What the new plan would be: [![new plan](http://tux.nl/Talks/DBI-Test/images/dbi-api.png)](http://tux.nl/Talks/DBI-Test/images/dbi-api.png) The plan is to support a full matrix of tests, including both DBI/XS and pure-perl DBI, as well as with and without proxy or other optional parts. There will be a possibility to skip pure-perl DBI (DBD::Oracle, DBD::CSV with Text::CSV\_XS) or to skip DBI/XS (DBD::Pg\_PP, DBD::CSV with Text::CSV\_PP). Visit the sandbox in the repository to view unrelated notes and stuff that won't be part of the distribution. DBI-Test-0.001/lib/DBI/000755 000765 000024 00000000000 12200131036 014117 5ustar00snostaff000000 000000 DBI-Test-0.001/lib/DBI/Mock.pm000644 000765 000024 00000033356 12177652317 015407 0ustar00snostaff000000 000000 package DBI::Mock; use strict; use warnings; use Carp qw(carp confess); sub _set_isa { my ( $classes, $topclass ) = @_; foreach my $suffix ( '::db', '::st' ) { my $previous = $topclass || 'DBI'; # trees are rooted here foreach my $class (@$classes) { my $base_class = $previous . $suffix; my $sub_class = $class . $suffix; my $sub_class_isa = "${sub_class}::ISA"; no strict 'refs'; @$sub_class_isa or @$sub_class_isa = ($base_class); $previous = $class; } } } sub _make_root_class { my ( $ref, $root ) = @_; $root or return; (my $c = ref $ref) =~ s/::dr$//g; no strict 'refs'; eval qq{ package $c; require $root; }; $@ and return; unless ( @{"$root\::db::ISA"} && @{"$root\::st::ISA"} ) { carp("DBI subclasses '$root\::db' and ::st are not setup, RootClass ignored"); } else { _set_isa( [$root], 'DBI::Mock' ); } return; } my %default_attrs = ( Warn => 1, Active => 1, Executed => 0, # set on execute ... Kids => 0, ActiveKids => 0, CachedKids => 0, Type => "db", ChildHandles => undef, # XXX improve to fake :/ CompatMode => 0, InactiveDestroy => 0, AutoInactiveDestroy => 0, PrintWarn => $^W, PrintError => 1, RaiseError => 0, HandleError => undef, # XXX no default specified HandleSetErr => undef, # XXX no default specified ErrCount => 0, ShowErrorStatement => undef, # XXX no default specified TraceLevel => 0, # XXX no default specified FetchHashKeyName => "NAME", # XXX no default specified ChopBlanks => undef, # XXX no default specified LongReadLen => 0, LongTruncOk => 0, TaintIn => 0, TaintOut => 0, Taint => 0, Profile => undef, # XXX no default specified ReadOnly => 1, Callbacks => undef, ); sub _make_handle { my ( $ref, $name ) = @_; my $h = bless( { %default_attrs, %$ref }, $name ); return $h; } my %drivers; sub _get_drv { my ( $self, $dsn, $attrs ) = @_; my $class = "DBI::dr"; # XXX maybe extract it from DSN? ... defined $drivers{$class} or $drivers{$class} = _make_handle( $attrs, $class ); return $drivers{$class}; } sub connect { my ( $self, $dsn, $user, $pass, $attrs ) = @_; my $drh = $self->_get_drv( $dsn, $attrs ); $drh->connect( $dsn, $user, $pass, $attrs ); } sub installed_drivers { %drivers; } sub available_drivers { 'NullP' } our $stderr = 1; our $err; our $errstr; sub err { $err } sub errstr { $errstr } sub set_err { my ( $ref, $_err, $_errstr ) = @_; $_err or do { $err = undef; $errstr = ''; return; }; $err = $_err; $errstr = $_errstr; Test::More::diag("Raise: ", $ref->{RaiseError}); $ref->{RaiseError} and $errstr and Carp::croak($errstr); Test::More::diag("Print: ", $ref->{PrintError}); $ref->{PrintError} and $errstr and Carp::carp($errstr); return; } { package # DBI::Mock::dr; our @ISA; my %default_db_attrs = ( AutoCommit => 1, Driver => undef, # set to the driver itself ... Name => "", Statement => "", RowCacheSize => 0, Username => "", ); sub connect { my ( $drh, $dbname, $user, $auth, $attrs ) = @_; exists $drh->{RootClass} and DBI::Mock::_make_root_class( $drh, $drh->{RootClass} ); my $class = $drh->{RootClass} ? $drh->{RootClass} . "::db" : "DBI::db"; my $dbh = DBI::Mock::_make_handle( { %default_db_attrs, %$attrs, drh => $drh }, $class ); return $dbh; } our $err; our $errstr; sub err { $err } sub errstr { $errstr } sub set_err { my ( $ref, $_err, $_errstr ) = @_; $_err or do { $err = undef; $errstr = ''; return; }; $err = $_err; $errstr = $_errstr; $ref->{RaiseError} and $errstr and Carp::croak($errstr); $ref->{PrintError} and $errstr and Carp::carp($errstr); return; } sub FETCH { my ( $dbh, $attr ) = @_; return $dbh->{$attr}; } sub STORE { my ( $dbh, $attr, $val ) = @_; return $dbh->{$attr} = $val; } } { package # DBI::Mock::db; our @ISA; my %default_st_attrs = ( NUM_OF_FIELDS => undef, NUM_OF_PARAMS => undef, NAME => undef, NAME_lc => undef, NAME_uc => undef, NAME_hash => undef, NAME_lc_hash => undef, NAME_uc_hash => undef, TYPE => undef, PRECISION => undef, SCALE => undef, NULLABLE => undef, CursorName => undef, Database => undef, Statement => undef, ParamValues => undef, ParamTypes => undef, ParamArrays => undef, RowsInCache => undef, ); sub _valid_stmt { 1; } sub disconnect { $_[0]->STORE( Active => 0 ); return 1; } sub prepare { my ( $dbh, $stmt, $attrs ) = @_; _valid_stmt( $stmt, $attrs ) or return; # error already set by _valid_stmt defined $attrs or $attrs = {}; ref $attrs eq "HASH" or $attrs = {}; my $class = $dbh->{drh}->{RootClass} ? $dbh->{drh}->{RootClass} . "::st" : "DBI::st"; my $sth = DBI::Mock::_make_handle( { %default_st_attrs, %$attrs, Statement => $stmt, dbh => $dbh, }, $class ); return $sth; } # I don't had a clue how to implement that better # finally - they are reduce to the max and don't interfer with anything around ... sub do { my ( $dbh, $statement, $attr, @params ) = @_; my $sth = $dbh->prepare( $statement, $attr ) or return undef; $sth->execute(@params) or return $dbh->set_err( $sth->err, $sth->errstr ); my $rows = $sth->rows; ( $rows == 0 ) ? "0E0" : $rows; } sub _do_selectrow { my ( $method, $dbh, $stmt, $attr, @bind ) = @_; my $sth = ( ( ref $stmt ) ? $stmt : $dbh->prepare( $stmt, $attr ) ) or return; $sth->execute(@bind) or return; my $row = $sth->$method() and $sth->finish; return $row; } sub selectrow_hashref { return _do_selectrow( 'fetchrow_hashref', @_ ); } sub selectrow_arrayref { return _do_selectrow( 'fetchrow_arrayref', @_ ); } sub selectrow_array { my $row = _do_selectrow( 'fetchrow_arrayref', @_ ) or return; return $row->[0] unless wantarray; return @$row; } sub selectall_arrayref { my ( $dbh, $stmt, $attr, @bind ) = @_; my $sth = ( ref $stmt ) ? $stmt : $dbh->prepare( $stmt, $attr ) or return; $sth->execute(@bind) || return; my $slice = $attr->{Slice}; # typically undef, else hash or array ref if ( !$slice and $slice = $attr->{Columns} ) { if ( ref $slice eq 'ARRAY' ) { # map col idx to perl array idx $slice = [ @{ $attr->{Columns} } ]; # take a copy for (@$slice) { $_-- } } } my $rows = $sth->fetchall_arrayref( $slice, my $MaxRows = $attr->{MaxRows} ); $sth->finish if defined $MaxRows; return $rows; } sub selectall_hashref { my ( $dbh, $stmt, $key_field, $attr, @bind ) = @_; my $sth = ( ref $stmt ) ? $stmt : $dbh->prepare( $stmt, $attr ); return unless $sth; $sth->execute(@bind) || return; return $sth->fetchall_hashref($key_field); } sub selectcol_arrayref { my ( $dbh, $stmt, $attr, @bind ) = @_; my $sth = ( ref $stmt ) ? $stmt : $dbh->prepare( $stmt, $attr ); return unless $sth; $sth->execute(@bind) || return; my @columns = ( $attr->{Columns} ) ? @{ $attr->{Columns} } : (1); my @values = (undef) x @columns; my $idx = 0; for (@columns) { $sth->bind_col( $_, \$values[ $idx++ ] ) || return; } my @col; if ( my $max = $attr->{MaxRows} ) { push @col, @values while 0 < $max-- && $sth->fetch; } else { push @col, @values while $sth->fetch; } return \@col; } our $err; our $errstr; sub err { $err } sub errstr { $errstr } sub set_err { my ( $ref, $_err, $_errstr ) = @_; $_err or do { $err = undef; $errstr = ''; return; }; $err = $_err; $errstr = $_errstr; defined $errstr or Carp::croak("Undefined \$errstr"); $ref->{RaiseError} and $errstr and Carp::croak($errstr); Test::More::diag("Print: ", $ref->{PrintError}); $ref->{PrintError} and $errstr and Carp::carp($errstr); return; } sub FETCH { my ( $dbh, $attr ) = @_; return $dbh->{$attr}; } sub STORE { my ( $dbh, $attr, $val ) = @_; return $dbh->{$attr} = $val; } } { package # DBI::Mock::st; our @ISA; my %default_attrs = (); sub execute { "0E0"; } our $err; our $errstr; sub err { $err } sub errstr { $errstr } sub set_err { my ( $ref, $_err, $_errstr ) = @_; $_err or do { $err = undef; $errstr = ''; return; }; $err = $_err; $errstr = $_errstr; defined $errstr or Carp::croak("Undefined \$errstr"); $ref->{RaiseError} and $errstr and Carp::croak($errstr); Test::More::diag("Print: ", $ref->{PrintError}); $ref->{PrintError} and $errstr and Carp::carp($errstr); } sub bind_col { my ( $h, $col, $value_ref, $from_bind_columns ) = @_; my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h); # from _get_fbav() my $num_of_fields = @$fbav; Carp::croak("bind_col: column $col is not a valid column (1..$num_of_fields)") if $col < 1 or $col > $num_of_fields; return 1 if not defined $value_ref; # ie caller is just trying to set TYPE Carp::croak("bind_col($col,$value_ref) needs a reference to a scalar") unless ref $value_ref eq 'SCALAR'; $h->{'_bound_cols'}->[ $col - 1 ] = $value_ref; return 1; } sub FETCH { my ( $dbh, $attr ) = @_; return $dbh->{$attr}; } sub STORE { my ( $dbh, $attr, $val ) = @_; return $dbh->{$attr} = $val; } } sub _inject_mock_dbi { eval qq{ package # DBI; our \@ISA = qw(DBI::Mock); our \$VERSION = "1.625"; package # DBI::dr; our \@ISA = qw(DBI::Mock::dr); package # DBI::db; our \@ISA = qw(DBI::Mock::db); package # DBI::st; our \@ISA = qw(DBI::Mock::st); 1; }; $@ and die $@; $INC{'DBI.pm'} = 'mocked'; } my $_have_dbi; sub _miss_dbi { defined $_have_dbi and return !$_have_dbi; $_have_dbi = 0; eval qq{ \$ENV{DBI_PUREPERL} = 2; # we only want to know if it's there ... require DBI; \$_have_dbi = 1; }; return !($_have_dbi = exists $INC{'DBI.pm'}); # XXX maybe riba can help to unload ... } BEGIN { if ( $ENV{DBI_MOCK} || _miss_dbi() ) { _inject_mock_dbi(); } } 1; =head1 NAME DBI::Mock - mock a DBI if we can't find the real one =head1 SYNOPSIS use DBI::Mock; my $dbh = DBI::Mock->connect($data_source, $user, $pass, \%attr) or die $DBI::Mock::errstr; my $sth = $dbh->prepare(); $sth->execute(); ... copy some from DBI SYNOPSIS =head1 DESCRIPTION =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) Joakim TE<0x00f8>rmoen (trmjoa) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut DBI-Test-0.001/lib/DBI/Test/000755 000765 000024 00000000000 12200131036 015036 5ustar00snostaff000000 000000 DBI-Test-0.001/lib/DBI/Test.pm000644 000765 000024 00000017153 12177742226 015431 0ustar00snostaff000000 000000 package DBI::Test; require 5.008001; use strict; use warnings; require Exporter; use Test::More import => [ '!pass' ]; use parent qw(Test::Builder::Module Exporter); our $VERSION = "0.001"; # XXX improve / beautify ... map {} + categories ... our @EXPORT = qw(connect_ok connect_not_ok prepare_ok execute_ok execute_not_ok do_ok do_not_ok); our @EXPORT_OK = qw(connect_ok connect_not_ok prepare_ok execute_ok execute_not_ok do_ok do_not_ok); my $CLASS = __PACKAGE__; =head1 NAME DBI::Test - Test suite for DBI API =cut sub connect_ok { my ($data_source, $username, $auth, $attr, $testname) = @_; my $tb = $CLASS->builder(); my $dbh = DBI->connect($data_source, $username, $auth, $attr); # maybe use Test::More::isa_ok directly from here? $tb->ok($dbh, $testname) and $tb->ok($dbh->isa("DBI::db"), "$testname delivers a DBI::db") and return $dbh; return; } sub connect_not_ok { my ($data_source, $username, $auth, $attr, $testname) = @_; my $tb = $CLASS->builder(); my $dbh = DBI->connect($data_source, $username, $auth, $attr); $tb->ok(!$dbh, $testname) or return $dbh; return; } sub prepare_ok { my ($dbh, @vals) = @_; my $testname = pop(@vals); my $tb = $CLASS->builder(); my $sth = $dbh->prepare(@vals); $tb->ok($sth, $testname) and $tb->ok($sth->isa("DBI::st"), "$testname delivers DBI::st") and return $sth; return; } sub execute_ok { my ($sth, @vals) = @_; my $testname = pop(@vals); my $tb = $CLASS->builder(); my $rv = $sth->execute(@vals); $tb->ok($rv, $testname); return $rv; } sub execute_not_ok { my ($sth, @vals) = @_; my $testname = pop(@vals); my $tb = $CLASS->builder(); my $rv = $sth->execute(@vals); $tb->ok(!defined($rv),, $testname); return $rv; } sub do_ok { my ($dbh, @vals) = @_; my $testname = pop(@vals); my $tb = $CLASS->builder(); my $rv = $dbh->do(@vals); $tb->ok($rv, $testname); return $rv; } sub do_not_ok { my ($dbh, @vals) = @_; my $testname = pop(@vals); my $tb = $CLASS->builder(); my $rv = $dbh->do(@vals); $tb->ok(!defined($rv),, $testname); return $rv; } 1; __END__ =head1 SYNOPSIS In Makefile.PL: use lib 'lib'; # to allow DBI::Test finds the test cases of your driver use DBI::Test::Conf (); my @generated_tests = DBI::Test::Conf->setup(); WriteMakefile ( test => { TESTS => join (' ' => 'xt/*.t', @generated_tests), }, clean => { FILES => join( " " => @generated_tests ) } ); You provide package DBI::Test::Your::Namespace::List; sub test_cases { return qw(...); # list of the test cases you provide } package DBI::Test::Your::Namespace::Conf; sub conf { my %conf = ( gofer => { category => "Gofer", cat_abbrev => "g", abbrev => "b", init_stub => qq(\$ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=null;policy=pedantic';), match => sub { my ($self, $test_case, $namespace, $category, $variant) = @_; ... }, name => "Gofer Transport", }, ); } package DBI::Test::Your::Namespace::Case::Your::First; ... # will be t/your/namespace/your/first.t package DBI::Test::Your::Namespace::Case::Your::Second; ... # will be t/your/namespace/your/second.t 1; And enhance DBI::Test with own test cases. =head1 DESCRIPTION This module aims to be a test suite for the DBI API and an underlying DBD driver, to check if the provided functionality is working and complete. Part of this module is the ability for self-testing using I. This is not designed to be another I - it's designed to allow tests can be verified to work as expected in a sandbox. This is, of course, limited to DBI API itself and cannot load any driver nor really execute any action. =head1 EXPORTS =head2 connect_ok $dbh = connect_ok($dsn, $user, $pass, \%attrs, $test_name); connect_ok invokes DBI-E and proves the result in an I. The created database handle (C<$dbh>) is returned, if any. =head2 connect_not_ok $dbh = connect_not_ok($dsn, $user, $pass, \%attrs, $test_name); connect_not_ok invokes DBI-E and proves the result in an I (but expects that there is no C<$dsn> returned). The created database handle (C<$dbh>) is returned, if any. =head2 prepare_ok $sth = prepare_ok($dbh, $stmt, \%attrs, $test_name); prepare_ok invokes $dbh-Eprepare and proves the result in an I. The resulting statement handle (C<$sth>) is returned, if any. =head2 execute_ok $rv = execute_ok($sth, $test_name); $rv = execute_ok($sth, @bind_values, $test_name); execute_ok invokes $sth->excute and proves the result via I. The value got from $sth-Eexecute is returned. =head2 execute_not_ok $rv = execute_not_ok($sth, $test_name); $rv = execute_not_ok($sth, @bind_values, $test_name); execute_not_ok invokes $sth->excute and proves the result via I. The value got from $sth-Eexecute is returned. =head2 do_ok $rv = do_ok($dbh, $test_name); $rv = do_ok($dbh, @bind_values, $test_name); do_ok invokes $dbh->do and proves the result via I. The value got from $dbh-Edo / $sth-Eexecute is returned. =head2 do_not_ok $rv = do_not_ok($dbh, $test_name); $rv = do_not_ok($dbh, @bind_values, $test_name); do_not_ok invokes $dbh->do and proves the result via I. The value got from $dbh-Edo / $sth-Eexecute is returned. =head1 GOAL =head2 TODO =head2 Source Recent changes can be (re)viewed in the public GIT repository at GitHub L Feel free to clone your own copy: $ git clone https://github.com/perl5-dbi/DBI-Test.git DBI-Test =head2 Contact We are discussing issues on the DBI development mailing list 1) and on IRC 2) 1) The DBI team 2) irc.perl.org/6667 #dbi =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc SQL::Statement You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * CPAN Search L =back =head2 Reporting bugs If you think you've found a bug then please read "How to Report Bugs Effectively" by Simon Tatham: L. Your problem is most likely related to the specific DBD driver module you're using. If that's the case then click on the 'Bugs' link on the L page for your driver. Only submit a bug report against the DBI::Test itself if you're sure that your issue isn't related to the driver you're using. =head1 TEST SUITE DBI::Test comes with some basic tests to test itself and L. The same tests are used for basic DBI self-tests as well as testing the SQL::Statement mock driver. =head1 EXAMPLES ??? Synopsis ??? =head1 DIAGNOSTICS ??? =head1 SEE ALSO DBI - Database independent interface for Perl DBI::DBD - Perl DBI Database Driver Writer's Guide Test::More - yet another framework for writing test scripts =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) Joakim TE<0x00f8>rmoen (trmjoa) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut DBI-Test-0.001/lib/DBI/Test/Case/000755 000765 000024 00000000000 12200131036 015711 5ustar00snostaff000000 000000 DBI-Test-0.001/lib/DBI/Test/Case.pm000644 000765 000024 00000002555 12177452336 016304 0ustar00snostaff000000 000000 package DBI::Test::Case; use strict; use warnings; use DBI::Mock (); sub requires_extended { 0 } sub is_test_for_mocked { my ( $self, $test_confs ) = @_; # allow DBD::NullP for DBI::Mock return ( $INC{'DBI.pm'} eq "mocked" and !scalar(@$test_confs) ) || scalar grep { $_->{cat_abbrev} eq "m" } @$test_confs; } sub is_test_for_dbi { my ( $self, $test_confs ) = @_; return ( -f $INC{'DBI.pm'} and !scalar(@$test_confs) ) || scalar grep { $_->{cat_abbrev} eq "z" } @$test_confs; } sub filter_drivers { my ( $self, $options, @test_dbds ) = @_; if ( $options->{CONTAINED_DBDS} ) { my @contained_dbds = "ARRAY" eq ref( $options->{CONTAINED_DBDS} ) ? @{ $options->{CONTAINED_DBDS} } : ( $options->{CONTAINED_DBDS} ); my @supported_dbds; foreach my $test_dbd (@test_dbds) { @supported_dbds = ( @supported_dbds, grep { $test_dbd eq $_ } @contained_dbds ); } return @supported_dbds; } return @test_dbds; } sub supported_variant { my ( $self, $test_case, $cfg_pfx, $test_confs, $dsn_pfx, $dsn_cred, $options ) = @_; # allow only DBD::NullP for DBI::Mock if ( $self->is_test_for_mocked($test_confs) ) { $dsn_cred or return 1; $dsn_cred->[0] eq 'dbi:NullP:' and return 1; return; } return 1; } 1; DBI-Test-0.001/lib/DBI/Test/Conf.pm000644 000765 000024 00000035261 12177743145 016317 0ustar00snostaff000000 000000 package DBI::Test::Conf; use strict; use warnings; use Carp qw(carp croak); use Config; use Cwd (); use Data::Dumper (); use File::Basename (); use File::Path (); use File::Spec (); use DBI::Mock (); use DBI::Test::DSN::Provider (); use Module::Pluggable::Object (); my $cfg_plugins; sub cfg_plugins { defined $cfg_plugins and return @{$cfg_plugins}; my $finder = Module::Pluggable::Object->new( search_path => ["DBI::Test"], require => 1, only => qr/::Conf$/, inner => 0 ); my @plugs = grep { $_->isa("DBI::Test::Conf") } $finder->plugins(); $cfg_plugins = \@plugs; return @{$cfg_plugins}; } my %conf = ( ( -f $INC{'DBI.pm'} ? ( default => { category => "mock", cat_abbrev => "m", abbrev => "b", init_stub => qq(\$ENV{DBI_MOCK} = 1;), match => { general => qq(require DBI;), namespace => [""], }, name => "Unmodified Test", } ) : () ) ); sub conf { %conf; } sub allconf { my ($self) = @_; my %allconf = $self->conf(); my @plugins = $self->cfg_plugins(); foreach my $plugin (@plugins) { # Hash::Merge->merge( ... ) %allconf = ( %allconf, $plugin->conf() ); } return %allconf; } my $tc_plugins; sub tc_plugins { defined $tc_plugins and return @{$tc_plugins}; my $finder = Module::Pluggable::Object->new( search_path => ["DBI::Test"], require => 1, only => qr/::List$/, inner => 0 ); my @plugs = grep { $_->isa("DBI::Test::List") } $finder->plugins(); $tc_plugins = \@plugs; return @{$tc_plugins}; } sub alltests { my ($self) = @_; my @alltests; my @plugins = $self->tc_plugins(); foreach my $plugin (@plugins) { # Hash::Merge->merge( ... ) @alltests = ( @alltests, $plugin->test_cases() ); } return @alltests; } sub alldrivers { # XXX restrict by config file ! my @drivers = grep { $_ !~ m/^Gofer|Multi|Multiplex|Proxy|Sponge$/ } DBI->available_drivers(); # hack around silly DBI behaviour which removes NullP from avail drivers -f $INC{'DBI.pm'} and push( @drivers, "NullP" ); @drivers; } sub default_dsn_conf { my ( $self, $driver ) = @_; $driver => { category => "driver", cat_abbrev => "d", abbrev => lc( substr( $driver, 0, 1 ) ), driver => "dbi:$driver:", name => "DSN for $driver", }; } sub dsn_conf { my ( $self, $driver, $test_case_ns ) = @_; my @dsn_providers = grep { $_ =~ m/\b$driver$/ && $_->can("dsn_conf") } DBI::Test::DSN::Provider->dsn_plugins(); @dsn_providers or return $self->default_dsn_conf($driver); return $dsn_providers[0]->dsn_conf($test_case_ns); } sub combine_nk { my ( $n, $k ) = @_; my @indx; my @result; @indx = map { $_ } ( 0 .. $k - 1 ); LOOP: while (1) { my @line = map { $indx[$_] } ( 0 .. $k - 1 ); push( @result, \@line ) if @line; for ( my $iwk = $k - 1; $iwk >= 0; --$iwk ) { if ( $indx[$iwk] <= ( $n - 1 ) - ( $k - $iwk ) ) { ++$indx[$iwk]; for my $swk ( $iwk + 1 .. $k - 1 ) { $indx[$swk] = $indx[ $swk - 1 ] + 1; } next LOOP; } } last; } return @result; } # simplified copy from Math::Cartesian::Product # Copyright (c) 2009 Philip R Brenan. # This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself. sub cartesian { my @C = @_; # Lists to be multiplied my @c = (); # Current element of cartesian product my @P = (); # Cartesian product my $n = 0; # Number of elements in product @C or return; # Empty product # Generate each cartesian product when there are no prior cartesian products. my $p; $p = sub { if ( @c < @C ) { for ( @{ $C[@c] } ) { push @c, $_; &$p(); pop @c; } } else { my $p = [@c]; push @P, $p; } }; &$p(); @P; } sub create_test { my ( $self, $test_case, $cfg_pfx, $test_confs, $dsn_pfx, $dsn_cred, $options ) = @_; # simply don't deploy them when you don't want be bothered about them ... my $test_base = ( defined( $options->{AUTHOR_TESTS} ) and $options->{AUTHOR_TESTS} ) ? "xt" : "t"; ( my $test_file = $test_case ) =~ s,::,/,g; $test_file = File::Spec->catfile( $test_base, $test_file . ".t" ); my $test_dir = File::Basename::dirname($test_file); $test_file = File::Basename::basename($test_file); my @tf_name_parts; $cfg_pfx and push( @tf_name_parts, $cfg_pfx ); $dsn_pfx and push( @tf_name_parts, $dsn_pfx ); push( @tf_name_parts, $test_file ); $test_file = File::Spec->catfile( $test_dir, join( "_", @tf_name_parts ) ); -d $test_dir or File::Path::make_path($test_dir); open( my $tfh, ">", $test_file ) or croak("Cannot open \"$test_file\": $!"); my $init_stub = join( ";\n", map { "ARRAY" eq ref( $_->{init_stub} ) ? join( ";\n", @{ $_->{init_stub} } ) : $_->{init_stub} } grep { $_->{init_stub} } @$test_confs ); $init_stub and $init_stub = sprintf( <{cleanup_stub} ) ? join( ";\n", @{ $_->{cleanup_stub} } ) : $_->{cleanup_stub} } grep { $_->{cleanup_stub} } @$test_confs ); $cleanup_stub and $cleanup_stub = sprintf( <new( [$dsn_cred] )->Indent(0)->Sortkeys(1)->Quotekeys(0)->Terse(1)->Dump(); # XXX how to deal with namespaces here and how do they affect generated test names? my $test_case_ns = "DBI::Test::Case::$test_case"; my $test_case_code = sprintf( <get_dsn_creds("${test_case_ns}", %s); ${test_case_ns}->run_test(\$test_case_conf); EOC print $tfh "$test_case_code\n"; close($tfh); return $test_dir; } sub create_conf_prefixes { my ( $self, $allconf ) = @_; my %pfx_hlp; my %pfx_lst; foreach my $cfg ( values %$allconf ) { push( @{ $pfx_hlp{ $cfg->{cat_abbrev} } }, $cfg ); } foreach my $cfg_id ( keys %pfx_hlp ) { my $n = scalar( @{ $pfx_hlp{$cfg_id} } ); my @combs = map { combine_nk( $n, $_ ); } ( 1 .. $n ); scalar @combs or next; $pfx_lst{$cfg_id} = { map { my @cfgs = map { $pfx_hlp{$cfg_id}->[$_] } @{$_}; my $pfx = "${cfg_id}v" . join( "", map { $_->{abbrev} } @cfgs ); $pfx => \@cfgs } @combs }; } my %pfx_direct = map { %{$_} } values %pfx_lst; %pfx_hlp = %pfx_lst; %pfx_lst = ( "" => [] ); do { my @pfx = keys %pfx_hlp; my $n = scalar(@pfx); my @combs = map { combine_nk( $n, $_ ); } ( 1 .. $n ); foreach my $comb (@combs) { my @cfgs = cartesian( map { [ keys %{ $pfx_hlp{ $pfx[$_] } } ] } @$comb ); foreach my $cfg (@cfgs) { my $_pfx = join( "_", @$cfg ); $pfx_lst{$_pfx} = [ map { @{ $pfx_direct{$_} } } @$cfg ]; } } } while (0); return %pfx_lst; } my %dsn_cfg = ( dbm => { category => "driver", cat_abbrev => "d", abbrev => "d", driver => "dbi:DBM:", variants => { mldbm => { f => { dbm_mldbm => 'FreezeThaw' }, d => { dbm_mldbm => 'Data::Dumper' }, s => { dbm_mldbm => 'Storable' }, }, type => { s => { dbm_type => 'SDBM_File' }, g => { dbm_type => 'GDBM_File' }, d => { dbm_type => 'DB_File' }, b => { dbm_type => 'BerkeleyDB', dbm_berkeley_flags => '...' } }, }, name => "DSN for DBM", }, csv => { category => "driver", cat_abbrev => "d", abbrev => "c", driver => "dbi:CSV:", variants => { type => { p => { csv_class => 'Text::CSV' }, x => { csv_class => 'Text::CSV_XS' }, }, }, name => "DSN for CSV", }, ); sub create_driver_prefixes { my ( $self, $dsnconf ) = @_; # $dsnconf or $dsnconf = \%dsn_cfg; my %pfx_lst; foreach my $dsncfg ( values %$dsnconf ) { my @creds = @$dsncfg{qw(driver user passwd attrs)}; my $pfx = $dsncfg->{cat_abbrev} . "v" . $dsncfg->{abbrev}; "HASH" eq ref $creds[3] or $creds[3] = {}; $pfx_lst{$pfx} = [@creds]; if ( $dsncfg->{variants} ) { my @varvals = values %{ $dsncfg->{variants} }; my @variants = cartesian( map { [ keys %{$_} ] } @varvals ); foreach my $variant (@variants) { my $attrs = { %{ $creds[3] }, map { %{ $varvals[$_]->{ $variant->[$_] } } } ( 0 .. $#varvals ) }; $pfx_lst{ $pfx . join( "", @$variant ) } = [ @creds[ 0 .. 2 ], $attrs ]; } } } # avoid prefix pollution if ( 1 == scalar( keys(%pfx_lst) ) ) { %pfx_lst = ( '' => ( values %pfx_lst )[0] ); } return %pfx_lst; } sub populate_tests { my ( $self, $alltests, $allconf, $alldrivers, $options ) = @_; my %test_dirs; my %pfx_cfgs = $self->create_conf_prefixes($allconf); foreach my $test_case (@$alltests) { # XXX how to deal with namespaces here and how do they affect generated test names? my $test_case_ns = "DBI::Test::Case::$test_case"; eval "require $test_case_ns;"; $@ and carp $@ and next; # don't create tests for broken test cases my @test_drivers = @$alldrivers; $test_case_ns->can("filter_drivers") and @test_drivers = $test_case_ns->filter_drivers( $options, @test_drivers ); @test_drivers or next; $test_case_ns->can("supported_variant") or eval qq/ package # $test_case_ns; sub supported_variant { 1 }; 1; /; my %dsn_conf; foreach my $test_drv (@test_drivers) { %dsn_conf = ( %dsn_conf, $self->dsn_conf( $test_drv, $test_case_ns ) ); } my %pfx_dsns = $self->create_driver_prefixes( \%dsn_conf ); foreach my $pfx_dsn ( keys %pfx_dsns ) { foreach my $pfx_cfg ( keys %pfx_cfgs ) { $test_case_ns->supported_variant( $test_case, $pfx_cfg, $pfx_cfgs{$pfx_cfg}, $pfx_dsn, $pfx_dsns{$pfx_dsn}, $options ) or next; my $test_dir = $self->create_test( $test_case, $pfx_cfg, $pfx_cfgs{$pfx_cfg}, $pfx_dsn, $pfx_dsns{$pfx_dsn}, $options ); $test_dirs{$test_dir} = 1; } } } return keys %test_dirs; } sub setup { my ( $self, %options ) = @_; my %allconf = $self->allconf(); # from DBI::Test::{NameSpace}::List->test_cases() my @alltests = $self->alltests(); my @alldrivers = $self->alldrivers(); my @gen_test_dirs = $self->populate_tests( \@alltests, \%allconf, \@alldrivers, \%options ); if ( $options{SKIP_FILE} ) { open( my $fh, ">", $options{SKIP_FILE} ) or croak("Can't open $options{SKIP_FILE} for writing: $!"); print $fh map { $_ . "/.*\\.t\n"; } @gen_test_dirs; close($fh); } return map { File::Spec->catfile( $_, "*.t" ) } @gen_test_dirs; } =head1 NAME DBI::Test::Conf - provides variants configuration for DBI::Test =head1 DESCRIPTION This module provides the configuration of variants for tests generated from DBI::Test::Case list. =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) Joakim TE<0x00f8>rmoen (trmjoa) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut 1; DBI-Test-0.001/lib/DBI/Test/DSN/000755 000765 000024 00000000000 12200131036 015462 5ustar00snostaff000000 000000 DBI-Test-0.001/lib/DBI/Test/List.pm000644 000765 000024 00000001205 12177727620 016334 0ustar00snostaff000000 000000 package DBI::Test::List; use strict; use warnings; sub test_cases { return qw(basic::connect basic::disconnect); } =head1 NAME DBI::Test::List - provides tests cases list for DBI::Test. =head1 DESCRIPTION =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) Joakim TE<0x00f8>rmoen (trmjoa) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut 1; DBI-Test-0.001/lib/DBI/Test/DSN/Provider/000755 000765 000024 00000000000 12200131036 017254 5ustar00snostaff000000 000000 DBI-Test-0.001/lib/DBI/Test/DSN/Provider.pm000644 000765 000024 00000003520 12177752247 017644 0ustar00snostaff000000 000000 package DBI::Test::DSN::Provider; use strict; use warnings; use Module::Pluggable::Object (); my $dsn_plugins; sub dsn_plugins { defined $dsn_plugins and return @{$dsn_plugins}; my $finder = Module::Pluggable::Object->new( search_path => ["DBI::Test"], only => qr/DBI::Test::(?:\w+::)*DSN::Provider.*/, require => 1, inner => 0 ); my @plugs = grep { $_->isa("DBI::Test::DSN::Provider::Base") and $_->can("get_dsn_creds") } $finder->plugins(); $dsn_plugins = \@plugs; return @$dsn_plugins; } sub get_dsn_creds { my ( $self, $test_case_ns, $default_creds ) = @_; my @plugins = sort { $b->relevance( $test_case_ns, $default_creds ) <=> $a->relevance( $test_case_ns, $default_creds ) } grep { $_->relevance( $test_case_ns, $default_creds ) > 0 } $self->dsn_plugins(); foreach my $plugin (@plugins) { # Hash::Merge->merge( ... ) my $dsn_creds = $plugin->get_dsn_creds( $test_case_ns, $default_creds ); $dsn_creds and return $dsn_creds; } $default_creds and return $default_creds; return [ 'dbi:NullP:', undef, undef, { ReadOnly => 1 } ]; } 1; =head1 NAME DBI::Test::DSN::Provider - choose appropriate DSN =head1 DESCRIPTION =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut DBI-Test-0.001/lib/DBI/Test/DSN/Provider/Base.pm000644 000765 000024 00000001655 12177474264 020525 0ustar00snostaff000000 000000 package DBI::Test::DSN::Provider::Base; use strict; use warnings; sub relevance { my ($self, $test_case_ns, $default_creds) = @_; $default_creds or return -1; $default_creds->[0] or return -1; (my $driver = $default_creds->[0]) =~ s/^dbi:(\w*?)(?:\((.*?)\))?:/$1/i; (my $me = ref($self)) =~ s/.*::(\w+)$/$1/; $driver eq $me and return 99; # 100 is safed for Config return 10; } 1; =head1 NAME DBI::Test::DSN::Provider::Base - base class for DSN Provider Plugins =head1 DESCRIPTION Provides a default for relevance =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut DBI-Test-0.001/lib/DBI/Test/DSN/Provider/Config.pm000644 000765 000024 00000011143 12177731752 021047 0ustar00snostaff000000 000000 package DBI::Test::DSN::Provider::Config; use strict; use warnings; use parent qw(DBI::Test::DSN::Provider::Base); require Cwd; require File::Spec; my $json; my $have_config_any; my $have_file_configdir; my $have_file_find_rule; BEGIN { foreach my $mod (qw(JSON JSON::PP)) { eval "require $mod"; $@ and next; $json = $mod->new(); last; } # $json or die "" . __PACKAGE__ . " requires a JSON parser"; # finally ... Config::Any could be enough, and most recent # perl5 are coming with JSON::PP $have_file_configdir = 0; eval { require File::ConfigDir; ++$have_file_configdir; }; $have_config_any = 0; eval { require Config::Any; ++$have_config_any; }; $have_file_find_rule = 0; eval { require File::Find::Rule; ++$have_file_find_rule; }; 1; # shadow whatever we did :D } sub relevance { 100 }; $have_file_configdir or *find_config_dirs = sub { my @confdirs = ( Cwd::getcwd(), $ENV{HOME} ); return @confdirs; }; $have_file_configdir and *find_config_dirs = sub { # XXX File::ConfigDir could support config files per what-ever, # if we use # config_dirs("dbi-test") my @confdirs = File::ConfigDir::config_dirs(); return @confdirs; }; $have_config_any or *get_config_pattern = sub { my @pattern; $json and push( @pattern, "json" ); @pattern; }; $have_config_any and *get_config_pattern = sub { my @pattern = Config::Any->extensions(); return @pattern; }; $have_file_find_rule or *find_config_files = sub { my ( $self, $ns ) = @_; my @cfg_pattern = map { "dbi-test" . $_ } $self->get_config_pattern(); my @cfg_dirs = $self->find_config_dirs(); my @cfg_files; foreach my $dir (@cfg_dirs) { foreach my $pat (@cfg_pattern) { my $fn = File::Spec->catfile( $dir, $pat ); -f $fn and -r $fn and push( @cfg_files, $fn ); } } return @cfg_files; }; $have_file_find_rule and *find_config_files = sub { my ( $self, $ns ) = @_; my @cfg_pattern = map { "dbi-test" . $_ } $self->get_config_pattern(); my @cfg_dirs = $self->find_config_dirs(); my @cfg_files = File::Find::Rule->file()->name(@cfg_pattern)->maxdepth(1)->in(@cfg_dirs); }; $have_config_any or *read_config_files = sub { my ( $self, @config_files ) = @_; my $all_cfg; foreach my $cfg_fn (@config_files) { my $fh; open( $fh, "<", $cfg_fn ) or next; # shouldn't happen, shall we die instead? local $/; my $cfg_cnt = <$fh>; close($fh); $all_cfg->{$cfg_fn} = $json->decode($cfg_cnt); } return $all_cfg; }; $have_config_any and *read_config_files = sub { my ( $self, @config_files ) = @_; my $all_cfg = Config::Any->load_files( { files => [@config_files], use_ext => 1, flatten_to_hash => 1, } ); return $all_cfg; }; sub get_config { my ($self) = @_; my %cfg; my @config_files = $self->find_config_files(); my $all_cfg = $self->read_config_files(@config_files); foreach my $filename (@config_files) { defined( $all_cfg->{$filename} ) or next; # file not found or not parsable ... # merge into default and previous loaded config ... %cfg = ( %cfg, %{ $all_cfg->{$filename} } ); } return %cfg; } sub get_dsn_creds { my ( $self, $test_case_ns, $default_creds ) = @_; my %connect_details = (); $test_case_ns->can("connect_details") and %connect_details = ( %connect_details, %{ $test_case_ns->connect_details($test_case_ns) } ); my %cfg = $self->get_config($test_case_ns); defined( $cfg{$test_case_ns} ) and return $cfg{$test_case_ns}; defined( $cfg{"DBI::Test"} ) and return $cfg{"DBI::Test"}; return; } 1; =head1 NAME DBI::Test::DSN::Provider::Config - provides DSN based on config file =head1 DESCRIPTION This DSN provider delivers connection attributes based on a config file. =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut DBI-Test-0.001/lib/DBI/Test/DSN/Provider/Dir.pm000644 000765 000024 00000003631 12177474022 020355 0ustar00snostaff000000 000000 package DBI::Test::DSN::Provider::Dir; use strict; use warnings; use parent qw(DBI::Test::DSN::Provider::Base); use File::Basename; use File::Path; use File::Spec; use Carp qw(carp croak); my $test_dir; END { defined( $test_dir ) and rmtree $test_dir } sub test_dir { unless( defined( $test_dir ) ) { $test_dir = File::Spec->rel2abs( File::Spec->curdir () ); $test_dir = File::Spec->catdir ( $test_dir, "test_output_" . $$ ); $test_dir = VMS::Filespec::unixify($test_dir) if $^O eq 'VMS'; rmtree $test_dir; mkpath $test_dir; # There must be at least one directory in the test directory, # and nothing guarantees that dot or dot-dot directories will exist. mkpath ( File::Spec->catdir( $test_dir, '000_just_testing' ) ); } return $test_dir; } sub get_dsn_creds { my ($self, $test_case_ns, $default_creds) = @_; $default_creds or return; $default_creds->[0] or return; (my $driver = $default_creds->[0]) =~ s/^dbi:(\w*?)(?:\((.*?)\))?:.*/DBD::$1/i; # my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver) # or die "panic: $class->install_driver($driver) failed"; eval "require $driver;"; $@ and return; $driver->isa("DBD::File") or return; my @creds = @$default_creds; $creds[3]->{f_dir} = test_dir(); return \@creds; } 1; =head1 NAME DBI::Test::DSN::Provider::Dir - provide DSN in own directory =head1 DESCRIPTION This DSN provider delivers an owned directory for connection attributes. =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut DBI-Test-0.001/lib/DBI/Test/DSN/Provider/File.pm000644 000765 000024 00000001272 12177473760 020525 0ustar00snostaff000000 000000 package DBI::Test::DSN::Provider::File; use strict; use warnings; use parent qw(DBI::Test::DSN::Provider::Base); 1; =head1 NAME DBI::Test::DSN::Provider::File - provide DSN in shared directory =head1 DESCRIPTION This DSN provider delivers a file name in a shared directory for connection attributes. =head1 AUTHOR This module is a team-effort. The current team members are H.Merijn Brand (Tux) Jens Rehsack (Sno) Peter Rabbitson (ribasushi) =head1 COPYRIGHT AND LICENSE Copyright (C)2013 - The DBI development team You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =cut DBI-Test-0.001/lib/DBI/Test/Case/attributes/000755 000765 000024 00000000000 12200131036 020077 5ustar00snostaff000000 000000 DBI-Test-0.001/lib/DBI/Test/Case/basic/000755 000765 000024 00000000000 12200131036 016772 5ustar00snostaff000000 000000 DBI-Test-0.001/lib/DBI/Test/Case/basic/bind_columns.pm000644 000765 000024 00000010100 12132526444 022013 0ustar00snostaff000000 000000 use strict; use warnings; use Test::More; our @DB_CREDS = ('dbi:SQLite::memory:', undef, undef, {}); my %SQLS = ( 'SELECT' => 'SELECT a, b FROM x', 'INSERT' => 'INSERT 1' ); my $dbh = DBI->connect( @DB_CREDS ); isa_ok($dbh, 'DBI::db'); #TO BE REMOVED $dbh->do("CREATE TABLE x(a INTEGER PRIMARY KEY, b INTEGER)") or die $DBI::errstr; { TODO : { local $TODO = "Must be able to mock fetch to change variables to a certain value"; my ($a, $b); my $sth = $dbh->prepare($SQLS{SELECT}); $sth->execute; # Bind Perl variables to columns: ok($sth->bind_columns(\$a, \$b), 'bind_columns'); #Need to mock the fetch method #Q : Where is the fetch method documented. Return values? $sth->fetch(); cmp_ok($a, 'eq', 'a', '$a eq a'); cmp_ok($b, 'eq', 'b', '$b eq b') } } { #Same test as above, just with a different perl reference syntax. See perlref # and DBI fetch example TODO : { local $TODO = "Must be able to mock fetch to change variables to a certain value"; my ($a, $b); my $sth = $dbh->prepare($SQLS{SELECT}); isa_ok($sth, 'DBI::st'); ok($sth->execute(), 'execute'); # Bind Perl variables to columns: ok($sth->bind_columns(\($a, $b)), 'bind_columns'); #Need to mock the fetch method #Q : Where is the fetch method documented. Return values? $sth->fetch(); cmp_ok($a, 'eq', 'a', '$a eq a'); cmp_ok($b, 'eq', 'b', '$b eq b') } } { # For compatibility with old scripts, the first parameter will be ignored if it is undef or a hash reference. TODO : { local $TODO = "Must be able to mock fetch to change variables to a certain value"; my $a = {}; my $b; my $sth = $dbh->prepare($SQLS{SELECT}); isa_ok($sth, 'DBI::st'); ok($sth->execute(), 'execute'); # Bind Perl variables to columns: ok($sth->bind_columns(\($a, $b)), 'bind_columns'); #Need to mock the fetch method #Q : Where is the fetch method documented. Return values? $sth->fetch(); is_deeply($a, {}, '$a is {}'); cmp_ok($b, 'eq', 'b', '$b eq b') } } { # For compatibility with old scripts, the first parameter will be ignored if it is undef or a hash reference. TODO : { local $TODO = "Must be able to mock fetch to change variables to a certain value"; my $a = undef; my $b; my $sth = $dbh->prepare($SQLS{SELECT}); isa_ok($sth, 'DBI::st'); ok($sth->execute(), 'execute'); # Bind Perl variables to columns: ok($sth->bind_columns(\($a, $b)), 'bind_columns'); #Need to mock the fetch method #Q : Where is the fetch method documented. Return values? $sth->fetch(); ok(!$a, '$a is undef'); cmp_ok($b, 'eq', 'b', '$b eq b') } } { #Negative case. bind_columns fails my $dbh = DBI->connect( @DB_CREDS[0..2], {} ); #The PrintError is default to true isa_ok($dbh, 'DBI::db'); #TO BE REMOVED $dbh->do("CREATE TABLE x(a INTEGER PRIMARY KEY, b INTEGER)") or die $DBI::errstr; TODO : { local $TODO = "Must be able to mock bind_columns to fail"; my ($a, $b); my $sth = $dbh->prepare($SQLS{SELECT}); isa_ok($sth, 'DBI::st'); ok($sth->execute(), 'execute'); my $warnings = 0; #Make sure we fetch the local local $SIG{__WARN__} = sub { $warnings++; #TODO : Must be the correct warning }; # Bind Perl variables to columns: ok(!$sth->bind_columns(\$a, \$b), 'bind_columns'); cmp_ok($warnings, '>', 0, "warning displayed"); } } { #Negative case. bind_columns fails with RaiseError my $dbh = DBI->connect( @DB_CREDS[0..2], { RaiseError => 1 } ); isa_ok($dbh, 'DBI::db'); #TO BE REMOVED $dbh->do("CREATE TABLE x(a INTEGER PRIMARY KEY, b INTEGER)") or die $DBI::errstr; TODO : { local $TODO = "Must be able to mock bind_columns to fail"; my ($a, $b); my $sth = $dbh->prepare($SQLS{SELECT}); isa_ok($sth, 'DBI::st'); ok($sth->execute(), 'execute'); # Bind Perl variables to columns: eval{ $sth->bind_columns(\$a, \$b); }; ok($@, 'bind_columns died'); } } done_testing();DBI-Test-0.001/lib/DBI/Test/Case/basic/connect.pm000644 000765 000024 00000005715 12176536647 021026 0ustar00snostaff000000 000000 package DBI::Test::Case::basic::connect; use strict; use warnings; use parent qw(DBI::Test::Case); use Test::More; use DBI::Test; sub run_test { my @DB_CREDS = @{$_[1]}; { my $dbh = connect_ok( @DB_CREDS, "basic connect" ); #Active should be true when you are connected #disconnect set Active to false ok( $dbh->{Active}, "dbh is active" ); } { #Testing that the connect attributes are correctly set SKIP: { skip "No attributes provided", 1 if ( !defined $DB_CREDS[3] || ref( $DB_CREDS[3] ) ne 'HASH' ); my $dbh = connect_ok( @DB_CREDS, "basic connect" ); #Check the $dbh->{Attribute} and $dbh->FETCH('Attribute') interface foreach my $attr ( keys %{ $DB_CREDS[3] } ) { is( $dbh->{$attr}, $DB_CREDS[3]->{$attr}, $attr . ' == ' . $DB_CREDS[3]->{$attr} ); is( $dbh->FETCH($attr), $DB_CREDS[3]->{$attr}, $attr . ' == ' . $DB_CREDS[3]->{$attr} ); } } } { #Check some default values my $dbh = connect_ok( @DB_CREDS[ 0 .. 2 ], {}, "connect without attr" ); for (qw(AutoCommit PrintError)) { cmp_ok( $dbh->{$_}, '==', 1, $_ . ' == 1' ); cmp_ok( $dbh->FETCH($_), '==', 1, $_ . ' == 1' ); } TODO: { #Seems like $^W doesnt honor the use warnings pragma.. Is PrintWarn affected by the pragma, or only the -w cmd flag? local $TODO = "PrintWarn should default to true if warnings is enabled. How to check?"; diag '$^W= ' . $^W . "\n"; cmp_ok( $dbh->{PrintWarn}, '==', ( ($^W) ? 1 : 0 ), 'PrintWarn == ' . ( ($^W) ? 1 : 0 ) ); } } { #Negative test #Use a fake dsn that does not exists #TODO : Using a invalid dsn does not work. Drivers like SQLite etc will just create a file with that name #It isnt so simple we will have to use a DBD that is available. Or do we do them all? TODO: { local $TODO = "How to make the connect fail. Just using a wrong dsn doesnt seem to cut it"; #TODO, make this more portable my $dsn = $DB_CREDS[0]; $dsn =~ s/(dbi:[A-Za-z_\-0-9]+::).+/$1/; $dsn .= "invalid_db"; #PrintError is on by default, so we should check that we can intercept a warning my $warnings = 0; #TODO : improve this local $SIG{__WARN__} = sub { $warnings++; }; connect_not_ok( $dsn, @DB_CREDS[ 1 .. 2 ], {}, "Connection failure" ); cmp_ok( $warnings, '>', 0, "warning displayed" ); ok( $DBI::err, '$DBI::err defined' ); ok( $DBI::errstr, '$DBI::errstr defined' ); } } done_testing(); } 1; DBI-Test-0.001/lib/DBI/Test/Case/basic/disconnect.pm000644 000765 000024 00000007217 12177730732 021515 0ustar00snostaff000000 000000 package DBI::Test::Case::basic::disconnect; use strict; use warnings; use parent qw(DBI::Test::Case); use Test::More; use DBI::Test; sub run_test { my @DB_CREDS = @{ $_[1] }; my %SQLS = ( 'SELECT' => 'SELECT 1+1', 'INSERT' => undef ); { #Basic test my $dbh = connect_ok(@DB_CREDS, "basic connect"); ok( $dbh->disconnect(), "Disconnect" ); #Disconnect should clear the active flag of a database handle ok( !$dbh->{Active}, 'dbh is inactive' ); } SKIP: { #Test that disconnect prints a warning if it disconncets on an active statementhandler #Q: Does it print an warning even though PrintWarn is false? my $dbh = connect_ok(@DB_CREDS, "basic connect"); skip("Invalid SQL for some engines", 1); #Create statementhandler my $sth = prepare_ok( $dbh, $SQLS{SELECT}, undef, "prepare $SQLS{SELECT}"); #TODO : some SELECT should go inside here, or? execute_ok($sth, "execute $SQLS{SELECT}" ); my $warnings = 0; #Make sure we fetch the local local $SIG{__WARN__} = sub { $warnings++ if ( shift() =~ m/^DBI::db/ ); }; #The statementhandler should have more rows to fetch ok( $dbh->disconnect(), "Disconnect" ); # cmp_ok( $warnings, '>', 0, "Catched a warning" ); } { #Negative test #TODO how should we force it to fail. Mock DBD\DBI? TODO: { local $TODO = "Must make an API to make the disconnecct fail"; my $dbh = connect_ok(@DB_CREDS, "basic connect"); #Put code to make disconnect fail in here ok( !$dbh->disconnect(), "Disconnect failure" ); #Check that $DBI::err && $DBI::errstr is set #It should be set after a failed call ok( $DBI::err, '$DBI::err is set' ); ok( $DBI::errstr, '$DBI::errstr is set' ); #Disconnect failed. The Active flag should still be true ok( $dbh->{Active}, 'dbh is still active' ); } } { #Check that disconnect does print an error when PrintError is true #TODO how should we force it to fail. Mock DBD\DBI? TODO: { local $TODO = "Must make an API to make the disconnecct fail"; my $dbh = connect_ok(@DB_CREDS[ 0 .. 2 ], { PrintError => 1 }, "connect with PrintError"); my @warnings = (); #Make sure we fetch the local local $SIG{__WARN__} = sub { my ( $called_from, $warning ) = @_; # to find out Carping methods my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn'; my @warning_stack = split /\n/, $warning; # some stuff of uplevel is included push( @warnings, $warning_stack[0] ); }; #TODO : force disconncet to fail #Put code to make disconnect fail in here ok( !$dbh->disconnect(), "Disconnect failure" ); cmp_ok( scalar(@warnings), '>', 1, "Warning recorded" ); } } { #Check that disconnect does dies on fail when RaiseError is set #TODO how should we force it to fail. Mock DBD\DBI? TODO: { local $TODO = "Must make an API to make the disconnecct fail"; my $dbh = DBI->connect( @DB_CREDS[ 0 .. 2 ], { RaiseError => 1 } ); isa_ok( $dbh, 'DBI::db' ); #TODO : force disconncet to fail #Put code to make disconnect fail in here eval { $dbh->disconnect(); }; ok( $@, "Disconnect raised error" ); } } done_testing(); } 1; DBI-Test-0.001/lib/DBI/Test/Case/basic/do.pm000644 000765 000024 00000003602 12140535102 017740 0ustar00snostaff000000 000000 use strict; use warnings; use Test::More; our @DB_CREDS = ('dbi:SQLite::memory:', undef, undef, {}); my %SQLS = ( 'SELECT' => 'SELECT a, b FROM x', 'SELECT_ZERO_ROWS' => 'SELECT a, b FROM x WHERE 1 = 2', 'INSERT' => 'INSERT INTO x VALUES(1, 1)', 'UPDATE' => 'UPDATE x SET a = 2', 'UPDATE_ZERO_ROWS' => 'UPDATE x SET a = 3 WHERE 1 = 2', 'DELETE' => 'DELETE FROM x WHERE b = 3', 'DELETE_ZERO_ROWS' => 'DELETE FROM x WHERE 1 = 2' ); my $dbh = DBI->connect( @DB_CREDS ); isa_ok($dbh, 'DBI::db'); #TO BE REMOVED $dbh->do("CREATE TABLE x(a INTEGER, b INTERGER)") or die $DBI::errstr; { #A very basic case. Checks that do returns a true value # Q: Do we need to test SELECT case? for( qw( SELECT SELECT_ZERO_ROWS INSERT UPDATE UPDATE_ZERO_ROWS) ){ my $retval = $dbh->do($SQLS{$_}); ok( $retval, 'dbh->do should return a true value'); } } { #Test that the driver returns 0E0 or -1 for 0 rows for( qw(UPDATE_ZERO_ROWS DELETE_ZERO_ROWS) ){ my $retval = $dbh->do($SQLS{$_}); ok( (defined $retval && ( $retval eq '0E0' || $retval == -1)) ? 1 : undef, '0E0 or -1 returned for zero rows query'); } } { #Test that the driver return > 0 for a SELECT that gives rows TODO : { local $TODO = "Make sure the query return rows"; for( qw(DELETE UPDATE INSERT) ){ my $retval = $dbh->do($SQLS{$_}); ok( (defined $retval && ( $retval > 0 || $retval == -1)) ? 1 : undef, 'return value for query with rows in result is > 0 or -1'); } } } { #Negative test. Check that do actually returns undef on failure TODO : { local $TODO = 'Make dbh->do fail'; for( qw(INSERT UPDATE UPDATE_ZERO_ROWS DELETE DELETE_ZERO_ROWS SELECT SELECT_ZERO_ROWS) ){ ok(!$dbh->do($SQLS{$_}), 'dbh->do() returns undef'); ok($DBI::err, '$DBI::err is set on dbh->do failure'); ok($DBI::errstr, '$DBI::errstr is set on dbh->do failure'); } } } done_testing();DBI-Test-0.001/lib/DBI/Test/Case/basic/execute.pm000644 000765 000024 00000003455 12132526444 021020 0ustar00snostaff000000 000000 use strict; use warnings; use Test::More; our @DB_CREDS = ('dbi:SQLite::memory:', undef, undef, {}); my %SQLS = ( 'SELECT' => 'SELECT 1+1', 'INSERT' => 'INSERT INTO x VALUES(1)' ); my $dbh = DBI->connect( @DB_CREDS ); isa_ok($dbh, 'DBI::db'); #TO BE REMOVED $dbh->do("CREATE TABLE x(a INTEGER PRIMARY KEY)") or die $DBI::errstr; #Q : How does prepare deside the query type? { #Basic test SELECT my $sth = $dbh->prepare($SQLS{SELECT}); ok($sth->execute(), "Execute sth"); #According to the DBI doc NUM_OF_FIELDS should be larger then 0 after a SELECT statement cmp_ok($sth->{NUM_OF_FIELDS}, '>', 0, 'NUM_OF_FIELDS > 0'); #Make sure the Execute attribute is true after execution ok($sth->{Executed}, 'sth executed is true after execution'); } { #Basic test INSERT my $sth = $dbh->prepare($SQLS{INSERT}); my $retval = $sth->execute(); #$retval should be either a digit or 0E0 after a execute of a non-SELECT statement ok( (( defined $retval && ($retval eq '0E0' || $retval > 0)) ? 1 : undef ), 'returnvalue of execute is sane'); #Make sure the Execute attribute is true after execution ok($sth->{Executed}, 'sth execute is true after execution'); } { #Execute fails TODO : { local $TODO = "Must have an API to make execute fail"; my $dbh = DBI->connect( @DB_CREDS[0..2], {} ); isa_ok($dbh, 'DBI::db'); #Do something so that prepare fails my $sth = $dbh->prepare($SQLS{SELECT}); ok(!$sth->execute(), "execute fails"); #Check that the sth is not marked as Executed if the execution fails ok(!$sth->{Executed}, "not marked as executed"); #Check that $DBI::err && $DBI::errstr is set #It should be set after a failed call ok($DBI::err, '$DBI::err is set'); ok($DBI::errstr, '$DBI::errstr is set'); } } done_testing();DBI-Test-0.001/lib/DBI/Test/Case/basic/prepare.pm000644 000765 000024 00000004633 12176532560 021017 0ustar00snostaff000000 000000 package DBI::Test::Case::basic::prepare; use strict; use warnings; use parent qw(DBI::Test::Case); use Test::More; sub run_test { my @DB_CREDS = @{ $_[1] }; my %SQLS = ( 'SELECT' => 'SELECT 1+1', 'INSERT' => undef ); { #Basic test my $dbh = DBI->connect(@DB_CREDS); isa_ok( $dbh, 'DBI::db' ); my $sth; eval { $sth = $dbh->prepare( $SQLS{SELECT} ); }; ok( !$@, "Prepared query" ); SKIP: { skip "Could not prepare query", 1 if !$sth; isa_ok( $sth, 'DBI::st' ); } } { #Prepare should fail TODO: { local $TODO = "Must have an API to make prepare fail"; my $dbh = DBI->connect( @DB_CREDS[ 0 .. 2 ], {} ); isa_ok( $dbh, 'DBI::db' ); #Do something so that prepare fails my $sth = $dbh->prepare( $SQLS{SELECT} ); ok( !$sth, "Prepared failed" ); #Check that $DBI::err && $DBI::errstr is set #It should be set after a failed call ok( $DBI::err, '$DBI::err is set' ); ok( $DBI::errstr, '$DBI::errstr is set' ); } } { #Prepare should print a warning if PrintError is set TODO: { local $TODO = "Must have an API to make prepare fail"; my $dbh = DBI->connect( @DB_CREDS[ 0 .. 2 ], { PrintError => 1 } ); isa_ok( $dbh, 'DBI::db' ); my $warnings = 0; #Make sure we fetch the local local $SIG{__WARN__} = sub { $warnings++; #TODO : Must be the correct warning }; #Do something so that prepare fails my $sth = $dbh->prepare( $SQLS{SELECT} ); ok( !$sth, "prepare failed" ); cmp_ok( $warnings, '>', 0, "Recorded a warning" ); } } { #Prepare should die if RaiseError is set TODO: { local $TODO = "Must have an API to make prepare fail"; my $dbh = DBI->connect( @DB_CREDS[ 0 .. 2 ], { RaiseError => 1 } ); isa_ok( $dbh, 'DBI::db' ); #Do something so that prepare fails my $sth; eval { $sth = $dbh->prepare( $SQLS{SELECT} ); }; ok( $@, "prepare died" ); ok( !$sth, 'sth is undef' ); } } done_testing(); } 1; DBI-Test-0.001/lib/DBI/Test/Case/basic/type_info.pm000644 000765 000024 00000012024 12140535102 021330 0ustar00snostaff000000 000000 use strict; use warnings; use Test::More; our @DB_CREDS = ('dbi:SQLite::memory:', undef, undef, {}); # NOTES: This test is a draft. Need to figure out several things. # TODO : We should implement stricter tests for the datastructure keys my @required_keys = qw( TYPE_NAME DATA_TYPE COLUMN_SIZE LITERAL_PREFIX LITERAL_SUFFIX CREATE_PARAMS NULLABLE CASE_SENSITIVE SEARCHABLE UNSIGNED_ATTRIBUTE FIXED_PREC_SCALE AUTO_UNIQUE_VALUE LOCAL_TYPE_NAME MINIMUM_SCALE MAXIMUM_SCALE SQL_DATA_TYPE SQL_DATETIME_SUB NUM_PREC_RADIX INTERVAL_PRECISION ); my $dbh = DBI->connect( @DB_CREDS ); isa_ok($dbh, 'DBI::db'); { #Checks that type_info returns a list of hashrefs containing the correct keys # if the method is called without arguments my @data_without_args = $dbh->type_info(); #No argument should be passed test_type_info( @data_without_args ); } { #Check that type_info() returns the same with no arguments as with argument SQL_ALL_TYPES #TODO import DBI constants my @data_with_args = $dbh->type_info( DBI::SQL_ALL_TYPES ); test_type_info(@data_with_args); #To be sure, match the two datastructures my @data_without_args = $dbh->type_info(); is_deeply(\@data_without_args, \@data_with_args, "Calling type_info without and with argument is equal"); } { #If type_info is called with an arrayref as an argument, it should return # the information from the first type in the array that has any matches TODO : { local $TODO = 'Need to check that $sql_timestamp_type is correct'; my $sql_timestamp_type = $dbh->type_info( [ 99999, DBI::SQL_TIMESTAMP ] ); #99999 is a chosen number that hopefully is not defined by a DBI constant } } sub test_type_info{ my @type_info_data = @_; #Check that each element in the array is a hashref with the correct keys for( my $i = 0; $i < scalar(@type_info_data); $i++){ my $element = $type_info_data[$i]; cmp_ok(ref($element), 'eq', 'HASH', 'Element #' . $i . ' is a hashref'); #Testing that we have the required hashkeys ok(exists $element->{$_}, 'Element #' . $i . ' has key ' . $_) for(@required_keys); #Check the TYPE_NAME # TODO : Implement some sort of more specific check. Can we produce a list of valid TYPE_NAMES? #Check that DATA_TYPE has a valid integer value or undef #TODO : This should be checked against DBI constant or something? ok( !defined $element->{DATA_TYPE} || $element->{DATA_TYPE} =~ m/^\d+$/, 'DATA_TYPE is an integer'); #Check that COLUMN_SIZE is an integer or undef ok( !defined $element->{COLUMN_SIZE} || $element->{COLUMN_SIZE} =~ m/^\d+$/, 'COLUMN_SIZE is an integer'); # TODO: Create a stricter test for this key #Check that NULLABLE is 0, empty string, 1 or 2 # Valid values are: # undef - not set by the DBD # 0 or an empty string = no # 1 = yes # 2 = unknown ok( !defined $element->{NULLABLE} || $element->{NULLABLE} eq '' || $element->{NULLABLE} =~ m/^(1|2)$/, 'NULLABLE is undef, empty string, 0, 1 or 2' ); #Check that SEARCHABLE is undef, 0, 1, 2 or 3 # Valid values: # undef - Not set by the DBD # 0 - Cannot be used in a WHERE clause # 1 - Only with a LIKE predicate # 2 - All comparison operators except LIKE # 3 - Can be used in a WHERE clause with any comparison operator ok( !defined $element->{SEARCHABLE} || $element->{SEARCHABLE} =~ m/^(0|1|2|3)$/, 'SEARCHABLE is undef, 0, 1, 2 or 3' ); #If FIXED_PREC_SCALE is set MINIMUM_SCALE and MAXIMUM_SCALE should be equal SKIP : { skip 'FIXED_PREC_SCALE is undef', 1 if !$element->{FIXED_PREC_SCALE}; cmp_ok( $element->{MINIMUM_SCALE}, '==', $element->{MAXIMUM_SCALE}, 'MINIMUM_SCALE == MAXIMUM_SCALE'); } #Check that MINIMUM_SCALE is undef or an integer ok( !defined $element->{MINIMUM_SCALE} || $element->{MINIMUM_SCALE} =~ m/^\d+$/, 'MINIMUM_SCALE is undef or integer'); #Check that MAXIMUM_SCALE is undef or an integer ok( !defined $element->{MAXIMUM_SCALE} || $element->{MAXIMUM_SCALE} =~ m/^\d+$/, 'MAXIMUM_SCALE is undef or integer'); #Check that SQL_DATA_TYPE is an integer # TODO : Do a better test ok( !defined $element->{SQL_DATA_TYPE} || $element->{SQL_DATA_TYPE} =~ m/^\d+$/, "SQL_DATA_TYPE is undef or integer" ); #Check that SQL_DATETIME_SUB is an integer # TODO : Do a better test ok( !defined $element->{SQL_DATETIME_SUB} || $element->{SQL_DATETIME_SUB} =~ m/^\d+$/, "SQL_DATETIME_SUB is undef or integer" ); #Check that NUM_PREC_RADIX is an integer # TODO : Do a better test ok( !defined $element->{NUM_PREC_RADIX} || $element->{NUM_PREC_RADIX} =~ m/^\d+$/, "NUM_PREC_RADIX is undef or integer" ); #Check that INTERVAL_PRECISION is an integer # TODO : Do a better test ok( !defined $element->{INTERVAL_PRECISION} || $element->{INTERVAL_PRECISION} =~ m/^\d+$/, "INTERVAL_PRECISION is undef or integer" ); } } done_testing();DBI-Test-0.001/lib/DBI/Test/Case/attributes/PrintError.pm000644 000765 000024 00000003450 12132543473 022565 0ustar00snostaff000000 000000 use strict; use warnings; use Test::More; our @DB_CREDS = ('dbi:SQLite::memory:', undef, undef, {}); my %SQLS = ( 'SELECT' => 'SELECT a, b FROM x', 'SELECT_ZERO_ROWS' => 'SELECT a, b FROM x WHERE 1 == 2', 'INSERT' => undef ); my $a; my %methods = ( dbh => { prepare => [$SQLS{SELECT}], prepare_cached => [$SQLS{SELECT}], disconnect => [] }, sth => { bind_columns => [\$a], execute => [] } ); { #Testing PrintError on dbh methods failure my $dbh = DBI->connect( @DB_CREDS[0..2], {} ); isa_ok($dbh, 'DBI::db'); my @warnings = (); #Make sure we fetch the local local $SIG{__WARN__} = sub { push(@warnings, shift()); }; TODO : { local $TODO = "Need to make dbh methods fail"; while( my ($dbh_method, $dbh_args) = each %{ $methods{dbh} } ){ ok(!$dbh->$dbh_method( @{$dbh_args} ), '$dbh->' . $dbh_method . '() fails'); } } cmp_ok(scalar(@warnings), '==', scalar(keys %{ $methods{dbh} }), 'Recorded ' . scalar( keys %{ $methods{dbh} }) . ' warnings'); } { #Testing PrintError on sth methods failure my $dbh = DBI->connect( @DB_CREDS[0..2], {} ); isa_ok($dbh, 'DBI::db'); #TO BE REMOVED $dbh->do("CREATE TABLE x(a INTEGER PRIMARY KEY, b INTEGER)") or die $DBI::errstr; my $sth = $dbh->prepare($SQLS{SELECT}); isa_ok($sth, 'DBI::st'); my @warnings = (); #Make sure we fetch the local local $SIG{__WARN__} = sub { push(@warnings, shift()); }; TODO : { local $TODO = "Need to make sth methods fail"; while( my ($sth_method, $sth_args) = each %{ $methods{sth} } ){ ok($sth->$sth_method( @{ $sth_args } ), '$sth->' . $sth_method . '() fails'); } } cmp_ok(scalar(@warnings), '==', scalar( keys %{ $methods{sth} }), 'Recorded ' . scalar( keys %{ $methods{sth} }) . ' warnings'); } done_testing();DBI-Test-0.001/lib/DBI/Test/Case/attributes/Warn.pm000644 000765 000024 00000000645 12132526444 021370 0ustar00snostaff000000 000000 use strict; use warnings; use Test::More; our @DB_CREDS = ('dbi:SQLite::memory:', undef, undef, { AutoCommit => 0}); my %SQLS = ( 'SELECT' => 'SELECT 1+1', 'INSERT' => undef ); { #Check that warn is enabled by default my $dbh = DBI->connect( @DB_CREDS[0..2], {} ); isa_ok($dbh, 'DBI::db'); ok($dbh->{Warn}, '$dbh->{Warn} is true'); ok($dbh->FETCH('Warn'), '$dbh->FETCH(Warn) is true'); } done_testing();