diff --git a/Changes b/Changes new file mode 100644 index 0000000..56bb86f --- /dev/null +++ b/Changes @@ -0,0 +1,142 @@ +Revision history for Perl extension DBD::Mock. + +0.19 Fri Jan 7 2005 + - changed the VERSION in lib/DBD/Mock.pm to be 1.23, allow me to explain... + + Chris Winters (the original author) used the CVS derived + VERSION, which when I took over the module (8 versions ago) + was at 1.15. Since I was not using Chris's CVS repo to store this + I decided to give Mock.pm the VERSION number found in the VERSION + file. + + Well,... PAUSE's indexer doesn't like it since it is a lower + number and would complain every time I uploaded a new version. + I ignored these complaints (at my own peril) until now. + + I found out recently that if you had version 0.11 or below installed + (where the Mock.pm was version 1.15 or below), then installing through + the CPAN shell would tell you DBD::Mock was up to date, even though it + wasn't. So in order to fix this issue, and make sure that all those who + want to install and update DBD::Mock easily, I changed the version + number of DBD::Mock to be 1.23 to reflect the number of updates + I have done since Chris handed it over to me. + + *sigh* + + Okay good, thats off my chest now. + +0.18 Wed Jan 5 2005 + - added reset() method to the + DBD::Mock::StatementTrack::Iterator object + - added test and docs for this + + - added the DBD::Mock::Session object and added + the support for it in the DBD::Mock driver + - added tests and docs for this + - Thanks to Rob Kinyon and Chris Winters for + their feedback on this feature + + - some general POD cleanup and formatting + +0.17 Thurs Nov 4 2004 + - added the following items: + - a 'mock_num_rows' attribute which will give you + the number of records affected/returned by the + last statement + - a num_rows method in the DBD::Mock::StatementTrack + object, which is where the above attribute gets it's + value + - added the 'rows' method for statement handles (which didnt + work before) + +0.16 Sat Oct 30 2004 + - minor change to the DBD::Mock::StatementTrack::Iterator + behavior. It no longer derefs the history array, so it + maintains a reference to it and therefore can be used like + this: + get-statement-iterator + run-query + check-next-statement-in-iterator + run-query + check-next-statement-in-iterator + ... + This prevents the need to re-fetch the iterator after + each query. + +0.15 Fri Oct 29 2004 + - added the DBD::Mock::StatementTrack::Iterator + object which can be accessed from the + 'mock_all_history_iterator' attribute. + - write the docs and test for it + +0.14 Fri Oct 29 2004 + - added the mock_last_insert_id attribute + which will get incremented upon each INSERT + query run. + - added tests and docs for this + - added the mock_start_insert_id attirbute + so that you can both reset and set the start + number for mock_last_insert_id + - added tests and docs for this + + ** EXPERIMENTAL FEATURE (use caution) ** + - added a feature to alias attributes. Basically it + allows you to alias an expected attribute like + 'mysql_insertid' to something DBD::Mock already has + like 'mock_last_insert_id'. + Right now this feature is highly experimental, and + has been added as a first attempt automatically handle + some of the DBD specific attributes which are commonly + used/accessed in DBI programming. + +0.13 Thurs Oct 28 2004 + - added prepare_cached as suggested by Rob Kinyon + in RT bug #7331. Also added his test script in + 15_prepare_cached.t + +0.12 Thurs Sept 2 2004 +** First version maintained by Stevan Little ** + - built up the test suite to 89.7% coverage + - removed the undocumented 'mock_auto_commit' since it really + was not very useful at this point. + - added the DBD::Mock::Pool functionality + - added tests for this + - added documentation for this + - added pod.t to test suite + - removed AUTOLOAD in DBD::Mock::StatementTrack and replaced it with + hand coded methods (sorry I really dislike AUTOLOAD) + - centralized error handling in DBD::Mock::_error_handler + +0.11 Fri Jul 23 10:35:13 EDT 2004 + + - Fix CPAN Bug #7057: add a no-op 'disconnect_all()' to + DBD::Mock::dr to support DBI versions earlier than 1.34. + + - Add the ability to create SQL parsers that get fired on a + prepare(). This way you can ensure your application generates + correct SQL and have the system fail at the right time. Thanks + to Rob Kinyon for the idea. + +0.10 Sat May 8 14:12:39 EDT 2004 + + - Incorporate number of patches from Stevan Little to implement + 'mock_can_connect', which allows you to simulate a downed + database. Add supporting tests for database and statement usage. + + - Add the ability for 'mock_add_resultset' to associate a + resultset with a particular SQL statement. Thanks to Stevan for + the idea. + + - Add documentation for database handle property + 'mock_add_resultset' + +0.02 Tue Mar 9 12:56:54 EST 2004 + + Add 'VERSION' to MANIFEST, thanks to Mike Castle for the note. + +0.01 Sun Mar 7 23:24:24 EST 2004 + + Initial version spawned from DBD::NullP shipped with the + DBI. Many thanks much to Tim Bunce for the pointer and the + original code. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..3819235 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,25 @@ +Changes +Makefile.PL +MANIFEST +META.yml +README +VERSION +lib/DBD/Mock.pm +t/00_basic.t +t/10_db_handle.t +t/11_dr_handle.t +t/12_db_can_connect.t +t/13_misc_mock_attr.t +t/14_db_parser.t +t/15_prepare_cached.t +t/16_mock_attribute_aliases.t +t/20_st_execute_empty.t +t/25_st_execute_bound_params.t +t/30_st_execute_pass_params.t +t/35_st_fetch_records.t +t/37_st_can_connect.t +t/40_mock_statement_track.t +t/45_mock_statement_track_iterator.t +t/50_db_pool.t +t/60_DBD_Mock_Session_test.t +t/pod.t diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..23a3c50 --- /dev/null +++ b/META.yml @@ -0,0 +1,10 @@ +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: DBD-Mock +version: 0.19 +version_from: VERSION +installdirs: site +requires: + DBI: 1.3 + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.12 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..6b9229f --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,12 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'DBD::Mock', + VERSION_FROM => 'VERSION', + PREREQ_PM => { + DBI => 1.30, + }, + ($] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => 'lib/DBD/Mock.pm', # retrieve abstract from module + AUTHOR => 'Chris Winters ') : ()), +); diff --git a/README b/README new file mode 100644 index 0000000..162831c --- /dev/null +++ b/README @@ -0,0 +1,34 @@ +DBD::Mock +===================== + +This is a simple mock DBD implementation used for testing. It's +entirely self-contained so that you can extract the single library +file (DBD/Mock.pm), put it in your own distribution and be able to run +DBI-based tests even though you don't have information about a +database. (If you're doing so you should probably get rid of the docs +to save space...) + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + DBI (wouldn't make too much sense without it...) + +COPYRIGHT AND LICENCE + +Copyright (C) 2004 Chris Winters +Copyright (C) 2004 Stevan Little + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +======================================== \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..13ccede --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +$VERSION = '0.19'; \ No newline at end of file diff --git a/lib/DBD/Mock.pm b/lib/DBD/Mock.pm new file mode 100644 index 0000000..2e58103 --- /dev/null +++ b/lib/DBD/Mock.pm @@ -0,0 +1,1462 @@ + +package DBD::Mock; + +sub import { + shift; + $DBI::connect_via = "DBD::Mock::Pool::connect" if (@_ && lc($_[0]) eq "pool"); +} + +# --------------------------------------------------------------------------- # +# Copyright (c) 2004 Stevan Little, Chris Winters +# (spawned from original code Copyright (c) 1994 Tim Bunce) +# --------------------------------------------------------------------------- # +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. +# --------------------------------------------------------------------------- # + +use strict; +use warnings; + +require DBI; + +our $VERSION = '1.23'; + +our $drh = undef; # will hold driver handle +our $err = 0; # will hold any error codes +our $errstr = ''; # will hold any error messages + +sub driver { + return $drh if defined $drh; + my ($class, $attributes) = @_; + $drh = DBI::_new_drh( "${class}::dr", { + Name => 'Mock', + Version => $DBD::Mock::VERSION, + Attribution => 'DBD Mock driver by Chris Winters & Stevan Little (orig. from Tim Bunce)', + Err => \$DBD::Mock::err, + Errstr => \$DBD::Mock::errstr, + }); + return $drh; +} + +sub CLONE { undef $drh } + +sub _error_handler { + my ($dbh, $error) = @_; + $dbh->DBI::set_err(1, $error); + if ($dbh->{'PrintError'}) { + warn "$error\n"; + } + elsif ($dbh->{'RaiseError'}) { + die "$error\n"; + } +} + +# NOTE: +# this feature is still quite experimental. It is defaulted to +# be off, but it can be turned on by doing this: +# $DBD::Mock::AttributeAliasing++; +# and then turned off by doing: +# $DBD::Mock::AttributeAliasing = 0; +# we shall see how this feature works out. + +our $AttributeAliasing = 0; + +my %AttributeAliases = ( + mysql => { + db => { + # aliases can either be a string which is obvious + mysql_insertid => 'mock_last_insert_id' + }, + st => { + # but they can also be a subroutine reference whose + # first argument will be either the $dbh or the $sth + # depending upon which context it is aliased in. + mysql_insertid => sub { (shift)->{Database}->{'mock_last_insert_id'} } + } + }, +); + +sub _get_mock_attribute_aliases { + my ($dbname) = @_; + (exists $AttributeAliases{lc($dbname)}) + || die "Attribute aliases not available for '$dbname'"; + return $AttributeAliases{lc($dbname)}; +} + +sub _set_mock_attribute_aliases { + my ($dbname, $dbh_or_sth, $key, $value) = @_; + return $AttributeAliases{lc($dbname)}->{$dbh_or_sth}->{$key} = $value; +} + +######################################## +# DRIVER + +package DBD::Mock::dr; + +use strict; +use warnings; + +$DBD::Mock::dr::imp_data_size = 0; + +sub connect { + my ($drh, $dbname, $user, $auth, $attributes) = @_; + $attributes ||= {}; + if ($dbname && $DBD::Mock::AttributeAliasing) { + # this is the DB we are mocking + $attributes->{mock_attribute_aliases} = DBD::Mock::_get_mock_attribute_aliases($dbname); + $attributes->{mock_database_name} = $dbname; + } + my $dbh = DBI::_new_dbh($drh, { + Name => $dbname, + # holds statement parsing coderefs/objects + mock_parser => [], + # holds all statements applied to handle until manually cleared + mock_statement_history => [], + # ability to fake a failed DB connection + mock_can_connect => 1, + # rest of attributes + %{ $attributes }, + }) || return undef; + return $dbh; +} + +sub data_sources { + return ("DBI:Mock:"); +} + +# Necessary to support DBI < 1.34 +# from CPAN RT bug #7057 + +sub disconnect_all { + # no-op +} + +sub DESTROY { undef } + +######################################## +# DATABASE + +package DBD::Mock::db; + +use strict; +use warnings; + +$DBD::Mock::db::imp_data_size = 0; + +sub ping { + my ( $dbh ) = @_; + return $dbh->{mock_can_connect}; +} + +sub prepare { + my($dbh, $statement) = @_; + + eval { + foreach my $parser ( @{ $dbh->{mock_parser} } ) { + if (ref($parser) eq 'CODE') { + $parser->($statement); + } + else { + $parser->parse($statement); + } + } + }; + if ($@) { + my $parser_error = $@; + chomp $parser_error; + DBD::Mock::_error_handler($dbh, "Failed to parse statement. Error: ${parser_error}. Statement: ${statement}"); + return undef; + } + + if (my $session = $dbh->FETCH('mock_session')) { + eval { + $session->verify($dbh, $statement); + }; + if ($@) { + my $session_error = $@; + chomp $session_error; + DBD::Mock::_error_handler($dbh, "Session Error: ${session_error}. Statement: ${statement}"); + return undef; + } + } + + my $sth = DBI::_new_sth($dbh, { Statement => $statement }); + + $dbh->{mock_last_insert_id}++ if ($statement =~ /^\s*?INSERT/); + + $sth->trace_msg("Preparing statement '${statement}'\n", 1); + + my %track_params = (statement => $statement); + + # If we have available resultsets seed the tracker with one + + my $rs; + if ( my $all_rs = $dbh->{mock_rs} ) { + if ( my $by_name = $all_rs->{named}{$statement} ) { + $rs = $by_name; + } + else { + $rs = shift @{$all_rs->{ordered}}; + } + } + + if (ref($rs) eq 'ARRAY' && scalar(@{$rs}) > 0 ) { + my $fields = shift @{$rs}; + $track_params{return_data} = $rs; + $track_params{fields} = $fields; + $sth->STORE(NAME => $fields); + $sth->STORE(NUM_OF_FIELDS => scalar @{$fields}); + } + else { + $sth->trace_msg('No return data set in DBH', 1); + } + + # do not allow a statement handle to be created if there is no + # connection present. + + unless ($dbh->FETCH('Active')) { + DBD::Mock::_error_handler($dbh, "No connection present"); + return undef; + } + + # This history object will track everything done to the statement + + my $history = DBD::Mock::StatementTrack->new(%track_params); + $sth->STORE(mock_my_history => $history); + + # ...now associate the history object with the database handle so + # people can browse the entire history at once, even for + # statements opened and closed in a black box + + my $all_history = $dbh->FETCH('mock_statement_history'); + push @{$all_history}, $history; + + return $sth; +} + +*prepare_cached = \&prepare; + +sub FETCH { + my ( $dbh, $attrib ) = @_; + $dbh->trace_msg( "Fetching DB attrib '$attrib'\n" ); + if ($attrib eq 'AutoCommit') { + return $dbh->{AutoCommit}; + } + elsif ($attrib eq 'Active') { + return $dbh->{mock_can_connect}; + } + elsif ($attrib eq 'mock_all_history') { + return $dbh->{mock_statement_history}; + } + elsif ($attrib eq 'mock_all_history_iterator') { + return DBD::Mock::StatementTrack::Iterator->new($dbh->{mock_statement_history}); + } + elsif ($attrib =~ /^mock/) { + return $dbh->{$attrib}; + } + elsif ($attrib =~ /^(private_|dbi_|dbd_|[A-Z])/ ) { + $dbh->trace_msg("... fetching non-driver attribute ($attrib) that DBI handles\n"); + return $dbh->SUPER::FETCH($attrib); + } + else { + if ($dbh->{mock_attribute_aliases}) { + if (exists ${$dbh->{mock_attribute_aliases}->{db}}{$attrib}) { + my $mock_attrib = $dbh->{mock_attribute_aliases}->{db}->{$attrib}; + if (ref($mock_attrib) eq 'CODE') { + return $mock_attrib->($dbh); + } + else { + return $dbh->FETCH($mock_attrib); + } + } + } + $dbh->trace_msg( "... fetching non-driver attribute ($attrib) that DBI doesn't handle\n"); + return $dbh->{$attrib}; + } +} + +sub STORE { + my ( $dbh, $attrib, $value ) = @_; + $dbh->trace_msg( "Storing DB attribute '$attrib' with '$value'\n" ); + if ($attrib eq 'AutoCommit') { + $dbh->{AutoCommit} = $value; + return $value; + } + elsif ( $attrib eq 'mock_clear_history' ) { + if ( $value ) { + $dbh->{mock_statement_history} = []; + } + return []; + } + elsif ( $attrib eq 'mock_add_parser' ) { + my $parser_type = ref($value); + my $is_valid_parser; + + if ($parser_type eq 'CODE') { + $is_valid_parser++; + } + elsif ($parser_type && $parser_type !~ /^(ARRAY|HASH|SCALAR)$/) { + $is_valid_parser = eval { $parser_type->can( 'parse' ) }; + } + + unless ($is_valid_parser) { + my $error = "Parser must be a code reference or object with 'parse()' " . + "method (Given type: '$parser_type')"; + DBD::Mock::_error_handler($dbh, $error); + return undef; + } + push @{$dbh->{mock_parser}}, $value; + return $value; + } + elsif ( $attrib eq 'mock_add_resultset' ) { + $dbh->{mock_rs} ||= { named => {}, + ordered => [] }; + if ( ref $value eq 'ARRAY' ) { +# print STDERR "mock_add_resultset: " . (join " | " => map { join ", " => @{$_} } @{$value}) . "\n"; + my @copied_values = @{$value}; + push @{$dbh->{mock_rs}{ordered}}, \@copied_values; + return \@copied_values; + } + elsif ( ref $value eq 'HASH' ) { + my $name = $value->{sql}; + unless ($name) { + die "Indexing resultset by name requires passing in 'sql' ", + "as hashref key to 'mock_add_resultset'.\n"; + } + my @copied_values = @{$value->{results}}; + $dbh->{mock_rs}{named}{$name} = \@copied_values; + return \@copied_values; + } + else { + die "Must provide an arrayref or hashref when adding ", + "resultset via 'mock_add_resultset'.\n"; + } + } + elsif ($attrib eq 'mock_start_insert_id') { + # we start at one minus the start id + # so that the increment works + $dbh->{mock_last_insert_id} = $value - 1; + } + elsif ($attrib eq 'mock_session') { + (defined($value) && ref($value) && UNIVERSAL::isa($value, 'DBD::Mock::Session')) + || die "Only DBD::Mock::Session objects can be placed into the 'mock_session' slot\n"; + $dbh->{mock_session} = $value; + } + elsif ($attrib =~ /^mock/) { + return $dbh->{$attrib} = $value; + } + elsif ($attrib =~ /^(private_|dbi_|dbd_|[A-Z])/ ) { + $dbh->trace_msg("... storing non-driver attribute ($attrib) with value ($value) that DBI handles\n"); + return $dbh->SUPER::STORE($attrib, $value); + } + else { + $dbh->trace_msg("... storing non-driver attribute ($attrib) with value ($value) that DBI wont handle\n"); + return $dbh->{$attrib} = $value; + } +} + +sub DESTROY { + undef +} + +######################################## +# STATEMENT + +package DBD::Mock::st; + +use strict; +use warnings; + +$DBD::Mock::st::imp_data_size = 0; + +sub bind_param { + my ($sth, $param_num, $val, $attr) = @_; + my $tracker = $sth->FETCH( 'mock_my_history' ); + $tracker->bound_param( $param_num, $val ); + return 1; +} + +sub execute { + my ($sth, @params) = @_; + + unless ($sth->{Database}->{mock_can_connect}) { + DBD::Mock::_error_handler($sth->{Database}, "No connection present"); + return 0; + } + + my $tracker = $sth->FETCH( 'mock_my_history' ); + if ( @params ) { + $tracker->bound_param_trailing( @params ); + } + $tracker->mark_executed; + my $fields = $tracker->fields; + $sth->STORE( NUM_OF_PARAMS => $tracker->num_params ); + return '0E0'; +} + +sub fetch { + my ($sth) = @_; + + unless ($sth->{Database}->{mock_can_connect}) { + DBD::Mock::_error_handler($sth->{Database}, "No connection present"); + return undef; + } + + my $tracker = $sth->FETCH( 'mock_my_history' ); + return $tracker->next_record; +} + +sub finish { + my ($sth) = @_; + $sth->FETCH( 'mock_my_history' )->is_finished( 'yes' ); +} + +sub rows { + my ($sth) = @_; + $sth->FETCH('mock_num_rows'); +} + +sub FETCH { + my ( $sth, $attrib ) = @_; + $sth->trace_msg( "Fetching ST attribute '$attrib'\n" ); + my $tracker = $sth->{mock_my_history}; + $sth->trace_msg( "Retrieved tracker: " . ref( $tracker ) . "\n" ); + if ( $attrib eq 'NAME' ) { + return $tracker->fields; + } + elsif ( $attrib eq 'NUM_OF_FIELDS' ) { + return $tracker->num_fields; + } + elsif ( $attrib eq 'NUM_OF_PARAMS' ) { + return $tracker->num_params; + } + elsif ( $attrib eq 'TYPE' ) { + my $num_fields = $tracker->num_fields; + return [ map { $DBI::SQL_VARCHAR } ( 0 .. $num_fields ) ]; + } + elsif ( $attrib eq 'Active' ) { + return $tracker->is_active; + } + elsif ( $attrib !~ /^mock/ ) { + if ($sth->{Database}->{mock_attribute_aliases}) { + if (exists ${$sth->{Database}->{mock_attribute_aliases}->{st}}{$attrib}) { + my $mock_attrib = $sth->{Database}->{mock_attribute_aliases}->{st}->{$attrib}; + if (ref($mock_attrib) eq 'CODE') { + return $mock_attrib->($sth); + } + else { + return $sth->FETCH($mock_attrib); + } + } + } + return $sth->SUPER::FETCH( $attrib ); + } + + # now do our stuff... + + if ( $attrib eq 'mock_my_history' ) { + return $tracker; + } + if ( $attrib eq 'mock_statement' ) { + return $tracker->statement; + } + elsif ( $attrib eq 'mock_params' ) { + return $tracker->bound_params; + } + elsif ( $attrib eq 'mock_num_records' || $attrib eq 'mock_num_rows' ) { + return $tracker->num_rows; + } + elsif ( $attrib eq 'mock_current_record_num' ) { + return $tracker->current_record_num; + } + elsif ( $attrib eq 'mock_fields' ) { + return $tracker->fields; + } + elsif ( $attrib eq 'mock_is_executed' ) { + return $tracker->is_executed; + } + elsif ( $attrib eq 'mock_is_finished' ) { + return $tracker->is_finished; + } + elsif ( $attrib eq 'mock_is_depleted' ) { + return $tracker->is_depleted; + } + else { + die "I don't know how to retrieve statement attribute '$attrib'\n"; + } +} + +sub STORE { + my ($sth, $attrib, $value) = @_; + $sth->trace_msg( "Storing ST attribute '$attrib'\n" ); + if ($attrib =~ /^mock/) { + return $sth->{$attrib} = $value; + } + elsif ($attrib eq 'NAME') { + # no-op... + return; + } + else { + $value ||= 0; + return $sth->SUPER::STORE( $attrib, $value ); + } +} + +sub DESTROY { undef } + +########################## +# Database Pooling +# (Apache::DBI emulation) + +package DBD::Mock::Pool; + +use strict; +use warnings; + +my $connection; + +sub connect { + my $class = "DBD::Mock::Pool"; + $class = shift unless ref($_[0]); + my ($driver_handle, $username, $password, $attributes) = @_; + $connection = bless $driver_handle->connect(), "DBD::Mock::Pool::db" unless $connection; + return $connection; +} + +package DBD::Mock::Pool::db; + +use strict; +use warnings; + +our @ISA = qw(DBI::db); + +sub disconnect { 1 } + +######################################## +# TRACKER + +package DBD::Mock::StatementTrack; + +use strict; +use warnings; + +sub new { + my ($class, %params) = @_; + # these params have default values + # but can be overridden + $params{return_data} ||= []; + $params{fields} ||= []; + $params{bound_params} ||= []; + $params{statement} ||= ""; + # these params should never be overridden + # and should always start out in a default + # state to assure the sanity of this class + $params{is_executed} = 'no'; + $params{is_finished} = 'no'; + $params{current_record_num} = 0; + # NOTE: + # changed from \%params here because that + # would bind the hash sent in so that it + # would reflect alterations in the object + # this violates encapsulation + my $self = bless { %params }, $class; + return $self; +} + +sub num_fields { + my ($self) = @_; + return scalar @{$self->{fields}}; +} + +sub num_rows { + my ($self) = @_; + return scalar @{$self->{return_data}}; +} + +sub num_params { + my ($self) = @_; + return scalar @{$self->{bound_params}}; +} + +sub bound_param { + my ($self, $param_num, $value) = @_; + $self->{bound_params}->[$param_num - 1] = $value; + return $self->bound_params; +} + +sub bound_param_trailing { + my ($self, @values) = @_; + push @{$self->{bound_params}}, @values; +} + +# Rely on the DBI's notion of Active: a statement is active if it's +# currently in a SELECT and has more records to fetch + +sub is_active { + my ($self) = @_; + return 0 unless $self->statement =~ /^\s*select/ism; + return 0 unless $self->is_executed eq 'yes'; + return 0 if $self->is_depleted; + return 1; +} + +sub is_finished { + my ($self, $value) = @_; + if (defined $value && $value eq 'yes' ) { + $self->{is_finished} = 'yes'; + $self->current_record_num(0); + $self->{return_data} = []; + } + elsif (defined $value) { + $self->{is_finished} = 'no'; + } + return $self->{is_finished}; +} + +#################### +# RETURN VALUES + +sub mark_executed { + my ($self) = @_; + $self->is_executed('yes'); + $self->current_record_num(0); +} + +sub next_record { + my ($self) = @_; + return undef if $self->is_depleted; + my $rec_num = $self->current_record_num; + my $rec = $self->return_data->[$rec_num]; + $self->current_record_num($rec_num + 1); + return $rec; +} + +sub is_depleted { + my ($self) = @_; + return ($self->current_record_num >= scalar @{$self->return_data}); +} + +# DEBUGGING AID + +sub to_string { + my ($self) = @_; + return join "\n" => ( + $self->{statement}, + "Values: [" . join( '] [', @{ $self->{bound_params} } ) . "]", + "Records: on $self->{current_record_num} of " . scalar(@{$self->return_data}) . "\n", + "Executed? $self->{is_executed}; Finished? $self->{is_finished}" + ); +} + +# PROPERTIES + +# boolean + +sub is_executed { + my ($self, $yes_no) = @_; + $self->{is_executed} = $yes_no if defined $yes_no; + return ($self->{is_executed} eq 'yes') ? 'yes' : 'no'; +} + +# single-element fields + +sub statement { + my ($self, $value) = @_; + $self->{statement} = $value if defined $value; + return $self->{statement}; +} + +sub current_record_num { + my ($self, $value) = @_; + $self->{current_record_num} = $value if defined $value; + return $self->{current_record_num}; +} + +# multi-element fields + +sub return_data { + my ($self, @values) = @_; + push @{$self->{return_data}}, @values if scalar @values; + return $self->{return_data}; +} + +sub fields { + my ($self, @values) = @_; + push @{$self->{fields}}, @values if scalar @values; + return $self->{fields}; +} + +sub bound_params { + my ($self, @values) = @_; + push @{$self->{bound_params}}, @values if scalar @values; + return $self->{bound_params}; +} + +package DBD::Mock::StatementTrack::Iterator; + +use strict; +use warnings; + +sub new { + my ($class, $history) = @_; + return bless { + pointer => 0, + history => $history || [] + } => $class; +} + +sub next { + my ($self) = @_; + return unless $self->{pointer} < scalar(@{$self->{history}}); + return $self->{history}->[$self->{pointer}++]; +} + +sub reset { (shift)->{pointer} = 0 } + +package DBD::Mock::Session; + +use strict; +use warnings; + +my $INSTANCE_COUNT = 1; + +sub new { + my $class = shift; + (@_) || die "You must specify at least one session state"; + my $session_name; + if (ref($_[0])) { + $session_name = 'Session ' . $INSTANCE_COUNT; + } + else { + $session_name = shift; + } + my @session_states = @_; + (@session_states) + || die "You must specify at least one session state"; + (ref($_) eq 'HASH') + || die "You must specify session states as HASH refs" + foreach @session_states; + $INSTANCE_COUNT++; + return bless { + name => $session_name, + states => \@session_states, + state_index => 0 + } => $class; +} + +sub name { (shift)->{name} } + +sub verify { + my ($self, $dbh, $statement) = @_; + my $current_state = $self->{states}->[$self->{state_index}]; + # make sure our state is good + (exists ${$current_state}{statement} && exists ${$current_state}{results}) + || die "Bad state '" . $self->{state_index} . "' in DBD::Mock::Session (" . $self->{name} . ")"; + # try the SQL + my $SQL = $current_state->{statement}; +# print STDERR "Testing statement:\n\tgot: $statement\n\texpected: $SQL\n"; + unless (ref($SQL)) { + ($SQL eq $statement) + || die "Statement does not match current state in DBD::Mock::Session (" . $self->{name} . ")"; + } + elsif (ref($SQL) eq 'Regexp') { + ($statement =~ /$SQL/) + || die "Statement does not match current state in DBD::Mock::Session (" . $self->{name} . ")"; + } + elsif (ref($SQL) eq 'CODE') { + ($SQL->($statement, $current_state)) + || die "Statement does not match current state in DBD::Mock::Session (" . $self->{name} . ")"; + } + else { + die "Bad 'statement' value '$SQL' in current state in DBD::Mock::Session (" . $self->{name} . ")"; + } + # if we are hear then things worked out well :) +# print STDERR "Adding Results: " . (join " | " => map { join ", " => @{$_} } @{$current_state->{results}}) . "\n"; + $dbh->STORE('mock_add_resultset' => $current_state->{results}); + # now we can get ready + # for the next statement + $self->{state_index}++; +} + +1; + +__END__ + +=head1 NAME + +DBD::Mock - Mock database driver for testing + +=head1 SYNOPSIS + + use DBI; + + # connect to your as normal, using 'Mock' as your driver name + my $dbh = DBI->connect( 'DBI:Mock:', '', '' ) + || die "Cannot create handle: $DBI::errstr\n"; + + # create a statement handle as normal and execute with parameters + my $sth = $dbh->prepare( 'SELECT this, that FROM foo WHERE id = ?' ); + $sth->execute( 15 ); + + # Now query the statement handle as to what has been done with it + my $mock_params = $sth->{mock_params}; + print "Used statement: ", $sth->{mock_statement}, "\n", + "Bound parameters: ", join( ', ', @{ $params } ), "\n"; + +=head1 DESCRIPTION + +Testing with databases can be tricky. If you are developing a system married to a single database then you can make some assumptions about your environment and ask the user to provide relevant connection information. But if you need to test a framework that uses DBI, particularly a framework that uses different types of persistence schemes, then it may be more useful to simply verify what the framework is trying to do -- ensure the right SQL is generated and that the correct parameters are bound. C makes it easy to just modify your configuration (presumably held outside your code) and just use it instead of C (like L or L) in your framework. + +There is no distinct area where using this module makes sense. (Some people may successfully argue that this is a solution looking for a problem...) Indeed, if you can assume your users have something like L or L or if you do not mind creating a dependency on them then it makes far more sense to use these legitimate driver implementations and test your application in the real world -- at least as much of the real world as you can create in your tests... + +And if your database handle exists as a package variable or something else easily replaced at test-time then it may make more sense to use L to create a fully dynamic handle. There is an excellent article by chromatic about using L in this and other ways, strongly recommended. (See L for a link) + +=head2 How does it work? + +C comprises a set of classes used by DBI to implement a database driver. But instead of connecting to a datasource and manipulating data found there it tracks all the calls made to the database handle and any created statement handles. You can then inspect them to ensure what you wanted to happen actually happened. For instance, say you have a configuration file with your database connection information: + + [DBI] + dsn = DBI:Pg:dbname=myapp + user = foo + password = bar + +And this file is read in at process startup and the handle stored for other procedures to use: + + package ObjectDirectory; + + my ( $DBH ); + + sub run_at_startup { + my ( $class, $config ) = @_; + $config ||= read_configuration( ... ); + my $dsn = $config->{DBI}{dsn}; + my $user = $config->{DBI}{user}; + my $pass = $config->{DBI}{password}; + $DBH = DBI->connect( $dsn, $user, $pass ) || die ...; + } + + sub get_database_handle { + return $DBH; + } + +A procedure might use it like this (ignoring any error handling for the moment): + + package My::UserActions; + + sub fetch_user { + my ( $class, $login ) = @_; + my $dbh = ObjectDirectory->get_database_handle; + my $sql = q{ + SELECT login_name, first_name, last_name, creation_date, num_logins + FROM users + WHERE login_name = ? + }; + my $sth = $dbh->prepare( $sql ); + $sth->execute( $login ); + my $row = $sth->fetchrow_arrayref; + return ( $row ) ? User->new( $row ) : undef; + } + +So for the purposes of our tests we just want to ensure that: + +=over 4 + +=item 1. The right SQL is being executed + +=item 2. The right parameters are bound + +=back + +Assume whether the SQL actually B or not is irrelevant for this test :-) + +To do that our test might look like: + + my $config = ObjectDirectory->read_configuration( ... ); + $config->{DBI}{dsn} = 'DBI:Mock:'; + ObjectDirectory->run_at_startup( $config ); + + my $login_name = 'foobar'; + my $user = My::UserActions->fetch_user( $login_name ); + + # Get the handle from ObjectDirectory; + # this is the same handle used in the + # 'fetch_user()' procedure above + my $dbh = ObjectDirectory->get_database_handle(); + + # Ask the database handle for the history + # of all statements executed against it + my $history = $dbh->{mock_all_history}; + + # Now query that history record to + # see if our expectations match reality + cmp_ok(scalar(@{$history}), '==', 1, 'Correct number of statements executed' ; + + my $login_st = $history->[0]; + like($login_st->statement, + qr/SELECT login_name.*FROM users WHERE login_name = ?/sm, + 'Correct statement generated' ); + + my $params = $login_st->bound_params; + cmp_ok(scalar(@{$params}), '==', 1, 'Correct number of parameters bound'); + is($params->[0], $login_name, 'Correct value for parameter 1' ); + + # Reset the handle for future operations + $dbh->{mock_clear_history} = 1; + +The list of properties and what they return is listed below. But in an overall view: + +=over 4 + +=item * + +A database handle contains the history of all statements created against it. Other properties set for the handle (e.g., 'PrintError', 'RaiseError') are left alone and can be queried as normal, but they do not affect anything. (A future feature may track the sequence/history of these assignments but if there is no demand it probably will not get implemented.) + +=item * + +A statement handle contains the statement it was prepared with plus all bound parameters or parameters passed via C. It can also contain predefined results for the statement handle to 'fetch', track how many fetches were called and what its current record is. + +=back + +=head2 A Word of Warning + +This may be an incredibly naive implementation of a DBD. But it works for me ... + +=head1 DBD::Mock + +Since this is a normal DBI statement handle we need to expose our tracking information as properties (accessed like a hash) rather than methods. + +=head2 Database Handle Properties + +=over 4 + +=item B + +Returns an array reference with all history (a.k.a. C) objects created against the database handle in the order they were created. Each history object can then report information about the SQL statement used to create it, the bound parameters, etc.. + +=item B + +Returns a C object which will iterate through the current set of C object in the history. See the B documentation below for more information. + +=item B + +If set to a true value all previous statement history operations will be erased. This B the history of currently open handles, so if you do something like: + + my $dbh = get_handle( ... ); + my $sth = $dbh->prepare( ... ); + $dbh->{mock_clear_history} = 1; + $sth->execute( 'Foo' ); + +You will have no way to learn from the database handle that the statement parameter 'Foo' was bound. + +This is useful mainly to ensure you can isolate the statement histories from each other. A typical sequence will look like: + + set handle to framework + perform operations + analyze mock database handle + reset mock database handle history + perform more operations + analyze mock database handle + reset mock database handle history + ... + +=item B + +This statement allows you to simulate a downed database connection. This is useful in testing how your application/tests will perform in the face of some kind of catastrophic event such as a network outage or database server failure. It is a simple boolean value which defaults to on, and can be set like this: + + # turn the database off + $dbh->{mock_can_connect} = 0; + + # turn it back on again + $dbh->{mock_can_connect} = 1; + +The statement handle checks this value as well, so something like this +will fail in the expected way: + + $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + $dbh->{mock_can_connect} = 0; + + # blows up! + my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); + if ( $@ ) { + # Here, $DBI::errstr = 'No connection present' + } + +Turning off the database after a statement prepare will fail on the statement C, which is hopefully what you would expect: + + $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + + # ok! + my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); + $dbh->{mock_can_connect} = 0; + + # blows up! + $sth->execute; + +Similarly: + + $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + + # ok! + my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); + + # ok! + $sth->execute; + + $dbh->{mock_can_connect} = 0; + + # blows up! + my $row = $sth->fetchrow_arrayref; + +Note: The handle attribute C and the handle method C will behave according to the value of C. So if C were to be set to 0 (or off), then both C and C would return false values (or 0). + +=item B + +This stocks the database handle with a record set, allowing you to seed data for your application to see if it works properly.. Each recordset is a simple arrayref of arrays with the first arrayref being the fieldnames used. Every time a statement handle is created it asks the database handle if it has any resultsets available and if so uses it. + +Here is a sample usage, partially from the test suite: + + my @user_results = ( + [ 'login', 'first_name', 'last_name' ], + [ 'cwinters', 'Chris', 'Winters' ], + [ 'bflay', 'Bobby', 'Flay' ], + [ 'alincoln', 'Abe', 'Lincoln' ], + ); + my @generic_results = ( + [ 'foo', 'bar' ], + [ 'this_one', 'that_one' ], + [ 'this_two', 'that_two' ], + ); + + my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + $dbh->{mock_add_resultset} = \@user_results; # add first resultset + $dbh->{mock_add_resultset} = \@generic_results; # add second resultset + my ( $sth ); + eval { + $sth = $dbh->prepare( 'SELECT login, first_name, last_name FROM foo' ); + $sth->execute(); + }; + + # this will fetch rows from the first resultset... + my $row1 = $sth->fetchrow_arrayref; + my $user1 = User->new( login => $row->[0], + first => $row->[1], + last => $row->[2] ); + is( $user1->full_name, 'Chris Winters' ); + + my $row2 = $sth->fetchrow_arrayref; + my $user2 = User->new( login => $row->[0], + first => $row->[1], + last => $row->[2] ); + is( $user2->full_name, 'Bobby Flay' ); + ... + + my $sth_generic = $dbh->prepare( 'SELECT foo, bar FROM baz' ); + $sth_generic->execute; + + # this will fetch rows from the second resultset... + my $row = $sth->fetchrow_arrayref; + +You can also associate a resultset with a particular SQL statement instead of adding them in the order they will be fetched: + + $dbh->{mock_add_resultset} = { + sql => 'SELECT foo, bar FROM baz', + results => [ + [ 'foo', 'bar' ], + [ 'this_one', 'that_one' ], + [ 'this_two', 'that_two' ], + ], + }; + +This will return the given results when the statement 'SELECT foo, bar FROM baz' is prepared. Note that they will be returned B the statement is prepared, not just the first. (This behavior could change.) + +It should also be noted that the C method will return the number of records stocked in the result set. So if your code/application makes use of the C<$sth-Erows> method for things like UPDATE and DELETE calls you should stock the result set like so: + + $dbh->{mock_add_resultset} = { + sql => 'UPDATE foo SET baz = 1, bar = 2', + # this will appear to have updated 3 rows + results => [[ 'rows' ], [], [], []], + }; + + # or ... + + $dbh->{mock_add_resultset} = { + sql => 'DELETE FROM foo WHERE bar = 2', + # this will appear to have deleted 1 row + results => [[ 'rows' ], []], + }; + +Now I admit this is not the most elegant way to go about this, but it works for me for now, and until I can come up with a better method, or someone sends me a patch ;) it will do for now. + +=item B + +This attribute can be used to set a current DBD::Mock::Session object. For more information on this, see the L docs below. + +=item B + +This attribute is incremented each time an INSERT statement is passed to prepare on a per-handle basis. It's starting value can be set with the 'mock_start_insert_id' attribute (see below). + +=item B + +This attribute can be used to set a start value for the 'mock_last_insert_id' attribute. It can also be used to effectively reset the 'mock_last_insert_id' attribute as well. + +=item B + +DBI provides some simple parsing capabilities for 'SELECT' statements to ensure that placeholders are bound properly. And typically you may simply want to check after the fact that a statement is syntactically correct, or at least what you expect. + +But other times you may want to parse the statement as it is prepared rather than after the fact. There is a hook in this mock database driver for you to provide your own parsing routine or object. + +The syntax is simple: + + $dbh->{mock_add_parser} = sub { + my ( $sql ) = @_; + unless ( $sql =~ /some regex/ ) { + die "does not contain secret fieldname"; + } + }; + +You can also add more than one for a handle. They will be called in order, and the first one to fail will halt the parsing process: + + $dbh->{mock_add_parser} = \&parse_update_sql; + $dbh->{mock_add-parser} = \&parse_insert_sql; + +Depending on the 'PrintError' and 'RaiseError' settings in the database handle any parsing errors encountered will issue a C or C. No matter what the statement handle will be C. + +Instead of providing a subroutine reference you can use an object. The only requirement is that it implements the method C and takes a SQL statement as the only argument. So you should be able to do something like the following (untested): + + my $parser = SQL::Parser->new( 'mysql', { RaiseError => 1 } ); + $dbh->{mock_add_parser} = $parser; + +=back + +=head2 Statement Handle Properties + +=over 4 + +=item B + +Returns true if the handle is a 'SELECT' and has more records to fetch, false otherwise. (From the DBI.) + +=item B + +The SQL statement this statement handle was Cd with. So if the handle were created with: + + my $sth = $dbh->prepare( 'SELECT * FROM foo' ); + +This would return: + + SELECT * FROM foo + +The original statement is unmodified so if you are checking against it in tests you may want to use a regex rather than a straight equality check. (However if you use a phrasebook to store your SQL externally you are a step ahead...) + +=item B + +Fields used by the statement. As said elsewhere we do no analysis or parsing to find these, you need to define them beforehand. That said, you do not actually need this very often. + +Note that this returns the same thing as the normal statement property 'FIELD'. + +=item B + +Returns an arrayref of parameters bound to this statement in the order specified by the bind type. For instance, if you created and stocked a handle with: + + my $sth = $dbh->prepare( 'SELECT * FROM foo WHERE id = ? AND is_active = ?' ); + $sth->bind_param( 2, 'yes' ); + $sth->bind_param( 1, 7783 ); + +This would return: + + [ 7738, 'yes' ] + +The same result will occur if you pass the parameters via C instead: + + my $sth = $dbh->prepare( 'SELECT * FROM foo WHERE id = ? AND is_active = ?' ); + $sth->execute( 7783, 'yes' ); + +=item B + +An arrayref of arrayrefs representing the records the mock statement was stocked with. + +=item B + +Number of records the mock statement was stocked with; if never stocked it is still 0. (Some weirdos might expect undef...) + +=item B + +This returns the same value as I. And is what is returned by the C method of the statement handle. + +=item B + +Current record the statement is on; returns 0 in the instances when you have not yet called C and if you have not yet called a C method after the execute. + +=item B + +Whether C has been called against the statement handle. Returns 'yes' if so, 'no' if not. + +=item B + +Whether C has been called against the statement handle. Returns 'yes' if so, 'no' if not. + +=item B + +Returns 'yes' if all the records in the recordset have been returned. If no C was executed against the statement, or If no return data was set this will return 'no'. + +=item B + +Returns a C object which tracks the actions performed by this statement handle. Most of the actions are separately available from the properties listed above, so you should never need this. + +=back + +=head1 DBD::Mock::Pool + +This module can be used to emulate Apache::DBI style DBI connection +pooling. Just as with Apache::DBI, you must enable DBD::Mock::Pool +before loading DBI. + + use DBD::Mock qw(Pool); + # followed by ... + use DBI; + +While this may not seem to make a lot of sense in a single-process testing +scenario, it can be useful when testing code which assumes a multi-process +Apache::DBI pooled environment. + +=head1 DBD::Mock::StatementTrack + +Under the hood this module does most of the work with a +C object. This is most useful when you are +reviewing multiple statements at a time, otherwise you might want to +use the C statement handle attributes instead. + +=over 4 + +=item B + +Takes the following parameters: + +=over 4 + +=item * + +B: Arrayref of return data records + +=item * + +B: Arrayref of field names + +=item * + +B: Arrayref of bound parameters + +=back + +=item B (Statement attribute 'mock_statement') + +Gets/sets the SQL statement used. + +=item B (Statement attribute 'mock_fields') + +Gets/sets the fields to use for this statement. + +=item B (Statement attribute 'mock_params') + +Gets/set the bound parameters to use for this statement. + +=item B (Statement attribute 'mock_records') + +Gets/sets the data to return when asked (that is, when someone calls 'fetch' on the statement handle). + +=item B (Statement attribute 'mock_current_record_num') + +Gets/sets the current record number. + +=item B (Statement attribute 'Active') + +Returns true if the statement is a SELECT and has more records to fetch, false otherwise. (This is from the DBI, see the 'Active' docs under 'ATTRIBUTES COMMON TO ALL HANDLES'.) + +=item B (Statement attribute 'mock_is_executed') + +Sets the state of the tracker 'executed' flag. + +=item B (Statement attribute 'mock_is_finished') + +If set to 'yes' tells the tracker that the statement is finished. This resets the current record number to '0' and clears out the array ref of returned records. + +=item B (Statement attribute 'mock_is_depleted') + +Returns true if the current record number is greater than the number of records set to return. + +=item B + +Returns the number of fields set in the 'fields' parameter. + +=item B + +Returns the number of records in the current result set. + +=item B + +Returns the number of parameters set in the 'bound_params' parameter. + +=item B + +Sets bound parameter C<$param_num> to C<$value>. Returns the arrayref of currently-set bound parameters. This corresponds to the 'bind_param' statement handle call. + +=item B + +Pushes C<@params> onto the list of already-set bound parameters. + +=item B + +Tells the tracker that the statement has been executed and resets the current record number to '0'. + +=item B + +If the statement has been depleted (all records returned) returns undef; otherwise it gets the current recordfor returning, increments the current record number and returns the current record. + +=item B + +Tries to give an decent depiction of the object state for use in debugging. + +=back + +=head1 DBD::Mock::StatementTrack::Iterator + +This object can be used to iterate through the current set of C objects in the history by fetching the 'mock_all_history_iterator' attribute from a database handle. This object is very simple and is meant to be a convience to make writing long test script easier. Aside from the constructor (C) this object has only one method. + +=over 4 + +B + +Calling C will return the next C object in the history. If there are no more C objects available, then this method will return undef. + +B + +This will reset the internal pointer to the begining of the statement history. + +=back + +=head1 DBD::Mock::Session + +The DBD::Mock::Session object is an alternate means of specifying the SQL statements and result sets for DBD::Mock. The idea is that you can specify a complete 'session' of usage, which will be verified through DBD::Mock. Here is an example: + + my $session = DBD::Mock::Session->new('my_session' => ( + { + statement => "SELECT foo FROM bar", # as a string + results => [[ 'foo' ], [ 'baz' ]] + }, + { + statement => qr/UPDATE bar SET foo \= \'bar\'/, # as a reg-exp + results => [[]] + }, + { + statement => sub { # as a CODE ref + my ($SQL, $state) = @_; + return $SQL eq "SELECT foo FROM bar"; + }, + results => [[ 'foo' ], [ 'bar' ]] + } + )); + +As you can see, a session is essentially made up a list of HASH references we call 'states'. Each state has a 'statement' and a set of 'results'. If DBD::Mock finds a session in the 'mock_session' attribute, then it will pass the current C<$dbh> and SQL statement to that DBD::Mock::Session. The SQL statement will be checked against the 'statement' field in the current state. If it passes, then the 'results' of the current state will get feed to DBD::Mock through the 'mock_add_resultset' attribute. We then advance to the next state in the session, and wait for the next call through DBD::Mock. If at any time the SQL statement does not match the current state's 'statement', an error will be raised (and propagated through the normal DBI error handling based on your values for RaiseError and PrintError). + +As can also be seen in the example above, 'statement' fields can come in many forms. The simplest is a string, which will be compared using C against the currently running statement. The next is a reg-exp reference, this too will get compared against the currently running statement. The last option is a CODE ref, this is sort of a catch-all to allow for a wide range of SQL comparison approaches (including using modules like SQL::Statement or SQL::Parser for detailed functional comparisons). The first argument to the CODE ref will be the currently active SQL statement to compare against, the second argument is a reference to the current state HASH (in case you need to alter the results, or store extra information). The CODE is evaluated in boolean context and throws and exception if it is false. + +=over 4 + +B + +A C<$session_name> can be optionally be specified, along with at least one C<@session_states>. If you don't specify a C<$session_name>, then a default one will be created for you. The C<@session_states> must all be HASH references as well, if this conditions fail, an exception will be thrown. + +B + +This will check the C<$SQL> against the current state's 'statement' value, and if it passes will add the current state's 'results' to the C<$dbh>. If for some reason the 'statement' value is bad, not of the prescribed type, an exception is thrown. See above for more details. + +=back + +=head1 EXPERIMENTAL FUNCTIONALITY + +All functionality listed here is highly experimental and should be used with great caution (if at all). + +=over 4 + +=item Attribute Aliasing + +Basically this feature allows you to alias attributes to other attributes. So for instance, you can alias a commonly expected attribute like 'mysql_insertid' to something DBD::Mock already has like 'mock_last_insert_id'. While you can also just set 'mysql_insertid' yourself, this functionality allows it to take advantage of things like the autoincrementing of the 'mock_last_insert_id' attribute. + +Right now this feature is highly experimental, and has been added as a first attempt to automatically handle some of the DBD specific attributes which are commonly used/accessed in DBI programming. The functionality is off by default so as to not cause any issues with backwards compatability, but can easily be turned on and off like this: + + # turn it on + $DBD::Mock::AttributeAliasing++; + + # turn it off + $DBD::Mock::AttributeAliasing = 0; + +Once this is turned on, you will need to choose a database specific attribute aliasing table like so: + + DBI->connect('dbi:Mock:MySQL', '', ''); + +The 'MySQL' in the DSN will be picked up and the MySQL specific attribute aliasing will be used. + +Right now only MySQL is supported by this feature, and even that support is very minimal. Currently the MySQL C<$dbh> and C<$sth> attributes 'mysql_insertid' are aliased to the C<$dbh> attribute 'mock_last_insert_id'. It is possible to add more aliases though, using the C function (see the source code for details). + +=back + +=head1 BUGS + +=over + +=item Odd $dbh attribute behavior + +When writing the test suite I encountered some odd behavior with some C<$dbh> attributes. I still need to get deeper into how DBD's work to understand what it is that is actually doing wrong. + +=back + +=head1 TO DO + +=over + +=item Make DBD specific handlers + +Each DBD has its own quirks and issues, it would be nice to be able to handle those issues with DBD::Mock in some way. I have an number of ideas already, but little time to sit down and really flesh them out. If you have any suggestions or thoughts, feel free to email me with them. + +=item Enhance the DBD::Mock::StatementTrack object + +I would like to have the DBD::Mock::StatementTrack object handle more of the mock_* attributes. This would encapsulate much of the mock_* behavior in one place, which would be a good thing. + +I would also like to add the ability to bind a subroutine (or possibly an object) to the result set, so that the results can be somewhat more dynamic and allow for a more realistic interaction. + +=back + +=head1 CODE COVERAGE + +I use L to test the code coverage of my tests, below is the L report on this module test suite. + + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + File stmt branch cond sub pod time total + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + DBD/Mock.pm 89.3 83.9 82.6 93.9 0.0 100.0 87.6 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + Total 89.3 83.9 82.6 93.9 0.0 100.0 87.6 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + +=head1 SEE ALSO + +L + +L, which provided a good starting point + +L, which provided the approach + +Test::MockObject article - L + +=head1 COPYRIGHT + +Copyright (c) 2004 Stevan Little, Chris Winters. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHORS + +Chris Winters Echris@cwinters.comE + +Stevan Little Estevan@iinteractive.comE diff --git a/t/00_basic.t b/t/00_basic.t new file mode 100644 index 0000000..c202de4 --- /dev/null +++ b/t/00_basic.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok( 'DBD::Mock' ); +} diff --git a/t/10_db_handle.t b/t/10_db_handle.t new file mode 100644 index 0000000..68d7b6c --- /dev/null +++ b/t/10_db_handle.t @@ -0,0 +1,93 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 22; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +# test misc. attributes + +{ + my $dbh = DBI->connect('DBI:Mock:', 'user', 'pass'); + isa_ok($dbh, 'DBI::db'); + + is($dbh->{Name}, '', '... if no db-name is given'); + + # DBI will handle attributes with 'private_', 'dbi_' or , + # 'dbd_' prefixes but all others, we need to handle. + + $dbh->{mysql_insertid} = 10; + cmp_ok($dbh->{mysql_insertid}, '==', 10, '... this attribute should be 10'); + + # DBI will handle these + + $dbh->{private_insert_id} = 15; + cmp_ok($dbh->{private_insert_id}, '==', 15, '... this attribute should be 15'); + + $dbh->{dbi_attribute} = 2000; + cmp_ok($dbh->{dbi_attribute}, '==', 2000, '... this attribute should be 2000'); + + $dbh->{dbd_attr} = 15_000; + cmp_ok($dbh->{dbd_attr}, '==', 15_000, '... this attribute should be 15,000'); + + $dbh->disconnect(); +} + +# test setting attributes post-connect + +{ + my $trace_log = 'tmp_dbi_trace.log'; + + my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 1; + $dbh->{AutoCommit} = 1; + $dbh->trace( 2, $trace_log ); + ok(-f $trace_log, '... the trace log file has been created'); + cmp_ok( $dbh->{RaiseError}, '==', 1, + 'RaiseError DB attribute set after connect()' ); + cmp_ok( $dbh->{PrintError}, '==', 1, + 'PrintError DB attribute set after connect()' ); + cmp_ok( $dbh->{AutoCommit}, '==', 1, + 'AutoCommit DB attribute set after connect()' ); + cmp_ok( $dbh->{TraceLevel}, '==', 2, + 'TraceLevel DB attribute set after connect()' ); + + cmp_ok(unlink($trace_log), '==', 1, "... removing the trace log file" ); + ok(!-e $trace_log, "... the trace log file is actually gone" ); + + $dbh->disconnect(); +} + +# test setting them during connect + +{ + my $trace_log = 'tmp_dbi_trace.log'; + + open STDERR, "> $trace_log"; + ok(-f $trace_log, '... the trace log file has been created'); + my $dbh = DBI->connect( 'DBI:Mock:', '', '', + { RaiseError => 1, + PrintError => 1, + AutoCommit => 1, + TraceLevel => 2 } ); + cmp_ok( $dbh->{RaiseError}, '==', 1, + 'RaiseError DB attribute set in connect()' ); + cmp_ok( $dbh->{PrintError}, '==', 1, + 'PrintError DB attribute set in connect()' ); + cmp_ok( $dbh->{AutoCommit}, '==', 1, + 'AutoCommit DB attribute set in connect()' ); + cmp_ok( $dbh->{TraceLevel}, '==', 2, + 'TraceLevel DB attribute set in connect()' ); + + close STDERR; + cmp_ok(unlink($trace_log), '==', 1, "... removing the trace log file" ); + ok(!-e $trace_log, "... the trace log file is actually gone" ); + + $dbh->disconnect(); +} \ No newline at end of file diff --git a/t/11_dr_handle.t b/t/11_dr_handle.t new file mode 100644 index 0000000..2801672 --- /dev/null +++ b/t/11_dr_handle.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +my $drh = DBI->install_driver("Mock"); +isa_ok($drh, 'DBI::dr'); + +# make sure we always get the same one back +{ + my $drh2 = DBI->install_driver("Mock"); + isa_ok($drh2, 'DBI::dr'); + + is($drh, $drh2, '... got the same driver'); +} + +is($drh->data_sources(), 'DBI:Mock:', '... got the expected data sources'); + +my $dbh = $drh->connect(); +isa_ok($dbh, 'DBI::db'); + +is($dbh->{Driver}, $drh, '... our driver is as we expect'); + +$dbh->disconnect(); diff --git a/t/12_db_can_connect.t b/t/12_db_can_connect.t new file mode 100644 index 0000000..f736b92 --- /dev/null +++ b/t/12_db_can_connect.t @@ -0,0 +1,82 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 23; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +# test this as an exception +{ + my $dbh = DBI->connect('DBI:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); + isa_ok($dbh, "DBI::db"); + # check to be sure this is set, otherwise + # the test wont be set up right + cmp_ok($dbh->{RaiseError}, '==', 1, '... make sure RaiseError is set correctly'); + + # check to see it is active in the first place + ok($dbh->{Active}, '...our handle with the default settting is Active' ); + ok($dbh->ping(), '...and successfuly pinged handle' ); + + $dbh->{mock_can_connect} = 0; + + # check our value is correctly set + cmp_ok($dbh->{mock_can_connect}, '==', 0, '... can connect is set to 0'); + + # and check the side effects of that + ok(!$dbh->{Active}, '...our handle is no longer Active after setting mock_can_connect'); + ok(!$dbh->ping(), '...and unsuccessfuly pinged handle (good)'); + + my $sth = eval { $dbh->prepare( "SELECT foo FROM bar" ) }; + ok($@, '... we should have an exception'); + + like($@, + qr/^No connection present/, + 'Preparing statement against inactive handle throws expected exception' ); + + like($dbh->errstr, + qr/^No connection present/, + 'Preparing statement against inactive handle sets expected DBI error' ); + + $dbh->disconnect(); +} + +# and now test this as a warning +{ + + my $dbh = DBI->connect('DBI:Mock:', '', '', { PrintError => 1 }); + isa_ok($dbh, "DBI::db"); + # check to be sure this is set, otherwise + # the test wont be set up right + cmp_ok($dbh->{PrintError}, '==', 1, '... make sure PrintError is set correctly'); + + # check to see it is active in the first place + ok($dbh->{Active}, '...our handle with the default settting is Active' ); + ok($dbh->ping(), '...and successfuly pinged handle' ); + + $dbh->{mock_can_connect} = 0; + + # check our value is correctly set + cmp_ok($dbh->{mock_can_connect}, '==', 0, '... can connect is set to 0'); + + # and check the side effects of that + ok(!$dbh->{Active}, '...our handle is no longer Active after setting mock_can_connect'); + ok(!$dbh->ping(), '...and unsuccessfuly pinged handle (good)'); + + { # isolate the warn handler + $SIG{__WARN__} = sub { + my $msg = shift; + like($msg, qr/No connection present/, '...got the expected warning'); + }; + + my $sth = eval { $dbh->prepare( "SELECT foo FROM bar" ) }; + ok(!$@, '... we should not have an exception'); + ok(!defined($sth), '... and our statement should be undefined'); + } + + $dbh->disconnect(); +} diff --git a/t/13_misc_mock_attr.t b/t/13_misc_mock_attr.t new file mode 100644 index 0000000..f7fc553 --- /dev/null +++ b/t/13_misc_mock_attr.t @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 26; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +# test misc. attributes of $dbh + +my $dbh = DBI->connect('DBI:Mock:', '', ''); +isa_ok($dbh, 'DBI::db'); + +$dbh->{AutoCommit} = 1; +cmp_ok($dbh->{AutoCommit}, '==', 1, '... it handles AutoCommit as well'); + +$dbh->{AutoCommit} = 0; +cmp_ok($dbh->{AutoCommit}, '==', 0, '... and turns off AutoCommit as well'); + +for (0 .. 5) { + my $sth = $dbh->prepare('SELECT * FROM foo'); + $sth->execute(); +} + +cmp_ok(scalar(@{$dbh->{mock_all_history}}), '==', 6, '... we have 6 statements'); + +$dbh->{mock_clear_history} = 1; + +cmp_ok(scalar(@{$dbh->{mock_all_history}}), '==', 0, '... we have 0 statements'); + +# test the misc. attributes of $sth + +$dbh->{mock_add_resultset} = [['foo'], [1], [2], [3]]; + +my $SQL = 'SELECT foo FROM bar WHERE baz = ?'; + +# prepare a statement +my $sth = $dbh->prepare($SQL); + +# mock_is_executed +is($sth->{mock_is_executed}, 'no', '... not executed yet'); + +# execute and bind the param +$sth->execute('test'); + +is($sth->{mock_is_executed}, 'yes', '... has been executed now'); + +# mock_my_history +my $history = $sth->{mock_my_history}; +ok($history, '... got something back for our history'); +isa_ok($history, 'DBD::Mock::StatementTrack'); + +# mock_statement +is($sth->{mock_statement}, $SQL, '... our statement is as expected'); + +# mock_fields +is_deeply( + $sth->{mock_fields}, + [ 'foo' ], + '... our fields is as expected'); + +# mock_num_records +cmp_ok($sth->{mock_num_records}, '==', 3, '... we have 3 records'); + +# mock_current_record_num +cmp_ok($sth->{mock_current_record_num}, '==', 0, '... we are at record number 0'); + +# mock_is_finished +is($sth->{mock_is_finished}, 'no', '... we are not yet finished'); + +# mock_is_depleted +ok(!$sth->{mock_is_depleted}, '... nor are we depleted'); + +for (1 .. 3) { + cmp_ok($sth->fetchrow_array(), '==', $_, '... got the expected row'); + cmp_ok($sth->{mock_current_record_num}, '==', $_, '... we are at record number ' . $_); +} + +# mock_is_depleted +ok($sth->{mock_is_depleted}, '... now we are depleted'); + +# mock_is_finished +is($sth->{mock_is_finished}, 'no', '... we are not yet finished'); + +$sth->finish(); + +# mock_is_finished +is($sth->{mock_is_finished}, 'yes', '... and we are now finished'); diff --git a/t/14_db_parser.t b/t/14_db_parser.t new file mode 100644 index 0000000..6dd1e8d --- /dev/null +++ b/t/14_db_parser.t @@ -0,0 +1,139 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 29; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +{ + my $dbh = DBI->connect('DBI:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); + isa_ok($dbh, "DBI::db"); + # check to be sure this is set, otherwise + # the test wont be set up right + cmp_ok($dbh->{RaiseError}, '==', 1, '... make sure RaiseError is set correctly'); + + # check parse sub-refs + + my $parser = sub { + my ($sql) = @_; + die "incorrect use of '*'\n" if $sql =~ /^SELECT \*/; + }; + + eval { + $dbh->{mock_add_parser} = $parser; + }; + ok(!$@, '... parser successfully added to dbh'); + + is($dbh->{mock_parser}->[0], $parser, '... the same parser is stored'); + + my $sth1 = eval { $dbh->prepare('SELECT myfield FROM mytable') }; + isa_ok($sth1, "DBI::st"); + + my $sth2 = eval { $dbh->prepare( 'SELECT * FROM mytable' ) }; + ok(!defined($sth2), '... we should get nothing back from here'); + + is($@, + qq(Failed to parse statement. Error: incorrect use of '*'. Statement: SELECT * FROM mytable\n), + '... parser failure generated correct error'); + + $dbh->disconnect(); +} + +# parser class +{ + package MyParser; + + sub new { return bless {} } + sub parse { + my ($self, $sql) = @_; + die "incorrect use of '*'\n" if $sql =~ /^SELECT \*/; + } +} + +{ + my $dbh = DBI->connect('DBI:Mock:', '', '', { PrintError => 1 }); + isa_ok($dbh, "DBI::db"); + # check to be sure this is set, otherwise + # the test wont be set up right + cmp_ok($dbh->{PrintError}, '==', 1, '... make sure PrintError is set correctly'); + + # check parse objects + + my $parser = MyParser->new(); + + eval { + $dbh->{mock_add_parser} = $parser; + }; + ok(!$@, '... parser successfully added to dbh'); + + is($dbh->{mock_parser}->[0], $parser, '... the same parser is stored'); + + my $sth1 = eval { $dbh->prepare('SELECT myfield FROM mytable') }; + isa_ok($sth1, "DBI::st"); + + { # isolate the warn handler + $SIG{__WARN__} = sub { + my $msg = shift; + like($msg, + qr/incorrect use of \'\*\'\. Statement\: SELECT \* FROM mytable/, #' + '...got the expected warning'); + }; + + my $sth2 = eval { $dbh->prepare( 'SELECT * FROM mytable' ) }; + ok(!defined($sth2), '... we should get nothing back from here'); + } + + $dbh->disconnect(); +} + + +{ # pass in a bad parser + my $dbh = DBI->connect('DBI:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); + isa_ok($dbh, "DBI::db"); + # check to be sure this is set, otherwise + # the test wont be set up right + cmp_ok($dbh->{RaiseError}, '==', 1, '... make sure RaiseError is set correctly'); + + eval { + $dbh->{mock_add_parser} = "Fail"; + }; + like($@, qr/Parser must be a code reference or /, '... bad parser successfully not added to dbh'); + + eval { + $dbh->{mock_add_parser} = []; + }; + like($@, qr/Parser must be a code reference or /, '... bad parser successfully not added to dbh'); + +} + +{ + # check it with PrintError too + + my $dbh = DBI->connect('DBI:Mock:', '', ''); + isa_ok($dbh, "DBI::db"); + # check to be sure this is set, otherwise + # the test wont be set up right + cmp_ok($dbh->{PrintError}, '==', 1, '... make sure PrintError is set correctly'); + + { # isolate the warn handler + $SIG{__WARN__} = sub { + my $msg = shift; + like($msg, + qr/Parser must be a code reference or /, + '... bad parser successfully not added to dbh'); + }; + + ok(!defined($dbh->{mock_add_parser} = {}), '... this returns undef too'); + + my $test = "Fail"; + + ok(!defined($dbh->{mock_add_parser} = \$test), '... this returns undef too'); + + } + +} diff --git a/t/15_prepare_cached.t b/t/15_prepare_cached.t new file mode 100644 index 0000000..fc4dac3 --- /dev/null +++ b/t/15_prepare_cached.t @@ -0,0 +1,40 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 11; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +my $dbh = DBI->connect('dbi:Mock:', '', ''); +isa_ok($dbh, 'DBI::db'); + +foreach my $i ( 1 .. 2 ) { + my $sth = $dbh->prepare('SELECT foo FROM bar WHERE x = ?'); + $sth->execute($i); + my $history = $dbh->{mock_all_history}; + cmp_ok(scalar(@{$history}), '==', $i, "... have $i statement executions"); +} + +$dbh->{mock_clear_history} = 1; +my $history = $dbh->{mock_all_history}; +cmp_ok(scalar(@{$history}), '==', 0, '... the history has been is cleared'); + +foreach my $i ( 1 .. 2 ) { + my $sth = $dbh->prepare_cached('SELECT foo FROM bar WHERE x = ?'); + $sth->execute($i); + my $history = $dbh->{mock_all_history}; + cmp_ok(scalar(@{$history}), '==', $i, "... have $i statement executions"); +} + +my $st_track = $dbh->{mock_all_history}->[0]; +isa_ok($st_track, 'DBD::Mock::StatementTrack'); + +is($st_track->statement, 'SELECT foo FROM bar WHERE x = ?', '... our statements match'); + +my $params = $st_track->bound_params; +cmp_ok(scalar(@{$params}), '==', 1, '... got the expected amount of params'); diff --git a/t/16_mock_attribute_aliases.t b/t/16_mock_attribute_aliases.t new file mode 100644 index 0000000..7e651ba --- /dev/null +++ b/t/16_mock_attribute_aliases.t @@ -0,0 +1,91 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 25; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +{ # aliasing is off + my $dbh; + eval { + $dbh = DBI->connect('dbi:Mock:mysql', '', ''); + }; + ok(!$@, '... got our non-mock DB successfully'); + isa_ok($dbh, 'DBI::db'); + + ok(!defined($dbh->{mock_attribute_aliases}), '... nothing here'); + ok(!$dbh->{mock_database_name}, '... nothing here'); +} + +# now turn it on +$DBD::Mock::AttributeAliasing++; + +{ # but without a dbname it does nothing + my $dbh; + eval { + $dbh = DBI->connect('dbi:Mock:', '', ''); + }; + ok(!$@, '... got our non-mock DB successfully'); + isa_ok($dbh, 'DBI::db'); + + ok(!defined($dbh->{mock_attribute_aliases}), '... nothing here'); + ok(!$dbh->{mock_database_name}, '... nothing here'); +} + +# now test the error + +eval { + DBI->connect('dbi:Mock:Fail', '', ''); +}; +like($@, qr/Attribute aliases not available for \'Fail\'/, '... got the error we expected'); + +# test the MySQL mock db +{ + my $dbh; + eval { + $dbh = DBI->connect('dbi:Mock:mysql', '', ''); + }; + ok(!$@, '... got our mock DB successfully'); + isa_ok($dbh, 'DBI::db'); + + is($dbh->{mock_database_name}, 'mysql', '... and its the name we expected'); + + ok(defined($dbh->{mock_attribute_aliases}), '... got something here'); + is(ref($dbh->{mock_attribute_aliases}), 'HASH', '... and its the hash we expected'); + + my $sth = $dbh->prepare('INSERT INTO Foo (bar) VALUES(NULL)'); + isa_ok($sth, 'DBI::st'); + + $sth->execute(); + + cmp_ok($dbh->{mysql_insertid}, '==', 1, '... our alias works'); + +} + +# and test it with the lowercasing +{ + my $dbh; + eval { + $dbh = DBI->connect('dbi:Mock:MySQL', '', ''); + }; + ok(!$@, '... got our mock DB successfully'); + isa_ok($dbh, 'DBI::db'); + + is($dbh->{mock_database_name}, 'MySQL', '... and its the name we expected'); + + ok(defined($dbh->{mock_attribute_aliases}), '... got something here'); + is(ref($dbh->{mock_attribute_aliases}), 'HASH', '... and its the hash we expected'); + + my $sth = $dbh->prepare('INSERT INTO Foo (bar) VALUES(NULL)'); + isa_ok($sth, 'DBI::st'); + + $sth->execute(); + + cmp_ok($dbh->{mysql_insertid}, '==', 1, '... our alias works'); + +} diff --git a/t/20_st_execute_empty.t b/t/20_st_execute_empty.t new file mode 100644 index 0000000..ad670c2 --- /dev/null +++ b/t/20_st_execute_empty.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 14; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +my $sql = 'SELECT * FROM foo WHERE bar = ? AND baz = ?'; + +{ + my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + my $sth = eval { $dbh->prepare( $sql ) }; + ok( ! $@, 'Statement handle prepared ok' ); + is( ref( $sth ), 'DBI::st', + 'Statement handle returned of the proper type' ); + is( $sth->{mock_my_history}->statement, $sql, + 'Statement handle stores SQL (method on tracker)' ); + is( $sth->{mock_statement}, $sql, + 'Statement handle stores SQL (attribute)' ); + is( $sth->{mock_is_executed}, 'no', + 'Execute flag not set yet' ); + eval { $sth->execute() }; + ok( ! $@, 'Called execute() ok (no params)' ); + is( $sth->{mock_is_executed}, 'yes', + 'Execute flag set after execute()' ); + my $t_params = $sth->{mock_my_history}->bound_params; + is( scalar @{ $t_params }, 0, + 'No parameters tracked (method on tracker)' ); + my $a_params = $sth->{mock_params}; + is( scalar @{ $a_params }, 0, + 'No parameters tracked (attribute)' ); + is( $sth->{mock_is_finished}, 'no', + 'Finished flag not set yet' ); + eval { $sth->finish }; + ok( ! $@, 'Called finish() ok' ); + is( $sth->{mock_is_finished}, 'yes', + 'Finished flag set after finish()' ); +} diff --git a/t/25_st_execute_bound_params.t b/t/25_st_execute_bound_params.t new file mode 100644 index 0000000..435ce54 --- /dev/null +++ b/t/25_st_execute_bound_params.t @@ -0,0 +1,39 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 10; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +my $sql = 'SELECT * FROM foo WHERE bar = ? AND baz = ?'; + +{ + my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + my $sth = eval { $dbh->prepare( $sql ) }; + eval { + $sth->bind_param( 2, 'bar' ); + $sth->bind_param( 1, 'baz' ); + }; + ok( ! $@, 'Parameters bound to statement handle with bind_param()' ); + eval { $sth->execute() }; + ok( ! $@, 'Called execute() ok (empty, after bind_param calls)' ); + my $t_params = $sth->{mock_my_history}->bound_params; + is( scalar @{ $t_params }, 2, + 'Correct number of parameters bound (method on tracker)' ); + is( $t_params->[0], 'baz', + 'Statement handle stored bound parameter from bind_param() (method on tracker)' ); + is( $t_params->[1], 'bar', + 'Statement handle stored bound parameter from bind_param() (method on tracker)' ); + my $a_params = $sth->{mock_params}; + is( scalar @{ $a_params }, 2, + 'Correct number of parameters bound (attribute)' ); + is( $a_params->[0], 'baz', + 'Statement handle stored bound parameter from bind_param() (attribute)' ); + is( $a_params->[1], 'bar', + 'Statement handle stored bound parameter from bind_param() (attribute)' ); +} diff --git a/t/30_st_execute_pass_params.t b/t/30_st_execute_pass_params.t new file mode 100644 index 0000000..3ec6346 --- /dev/null +++ b/t/30_st_execute_pass_params.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 9; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +my $sql = 'SELECT * FROM foo WHERE bar = ? AND baz = ?'; + +{ + my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + my $sth = eval { $dbh->prepare( $sql ) }; + eval { $sth->execute( 'baz', 'bar' ) }; + ok( ! $@, 'Called execute() ok (inline params)' ); + my $t_params = $sth->{mock_my_history}->bound_params; + is( scalar @{ $t_params }, 2, + 'Correct number of parameters bound (inline; method on tracker)' ); + is( $t_params->[0], 'baz', + 'Statement handle stored bound inline parameter (method on tracker)' ); + is( $t_params->[1], 'bar', + 'Statement handle stored bound inline parameter (method on tracker)' ); + my $a_params = $sth->{mock_my_history}->bound_params; + is( scalar @{ $a_params }, 2, + 'Correct number of parameters bound (inline; attribute)' ); + is( $a_params->[0], 'baz', + 'Statement handle stored bound inline parameter (attribute)' ); + is( $a_params->[1], 'bar', + 'Statement handle stored bound inline parameter (attribute)' ); +} diff --git a/t/35_st_fetch_records.t b/t/35_st_fetch_records.t new file mode 100644 index 0000000..6ad5b3b --- /dev/null +++ b/t/35_st_fetch_records.t @@ -0,0 +1,109 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 43; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +#use Data::Dumper qw( Dumper ); + +my @rs_foo = ( + [ 'this', 'that' ], + [ 'this_one', 'that_one' ], + [ 'this_two', 'that_two' ], +); +my $foo_sql = 'SELECT this, that FROM foo'; + +my @rs_login = ( + [ 'login', 'first_name', 'last_name' ], + [ 'cwinters', 'Chris', 'Winters' ], + [ 'bflay', 'Bobby', 'Flay' ], + [ 'alincoln', 'Abe', 'Lincoln' ], +); +my $login_sql = 'SELECT login, first_name, last_name FROM foo'; + +my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); + +# Seed the handle with two resultsets + +# the first one ordered +$dbh->{mock_add_resultset} = [ @rs_foo ]; + +# the second one named +$dbh->{mock_add_resultset} = { sql => $login_sql, + results => \@rs_login }; + +# run the first one +{ + my ( $sth ); + eval { + $sth = $dbh->prepare( $foo_sql ); + $sth->execute(); + }; + check_resultset( $sth, [ @rs_foo ] ); +} + +{ + my ( $sth ); + eval { + $sth = $dbh->prepare( $login_sql ); + $sth->execute(); + }; + check_resultset( $sth, [ @rs_login ] ); +} + +{ + my ( $sth ); + eval { + $sth = $dbh->prepare( q{INSERT INTO foo VALUES ( 'Don Corleone' )} ); + $sth->execute(); + }; + ok( ! $sth->{Active}, + '...this should not be an active handle' ); +} + +sub check_resultset { + my ( $sth, $check ) = @_; + my $fields = shift @{ $check }; + is( $sth->{mock_num_records}, scalar @{ $check }, + 'Correct number of records reported by statement' ); + is( $sth->{mock_num_rows}, scalar @{ $check }, + 'Correct number of rows reported by statement' ); + is( $sth->rows, scalar @{ $check }, + 'Correct number of rows reported by statement' ); + is( $sth->{mock_current_record_num}, 0, + 'Current record number correct before fetching' ); + ok( $sth->{Active}, + '... this should be an active handle' ); + for ( my $i = 0; $i < scalar @{ $check }; $i++ ) { + my $rec_num = $i + 1; + my $this_check = $check->[$i]; + my $this_rec = $sth->fetchrow_arrayref; + my $num_fields = scalar @{ $this_check }; + is( scalar @{ $this_rec }, $num_fields, + "Record $rec_num, correct number of fields ($num_fields)" ); + for ( my $j = 0; $j < $num_fields; $j++ ) { + my $field_num = $j + 1; + is( $this_rec->[$j], $this_check->[$j], + "Record $rec_num, field $field_num" ); + } + is( $sth->{mock_current_record_num}, $rec_num, + "Record $rec_num, current record number tracked" ); + if ( $rec_num == scalar @{ $check } ) { + ok( $sth->{mock_is_depleted}, + 'Resultset depleted properly' ); + ok( ! $sth->{Active}, + '...this should not be an active handle anymore' ); + } + else { + ok( ! $sth->{mock_is_depleted}, + 'Resultset not yet depleted' ); + } + } + +} diff --git a/t/37_st_can_connect.t b/t/37_st_can_connect.t new file mode 100644 index 0000000..c534324 --- /dev/null +++ b/t/37_st_can_connect.t @@ -0,0 +1,76 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 23; + +BEGIN { + use_ok('DBD::Mock'); + use_ok('DBI'); +} + +my $dbh = DBI->connect('DBI:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); +isa_ok($dbh, "DBI::db"); +cmp_ok($dbh->{RaiseError}, '==', 1, '... RaiseError is set correctly'); +cmp_ok($dbh->{PrintError}, '==', 0, '... PrintError is set correctly'); + +my $sth_exec = $dbh->prepare('SELECT foo FROM bar'); +isa_ok($sth_exec, "DBI::st"); + +# turn off the handle between the prepare and execute... +$dbh->{mock_can_connect} = 0; + +# check our value is correctly set +cmp_ok($dbh->{mock_can_connect}, '==', 0, '... can connect is set to 0'); + +# and check the side effects of that +ok(!$dbh->{Active}, '... the handle is not Active'); +ok(!$dbh->ping(), '... and ping returns false'); + +# now try to execute it + +eval { $sth_exec->execute() }; +ok($@, '... we got an exception'); +like($@, qr/^No connection present/, '... we got the expected execption'); + +# turn off the database between execute and fetch + +$dbh->{mock_can_connect} = 1; + +# check our value is correctly set +cmp_ok($dbh->{mock_can_connect}, '==', 1, '... can connect is set to 1'); + +# and check the side effects of that +ok($dbh->{Active}, '... the handle is Active'); +ok($dbh->ping(), '... and ping returns true'); + +$dbh->{mock_add_resultset} = [[ qw(foo bar ) ], # column headers + [ qw(this that ) ], # first row values + [ qw(never seen) ]]; # second row values + +my $sth_fetch = $dbh->prepare('SELECT foo, bar FROM baz'); +isa_ok($sth_fetch, "DBI::st"); + +eval { $sth_fetch->execute() }; +ok(!$@, '... executed without exception'); + +my $row = eval { $sth_fetch->fetchrow_arrayref() }; +ok(!$@, '... the first row was returned without execption'); +is_deeply($row, [ qw(this that) ], '... we got back the expected data in the first row'); + +# now turn off the database +$dbh->{mock_can_connect} = 0; + +# check our value is correctly set +cmp_ok($dbh->{mock_can_connect}, '==', 0, '... can connect is set to 0'); + +# and check the side effects of that +ok(!$dbh->{Active}, '... the handle is not Active'); +ok(!$dbh->ping(), '... and ping returns false'); + +$row = eval { $sth_fetch->fetchrow_arrayref() }; +ok($@, '... we got the exception'); +like($sth_fetch->errstr, + qr/^No connection present/, + '... fetching row against inactive db throws expected exception' ); diff --git a/t/40_mock_statement_track.t b/t/40_mock_statement_track.t new file mode 100644 index 0000000..e4cf238 --- /dev/null +++ b/t/40_mock_statement_track.t @@ -0,0 +1,151 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 68; + +BEGIN { + use_ok('DBD::Mock'); +} + +{ # check the available methods + + can_ok("DBD::Mock::StatementTrack", 'new'); + my $st_track = DBD::Mock::StatementTrack->new(); + isa_ok($st_track, 'DBD::Mock::StatementTrack'); + + can_ok($st_track, 'num_fields'); + can_ok($st_track, 'num_params'); + can_ok($st_track, 'bound_param'); + can_ok($st_track, 'bound_param_trailing'); + can_ok($st_track, 'is_active'); + can_ok($st_track, 'is_finished'); + can_ok($st_track, 'mark_executed'); + can_ok($st_track, 'next_record'); + can_ok($st_track, 'is_depleted'); + can_ok($st_track, 'to_string'); + can_ok($st_track, 'is_executed'); + can_ok($st_track, 'statement'); + can_ok($st_track, 'current_record_num'); + can_ok($st_track, 'return_data'); + can_ok($st_track, 'fields'); + can_ok($st_track, 'bound_params'); +} + +{ # check the default state + + my $st_track = DBD::Mock::StatementTrack->new(); + isa_ok($st_track, 'DBD::Mock::StatementTrack'); + + cmp_ok($st_track->num_fields(), '==', 0, '... we have no fields in the default'); + is_deeply($st_track->fields(), [], '... we have no fields in the default'); + + cmp_ok($st_track->num_params(), '==', 0, '... we have no bound params in the default'); + is_deeply($st_track->bound_params(), [], '... we have no bound params in the default'); + + is_deeply($st_track->return_data(), [], '... we have no return data in the default'); + + cmp_ok($st_track->current_record_num(), '==', 0, '... our current record num is 0 in the default'); + + is($st_track->statement(), '', '... our statement is a blank string in the default'); + is($st_track->is_executed(), 'no', '... our statement is not executed in the default'); + + ok($st_track->is_depleted(), '... the default state is depleted'); + ok(!defined($st_track->next_record()), '... the default state has no next record since it is depleted'); + + is($st_track->is_finished(), 'no', '... our statement is not finished in the default'); + + cmp_ok($st_track->is_active(), '==', 0, '... the default state is not active'); +} + +{ # check a pre-defined state + + my %params = ( + return_data => [ [1, 1, 1], [2, 2, 2], [3, 3, 3] ], + fields => [ 'foo', 'bar', 'baz' ], + bound_params => [ 'baz' ], + statement => 'SELECT foo FROM bar WHERE baz = ?' + ); + + my $st_track = DBD::Mock::StatementTrack->new(%params); + isa_ok($st_track, 'DBD::Mock::StatementTrack'); + + cmp_ok($st_track->num_fields(), '==', 3, '... we have the expected num of fields'); + is_deeply($st_track->fields(), $params{fields}, '... we have the expected fields'); + + cmp_ok($st_track->num_params(), '==', 1, '... we have the expected num of bound params'); + is_deeply($st_track->bound_params(), $params{bound_params}, '... we have the expected bound params'); + + is_deeply($st_track->return_data(), $params{return_data}, '... we have the expected return data'); + + cmp_ok($st_track->current_record_num(), '==', 0, '... our current record num is 0 in the default'); + + is($st_track->statement(), $params{statement}, '... our statement as expected '); + is($st_track->is_executed(), 'no', '... our statement is not executed'); + + ok(!$st_track->is_depleted(), '... the state is not depleted'); + + is($st_track->is_finished(), 'no', '... our statement is not finished'); + + cmp_ok($st_track->is_active(), '==', 0, '... the default state is active'); + +# now lets alter that state +# and make sure changes reflect + + is_deeply( + $st_track->bound_param(2, 'foo'), + [ 'baz', 'foo' ], + '... we have the expected bound params'); + + $st_track->bound_param_trailing('bar', 'foobar'); + is_deeply( + $st_track->bound_params(), + [ 'baz', 'foo', 'bar', 'foobar' ], + '... we have the expected bound params'); + + cmp_ok($st_track->num_params(), '==', 4, '... we have the expected num of bound params'); + + { + my $old_SQL = $st_track->statement(); + + my $SQL = 'INSERT INTO foo (foo, bar, baz) VALUE(1, 2, 3)'; + $st_track->statement($SQL); + + is($st_track->statement(), $SQL, '... our statement as expected '); + cmp_ok($st_track->is_active(), '==', 0, '... with an INSERT we are not considered active'); + + $st_track->statement($old_SQL); + + is($st_track->statement(), $old_SQL, '... restore our statement'); + } + + $st_track->mark_executed(); + is($st_track->is_executed(), 'yes', '... our statement is now executed'); + cmp_ok($st_track->current_record_num(), '==', 0, '... our current record num is 0'); + + cmp_ok($st_track->is_active(), '==', 1, '... we are active now that we are executed'); + + for (1 .. 3) { + ok(!$st_track->is_depleted(), '... the state is not depleted'); + is_deeply( + $st_track->next_record(), + [ $_, $_, $_ ], + '... got the next record as expected'); + cmp_ok($st_track->current_record_num(), '==', $_, '... our current record num is now ' . $_); + } + + ok(!defined($st_track->next_record()), '... no more records'); + ok($st_track->is_depleted(), '... we are now depleted'); + + cmp_ok($st_track->is_active(), '==', 0, '... we are no longer active now that we are depleted'); + + is($st_track->is_finished(), 'no', '... passing in nothing just returns the value'); + + $st_track->is_finished('yes'); + is($st_track->is_finished(), 'yes', '... our statement is now finished'); + + $st_track->is_finished('nothing'); + is($st_track->is_finished(), 'no', '... our statement is no longer finished'); + +} diff --git a/t/45_mock_statement_track_iterator.t b/t/45_mock_statement_track_iterator.t new file mode 100644 index 0000000..b7e9b97 --- /dev/null +++ b/t/45_mock_statement_track_iterator.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 22; + +BEGIN { + use_ok('DBD::Mock'); +} + +# just test the iterator plain +{ + my $i = DBD::Mock::StatementTrack::Iterator->new([ 1 .. 5 ]); + isa_ok($i, 'DBD::Mock::StatementTrack::Iterator'); + + cmp_ok($i->next(), '==', 1, '... got 1'); + cmp_ok($i->next(), '==', 2, '... got 2'); + cmp_ok($i->next(), '==', 3, '... got 3'); + cmp_ok($i->next(), '==', 4, '... got 4'); + cmp_ok($i->next(), '==', 5, '... got 5'); + ok(!defined($i->next()), '... got undef'); + + $i->reset(); + + cmp_ok($i->next(), '==', 1, '... got 1'); + cmp_ok($i->next(), '==', 2, '... got 2'); + cmp_ok($i->next(), '==', 3, '... got 3'); + cmp_ok($i->next(), '==', 4, '... got 4'); + cmp_ok($i->next(), '==', 5, '... got 5'); + ok(!defined($i->next()), '... got undef'); +} + +# and now test it within context + +my $dbh = DBI->connect('DBI:Mock:', '', ''); +isa_ok($dbh, 'DBI::db'); + +my $i = $dbh->{mock_all_history_iterator}; +isa_ok($i, 'DBD::Mock::StatementTrack::Iterator'); + +ok(!defined($i->next()), '... nothing in the iterator'); + +$dbh->prepare("INSERT INTO nothing (nothing) VALUES('nada')"); + +ok(defined($i->next()), '... now something in the iterator (which is what we want)'); + +$dbh->prepare("INSERT INTO nothing (nothing) VALUES('nada')"); + +my $next = $i->next(); +ok(defined($next), '... something in the iterator'); +isa_ok($next, 'DBD::Mock::StatementTrack'); +is($next->statement, "INSERT INTO nothing (nothing) VALUES('nada')", '... its our old insert statement too'); + +ok(!defined($i->next()), '... now nothing in the iterator'); diff --git a/t/50_db_pool.t b/t/50_db_pool.t new file mode 100644 index 0000000..ffaa1ac --- /dev/null +++ b/t/50_db_pool.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; + +BEGIN { + use_ok( 'DBD::Mock' => qw(Pool) ); + use_ok('DBI'); +} + +# check that the pool works +{ + + my $dbh = DBI->connect("DBI:Mock:", '', ''); + isa_ok($dbh, 'DBD::Mock::Pool::db'); + + my $dbh2 = DBI->connect("DBI:Mock:", '', ''); + isa_ok($dbh2, 'DBD::Mock::Pool::db'); + + is($dbh, $dbh2, '... these handles should be the same'); + + ok($dbh->disconnect(), '... this will not actually do anything just return true'); + ok($dbh2->disconnect(), '... this will not actually do anything just return true'); + +} + +# check that the pool holds result sets +# in an scope indepenent manner + +{ + # set up handle from pool + my $dbh = DBI->connect("DBI:Mock:", '', ''); + isa_ok($dbh, 'DBD::Mock::Pool::db'); + + $dbh->{mock_add_resultset} = [[ 'foo', 'bar', 'baz' ], [ 1, 2, 3 ]]; + + ok($dbh->disconnect(), '... not really disconnecting, just returning true'); +} + +{ + # execute a statement, and expect the results + my $dbh = DBI->connect("DBI:Mock:", '', ''); + isa_ok($dbh, 'DBD::Mock::Pool::db'); + + my $sth = $dbh->prepare("SELECT foo, bar, baz FROM whatever"); + $sth->execute(); + is_deeply( + $sth->fetchrow_arrayref(), + [ 1, 2, 3 ], + '... got our row correctly' + ); + $sth->finish(); + + ok($dbh->disconnect(), '... not really disconnecting, just returning true'); +} + +{ + # check our statement istory + my $dbh = DBI->connect("DBI:Mock:", '', ''); + isa_ok($dbh, 'DBD::Mock::Pool::db'); + + my $history = $dbh->{mock_all_history}; + + cmp_ok(scalar @{$history}, '==', 1, '... we executed 1 statement'); + + is( $history->[0]->statement(), + "SELECT foo, bar, baz FROM whatever", + '... this the statement we executed'); + + ok($dbh->disconnect(), '... not really disconnecting, just returning true'); +} \ No newline at end of file diff --git a/t/60_DBD_Mock_Session_test.t b/t/60_DBD_Mock_Session_test.t new file mode 100644 index 0000000..01c7df1 --- /dev/null +++ b/t/60_DBD_Mock_Session_test.t @@ -0,0 +1,296 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 48; + +BEGIN { + use_ok('DBD::Mock'); +} + +use DBI; + +{ + package Login::Test; + + my $MAX_LOGIN_FAILURES = 3; + + sub login { + my ($dbh, $u, $p) = @_; + # look for the right username and password + my ($user_id) = $dbh->selectrow_array("SELECT user_id FROM users WHERE username = '$u' AND password = '$p'"); + # if we find one, then ... + if ($user_id) { + # log the event and return true + $dbh->do("INSERT INTO event_log (event) VALUES('User $user_id logged in')"); + return 'LOGIN SUCCESSFUL'; + } + # if we don't find one then ... + else { + # see if the username exists ... + my ($user_id, $login_failures) = $dbh->selectrow_array("SELECT user_id, login_failures FROM users WHERE username = '$u'"); + # if we do have a username, and the password doesnt match then ... + if ($user_id) { + # if we have not reached the max allowable login failures then ... + if ($login_failures < $MAX_LOGIN_FAILURES) { + # update the login failures + $dbh->do("UPDATE users SET login_failures = (login_failures + 1) WHERE user_id = $user_id"); + return 'BAD PASSWORD'; + } + # otherwise ... + else { + # we must update the login failures, and lock the account + $dbh->do("UPDATE users SET login_failures = (login_failures + 1), locked = 1 WHERE user_id = $user_id"); return 'USER ACCOUNT LOCKED'; + } + } + else { + return 'USERNAME NOT FOUND'; + } + } + } +} + +{ + my $session = DBD::Mock::Session->new({}); + isa_ok($session, 'DBD::Mock::Session'); + + is($session->name(), 'Session 1', '... got the first default session name'); + + my $session2 = DBD::Mock::Session->new({}); + isa_ok($session2, 'DBD::Mock::Session'); + + is($session2->name(), 'Session 2', '... got the second default session name'); +} + +{ + my $successful_login = DBD::Mock::Session->new('successful_login' => ( + { + statement => "SELECT user_id FROM users WHERE username = 'user' AND password = '****'", + results => [[ 'user_id' ], [ 1 ]] + }, + { + statement => "INSERT INTO event_log (event) VALUES('User 1 logged in')", + results => [] + } + )); + isa_ok($successful_login, 'DBD::Mock::Session'); + + is($successful_login->name(), 'successful_login', '... got the right name'); + + my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); + $dbh->{mock_session} = $successful_login; + + is(Login::Test::login($dbh, 'user', '****'), 'LOGIN SUCCESSFUL', '... logged in successfully'); +} + +{ + + my $bad_username = DBD::Mock::Session->new('bad_username' => ( + { + statement => qr/SELECT user_id FROM users WHERE username = \'.*?\' AND password = \'.*?\'/, #' + results => [[ 'user_id' ], [ undef ]] + }, + { + statement => qr/SELECT user_id, login_failures FROM users WHERE username = \'.*?\'/, #' + results => [[ 'user_id', 'login_failures' ], [ undef, undef ]] + } + )); + isa_ok($bad_username, 'DBD::Mock::Session'); + + is($bad_username->name(), 'bad_username', '... got the right name'); + + my $dbh = DBI->connect('dbi:Mock:', '', ''); + $dbh->{mock_session} = $bad_username; + + is(Login::Test::login($dbh, 'user', '****'), 'USERNAME NOT FOUND', '... username is not found'); +} + +{ + my $bad_password = DBD::Mock::Session->new('bad_password' => ( + { + statement => sub { $_[0] eq "SELECT user_id FROM users WHERE username = 'user' AND password = '****'" }, + results => [[ 'user_id' ], [ undef]] + }, + { + statement => sub { $_[0] eq "SELECT user_id, login_failures FROM users WHERE username = 'user'" }, + results => [[ 'user_id', 'login_failures' ], [ 1, 0 ]] + }, + { + statement => sub { $_[0] eq "UPDATE users SET login_failures = (login_failures + 1) WHERE user_id = 1" }, + results => [] + } + )); + isa_ok($bad_password, 'DBD::Mock::Session'); + + is($bad_password->name(), 'bad_password', '... got the right name'); + + my $dbh = DBI->connect('dbi:Mock:', '', ''); + $dbh->{mock_session} = $bad_password; + + is(Login::Test::login($dbh, 'user', '****'), 'BAD PASSWORD', '... username is found, but the password is wrong'); +} + +{ + my $lock_user_account = DBD::Mock::Session->new('lock_user_account' => ( + { + statement => "SELECT user_id FROM users WHERE username = 'user' AND password = '****'", + results => [[ 'user_id' ], [ undef]] + }, + { + statement => qr/SELECT user_id, login_failures FROM users WHERE username = \'.*?\'/, #' + results => [[ 'user_id', 'login_failures' ], [ 1, 4 ]] + }, + { + statement => sub { $_[0] eq "UPDATE users SET login_failures = (login_failures + 1), locked = 1 WHERE user_id = 1" }, + results => [] + } + )); + isa_ok($lock_user_account, 'DBD::Mock::Session'); + + is($lock_user_account->name(), 'lock_user_account', '... got the right name'); + + my $dbh = DBI->connect('dbi:Mock:', '', ''); + $dbh->{mock_session} = $lock_user_account; + + is(Login::Test::login($dbh, 'user', '****'), 'USER ACCOUNT LOCKED', '... username is found, and the password is wrong, and the user account is now locked'); +} + +# now check some errors + +{ + eval { + DBD::Mock::Session->new() + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^You must specify at least one session state/, '... got the error we expected'); + + eval { + DBD::Mock::Session->new([]) + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^You must specify session states as HASH refs/, '... got the error we expected'); + + eval { + DBD::Mock::Session->new('session') + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^You must specify at least one session state/, '... got the error we expected'); + + eval { + DBD::Mock::Session->new('session', []) + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^You must specify session states as HASH refs/, '... got the error we expected'); + + eval { + DBD::Mock::Session->new('session', {}, []) + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^You must specify session states as HASH refs/, '... got the error we expected'); + +} + +{ + my $session = DBD::Mock::Session->new('session' => {}); + isa_ok($session, 'DBD::Mock::Session'); + + eval { + $session->verify(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar'); + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^Bad state \'0\' in DBD::Mock::Session \(session\)/, '... got the error we expected'); + +} + +{ + my $session = DBD::Mock::Session->new('session' => { statement => "" }); + isa_ok($session, 'DBD::Mock::Session'); + + eval { + $session->verify(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar'); + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^Bad state \'0\' in DBD::Mock::Session \(session\)/, '... got the error we expected'); + +} + +{ + my $session = DBD::Mock::Session->new('session' => { results => [] }); + isa_ok($session, 'DBD::Mock::Session'); + + eval { + $session->verify(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar'); + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^Bad state \'0\' in DBD::Mock::Session \(session\)/, '... got the error we expected'); + +} + +{ + my $session = DBD::Mock::Session->new('session' => + { + statement => [], + results => [] + } + ); + isa_ok($session, 'DBD::Mock::Session'); + + eval { + $session->verify(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar'); + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^Bad \'statement\' value \'ARRAY\(0x[a-f0-9]+\)\' in current state in DBD::Mock::Session \(session\)/, '... got the error we expected'); + +} + +{ + my $session = DBD::Mock::Session->new('session' => + { + statement => "SELECT foo FROM baz", + results => [] + } + ); + isa_ok($session, 'DBD::Mock::Session'); + + eval { + $session->verify(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar'); + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^Statement does not match current state in DBD::Mock::Session \(session\)/, '... got the error we expected'); + +} + +{ + my $session = DBD::Mock::Session->new('session' => + { + statement => qr/SELECT foo FROM baz/, + results => [] + } + ); + isa_ok($session, 'DBD::Mock::Session'); + + eval { + $session->verify(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar'); + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^Statement does not match current state in DBD::Mock::Session \(session\)/, '... got the error we expected'); + +} + +{ + my $session = DBD::Mock::Session->new('session' => + { + statement => sub { 0 }, + results => [] + } + ); + isa_ok($session, 'DBD::Mock::Session'); + + eval { + $session->verify(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar'); + }; + ok(defined($@), '... got an error, as expected'); + like($@, qr/^Statement does not match current state in DBD::Mock::Session \(session\)/, '... got the error we expected'); + +} diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..4ae1af3 --- /dev/null +++ b/t/pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; + +all_pod_files_ok();