Test-MockDBI-0.70/0000755000175000017500000000000012022124715011633 5ustar affaffTest-MockDBI-0.70/Makefile.PL0000755000175000017500000000205412013153136013610 0ustar affaffuse strict; use warnings; use 5.008; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Test::MockDBI', 'VERSION_FROM' => 'lib/Test/MockDBI.pm', 'ABSTRACT_FROM' => 'lib/Test/MockDBI.pm', 'AUTHOR' => 'Mark Leighton Fisher ', 'LICENSE' => 'perl', 'META_MERGE' => { resources => { repository => 'https://github.com/aff/Test-MockDBI', }, keywords => [qw [Test Mock DBI database]], }, 'BUILD_REQUIRES' => { 'CPAN::Meta' => 0, }, 'PREREQ_PM' => { 'DBI' => 0, 'Test::MockObject' => 0.14, 'Test::More' => 0, 'File::Spec::Functions' => 0, 'Test::Warn' => 0, 'Test::Differences' => 0, 'Scalar::Util' => 0, 'Carp' => 0, 'Clone' => 0 }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Test-MockDBI-*' }, ); __END__ Test-MockDBI-0.70/HISTORY0000755000175000017500000000414312004510233012716 0ustar affaffHISTORY This is the third version (second major re-write) of this code. All three versions used Test::MockObject to mock-up the DBI, but they differed in their modularity and how the developer changed the mock DBI's behavior. The first version was embedded in an application, using DFA::Simple to provide a state machine for processing the SQL. This was not modular or reusable. (I was coming up to speed on a client's DBI application and needed a way to quickly test whether the DBI interface portion was correct without modifying the production database.) The second version was a .pl file implementing a singleton object that put all its code and data into main:: (because I misunderstood how Test::MockObject worked), used DFA::Simple again, and had to be require'd. Usable, but not nearly as simple as it seemed like it should be. In this third version: - Test::MockDBI is a CPAN-standard Perl module now, with code and data all in the Test::MockObject namespace. Once again, Test::MockDBI is a singleton class, as I cannot see a way that multiple Test::MockDBI objects would be useful. - DFA::Simple is no longer used, as using the second version of Test::MockDBI to test multiple programs revealed that any state machine(s) used should be part of the developer-supplied code for processing specific pieces of SQL, rather than built into the main code. - Testing types ("--dbitest[=TYPE]") were made more explicit. An explicit wildcard type of 0 (zero) was added (easily since zero cannot be used as a regular type). Strangely enough, this wildcard type almost eliminated use of state machines in my testing... - The separate test programs are autogenerated so they use the correct #! startup line. - The test suite covers almost all of the statements, and most of the branches and conditionals. - Devel::Cover can be used to generate test coverage statistics. - The developed-supplied code to invoke Test::MockDBI and modify the behavior of the DBI is now about half the size of what was required by the second version of Test::MockDBI. Test-MockDBI-0.70/lib/0000755000175000017500000000000012022124715012401 5ustar affaffTest-MockDBI-0.70/lib/Test/0000755000175000017500000000000012022124715013320 5ustar affaffTest-MockDBI-0.70/lib/Test/MockDBI.pm0000644000175000017500000006002012022124644015065 0ustar affaffpackage Test::MockDBI; use 5.008; # minimum Perl is V5.8.0 use strict; use warnings; use Carp; use Clone; use Test::MockObject::Extends; use Scalar::Util; our $VERSION = '0.70'; my $instance = undef; =head1 NAME Test::MockDBI - Mocked DBI interface for testing purposes =head1 SYNOPSIS use Test::MockDBI; my $mi = Test::MockDBI::get_instance(); Sets a fake return value for the rows statementhandler $mi->set_retval( method => rows, retval => sub{ return scalar( @somearray ); }); $mi->set_retval( method => 'bind_param', retval => undef); Same as: $mi->bad_method('bind_param'); You can also specify return values for specific sqls $mi->set_retval( method => rows, retval => sub{ return scalar( @somearray ); }, sql => 'select id from names'); $mi->set_retval( method => 'bind_param', retval => undef, sql => 'select id from names where id < ?'); Same as: $mi->bad_method('bind_param', 'select id from names where id < ?'); =cut sub import{ require Test::MockDBI::Db; require Test::MockDBI::St; $instance = bless { methods => { }, _regexes => {} }, __PACKAGE__; Test::MockDBI::Db->import($instance); Test::MockDBI::St->import($instance); my $mock = Test::MockObject::Extends->new(); $mock->fake_module("DBI", connect => \&_dbi_connect, _concat_hash_sorted => \&_dbi__concat_hash_sorted, _get_sorted_hash_keys => \&_dbi__get_sorted_hash_keys, looks_like_number => \&_dbi__looks_like_number ); my %dbi_methods = ( "DBI::db" => ['clone', 'data_sources', 'do', 'last_inserted_id', 'selectrow_array', 'selectrow_hashref', 'selectall_arrayref', 'selectall_hashref', 'selectcol_arrayref', 'prepare', 'prepare_cached', 'commit', 'rollback', 'begin_work', 'disconnect', 'ping', 'get_info', 'table_info', 'column_info', 'primary_key_info', 'primary_key', 'foreign_key_info', 'statistics_info', 'tables', 'type_info_all', 'type_info', 'quote', 'quote_identifier', 'take_imp_data', 'err', 'errstr'], "DBI::st" => ['bind_param', 'bind_param_inout', 'bind_param_array', 'execute', 'execute_array', 'execute_array_fetch', 'fetchrow_arrayref', 'fetchrow_array', 'fetchrow_hashref', 'fetchall_arrayref', 'fetchall_hashref', 'finish', 'rows', 'bind_col', 'bind_columns', 'dump_results', 'err', 'errstr', 'fetch'] ); my %packages = ( "Test::MockDBI::Db" => "DBI::db", "Test::MockDBI::St" => "DBI::st" ); foreach my $mock_package ( keys %packages ){ my %available_methods = (); #Takes the package as a parameter my $map_subs = sub{ no strict 'refs'; my $p = shift; return map{ s/^_dbi_//; $_ => $p . '::_dbi_' . $_ } grep { m/^_dbi_/ } grep { defined &{"$p\::$_"} } keys %{"$p\::"}; }; %available_methods = $map_subs->($mock_package); #Also find methods inherited by the package my @isalist = eval( '@' . $mock_package . '::ISA'); die('Could not eval @' . $mock_package .'::ISA') if $@; foreach my $isa_package ( @isalist ){ #Pray for no duplicates my %isamethods = $map_subs->($isa_package); @available_methods{keys %isamethods} = values %isamethods; } my %args = (); foreach my $method ( @{ $dbi_methods{ $packages{$mock_package} } } ){ if(grep { m/^$method$/} keys %available_methods){ $args{$method} = eval( '\&' . $available_methods{$method}); die("Error during fake module setup. " . $@) if($@); }else{ #Need to check if the method is inherited from a parent package $args{$method} = eval('sub{ die \'Test::MockDBI-ERROR : Unsupported method ' . $method . '\'; } '); } } $mock->fake_module( $packages{ $mock_package }, %args ); } $mock->fake_new( "DBI" ); return 1; } ################################## # # OO - Test MockDBI API # ################################### =head1 PUBLIC INTERFACE Methods available on the Test::MockDBI instance. =over 4 =item reset() Method for reseting all mock returnvalues \ bad_params etc =cut sub reset{ my ($self) = @_; $self->{methods} = {}; } =item bad_method() This method is basically a alias for calling set_retval with the return value undef. Args: $method_name - The name of the method which should return undef $matching_sql (Optional) - The sql matching condition Returns: On success: 1 On failure: undef The method also supports calling the method with the following arguments: $method_name, $dbi_testing_type, $matching_sql This will issue a warning as it is deprecated. =cut sub bad_method{ my $self = shift; my %args = (); if(scalar(@_) == 3 && $_[0] =~ m/^[a-z_]+$/ && $_[1] =~ m/^\d+$/){ warn "You have called bad_method in an deprecated way. Please consult the documentation\n"; $args{method} = shift; #Throw away $dbi_testing_type shift; my $matchingsql = shift; if($matchingsql && $matchingsql ne ''){ my $regex = qr/$matchingsql/; $args{sql} = $regex; } }else{ %args = @_; } $args{retval} = undef; return $self->set_retval( %args ); } =item bad_param() Args: $p_value - The value that will cause bind_param to return undef $sql (Optional) - The sql matching condition Returns: On success: 1 On failure: undef The method also supports calling the method with the following arguments: $dbi_testing_type, $p_num, $p_value This will issue a warning as it is deprecated. =cut sub bad_param{ my $self = shift; my %args; #We assume its a legacy call if its length is 3 and arg 1 && 2 is numeric if(scalar(@_) == 3 && $_[0] =~ m/^\d+$/ && $_[1] =~ m/^\d+$/){ warn "You have called bad_param in an deprecated way. Please consult the documentation\n"; #Throw away $dbi_testing_type as we dont use it anymoer shift; #Throw away $p_num as we dont use it anymore shift; $args{p_value} = shift; }else{ %args = @_; } if($args{sql}){ push( @{ $self->{methods}->{bind_param}->{sqls}->{$args{sql}}->{bad_params}}, $args{p_value}); $self->{_regexes}->{$args{sql}} = (ref($args{sql}) eq 'Regexp') ? $args{sql} : qr/\Q$args{sql}\E/; }else{ push( @{ $self->{methods}->{bind_param}->{global_bad_params} }, $args{p_value}); } return 1; } =item set_retval() Method for setting a return value for the specific method. Args:(Keys in a hash) method - The method that should return the provided value retval - The data which should be returned sql (Optional) - Matching sql. The return value will only be returned for the provided method if the sql matches a regex compiled by using this string Returnvalues: On success: 1 On failure: undef Example usage: #fetchrow_hashref will shift one hashref from the list each time its called if the sql matches the sql provided, this will happend #until the return list is empty. $inst->set_retval( method => 'fetchrow_hashref', retval => [ { letter => 'a' }, { letter => 'b' }, { letter => 'c' } ], sql => 'select * from letters' ) #execute will default return undef $inst->set_retval( method => 'execute', retval => undef) #Execute will return 10 for sql 'select * from cars' $inst->set_retval( method => 'execute', retval => undef); $inst->set_retval( method => 'execute', retval => 10, sql => 'select * from cars'); =cut sub set_retval{ my ($self, %args) = @_; my $method = $args{method}; my $sql = $args{sql} if $args{sql}; unless($method){ warn "No method provided\n"; return; } if(ref($method)){ warn "Parameter method must be a scalar string\n"; return; } if($sql && (ref($sql) && ref($sql) ne 'Regexp')){ warn "Parameter SQL must be a scalar string or a precompiled regex\n"; return; } unless( exists $args{retval} ){ warn "No retval provided\n"; return; } $self->{methods}->{$method} = {} if !$self->{methods}->{$method}; if($sql){ $self->{methods}->{$method}->{sqls}->{$sql}->{retval} = Clone::clone($args{retval}); $self->{methods}->{$method}->{sqls}->{$sql}->{errstr} = $args{errstr} if $args{errstr}; $self->{methods}->{$method}->{sqls}->{$sql}->{err} = $args{err} if $args{err}; $self->{_regexes}->{$sql} = (ref($sql) eq 'Regexp') ? $sql : qr/\Q$sql\E/; }else{ $self->{methods}->{$method}->{default}->{retval} = Clone::clone($args{retval}); $self->{methods}->{$method}->{default}->{errstr} = $args{errstr} if $args{errstr}; $self->{methods}->{$method}->{default}->{err} = $args{err} if $args{err}; } return 1; } =item set_inout_value() Special method for handling inout params. In this method you can provided the value that the inout param should have after execute is called. Args: $sql - The sql that this rule should apply for $p_num - The parameter number of the inout parameter $value - The value that the inout parameter should have after execute Returns: On success: 1 On failure: undef Example: =cut sub set_inout_value{ my ($self, $sql, $p_num, $value) = @_; if(!$sql || ref($sql)){ warn "Parameter SQL must be a scalar string\n"; return; } if($p_num !~ m/^\d+$/){ warn "Parameter p_num must be numeric\n"; return; } $self->{inoutvalues}->{$sql}->{$p_num} = $value; return 1; } =back =head1 PRIVATE INTERFACE Methods used by the package internally. Should not be called from an external package. =over 4 =item _clear_dbi_err_errstr() Helper method used by the fake DBI::st and DBI::db to clear out the $obj->{err} and $obj->{errstr} on each method call. Should not be called from an external script\package. =cut sub _clear_dbi_err_errstr{ my ($self, $obj) = @_; $obj->{errstr} = undef; $obj->{err} = undef; $DBI::errstr = undef; $DBI::err = undef; return 1; } =item _set_dbi_err_errstr() Helper method used by the fake DBI::st and DBI::db to set the $obj->{err}, $obj->{errstr}, $DBI::err and $DBI::errstr. This method also handles RaiseError and PrintError attributes. Args: $obj - Instance of DBI::st or DBI::db %args - A hash with the following keys: err - The numeric error code to be set errstr - The user friendly DBI error message. Returns: On success : 1 On failure : undef =cut sub _set_dbi_err_errstr{ my ($self, $obj, %args) = @_; if($args{err}){ $DBI::err = $args{err}; $obj->{err} = $args{err}; } if($args{errstr}){ $DBI::errstr = $args{errstr}; $obj->{errstr} = $args{errstr}; } print $obj->{errstr} . "\n" if $obj->{PrintError} && $obj->{errstr}; die( (($obj->{errstr}) ? $obj->{errstr} : '') ) if $obj->{RaiseError}; return 1; } =item _set_fake_dbi_err_errstr =cut sub _set_fake_dbi_err_errstr{ my ($self, $obj) = @_; my $sql = $obj->{Statement}; #This should be refactored out in a helper method my @caller = caller(1); my $method = $caller[3]; $method =~ s/Test::MockDBI::(St|Db)::_dbi_//; #No special return value is set for this method return if !exists($self->{methods}->{$method}); #Search to see if the sql has a specific if($sql){ foreach my $key (keys %{$self->{methods}->{$method}->{sqls}}){ #This introduces the bug that the first hit will be the one used. #This is done to be complient with the regex functionality in the earlier versions #of Test::MockDBI if( $sql =~ $self->{_regexes}->{$key}){ $self->_set_dbi_err_errstr($obj, err => $self->{methods}->{$method}->{sqls}->{$key}->{err}, errstr => $self->{methods}->{$method}->{sqls}->{$key}->{errstr} ); return 1; } } } #If $sql is not or we have no matching sql we return the default if it is set if(exists $self->{methods}->{$method}->{default}->{err} && exists $self->{methods}->{$method}->{default}->{errstr}){ $self->_set_dbi_err_errstr($obj, err => $self->{methods}->{$method}->{default}->{err}, errstr => $self->{methods}->{$method}->{default}->{errstr}); return 1; } return ; } =item _has_inout_value() Helper method used by the DBI::db and DBI::st packages. The method searches to see if there is specified a value for a inout variable. If called in SCALAR context it return 1/undef based on if the parameter bound as $p_num has a predefined return value set. If called in LIST context the method returns and array with 1/undef in position 0 which indicates the same as when the method is called in SCALAR context. The second element of the list is the value that should be applied to the inout parameter. =cut sub _has_inout_value{ my ($self, $sql, $p_num) = @_; foreach my $key (keys %{ $self->{inoutvalues} }){ if( $sql =~ m/\Q$key\E/ms){ if($self->{inoutvalues}->{$key}->{$p_num}){ return (wantarray) ? (1, $self->{inoutvalues}->{$key}->{$p_num}) : 1; } } } return; } =item _has_fake_retval() Method for identifing if a method has a predefined return value set. If the SQL parameter is provided this will have precedence over the default value. If the method is called in SCALAR context it will return 1\undef based on if the method has a predefined return value set. If the method is called in LIST context it will return a list with 1/undef at index 0 which indicates the same as when called in SCALAR context. index 1 will contain a reference to the actual return value that should be returned by the method. This value may be undef. =cut sub _has_fake_retval{ my ($self, $sql) = @_; my @caller = caller(1); my $method = $caller[3]; $method =~ s/Test::MockDBI(::(St|Db))?::_dbi_//; #No special return value is set for this method return if !exists($self->{methods}->{$method}); #Search to see if the sql has a specific if($sql){ foreach my $key (keys %{$self->{methods}->{$method}->{sqls}}){ #This introduces the bug that the first hit will be the one used. #This is done to be complient with the regex functionality in the earlier versions #of Test::MockDBI # if( ( ($key =~ m/^\(\?\^:/ && $sql =~ $instance->{legacy_regex}->{$key}) || $sql =~ m/\Q$key\E/ms ) && # exists $self->{methods}->{$method}->{sqls}->{$key}->{retval}){ # to handle old and new versions of PERL my $modifiers = ($key =~ /\Q(?^/) ? "^" : "-xism"; if( $sql =~ $self->{_regexes}->{$key} && exists $self->{methods}->{$method}->{sqls}->{$key}->{retval}){ if(wantarray()){ return (1, $self->{methods}->{$method}->{sqls}->{$key}->{retval}); }else{ return 1; } } } } #If $sql is not or we have no matching sql we return the default if it is set if(exists $self->{methods}->{$method}->{default}->{retval}){ return (wantarray()) ? (1, $self->{methods}->{$method}->{default}->{retval}) : undef; } return; } =item _is_bad_bind_param() Method for identifing if a bind parameters value is predefined as unwanted. The configuration for the provided SQL will have precedence over the default configured behaviour. When called it will return 1\undef based on if the provided value should make the bind_param method fail. =cut sub _is_bad_bind_param{ my ($self, $sql, $param) = @_; my @caller = caller(1); my $method = $caller[3]; $method =~ s/Test::MockDBI::(St|Db)::_dbi_//; foreach my $key (keys %{ $self->{methods}->{$method}->{sqls} }){ #This introduces the bug that the first hit will be the one used. #This is done to be complient with the regex functionality in the earlier versions #of Test::MockDBI if( $sql =~ $self->{_regexes}->{$key} ){ #If no bad params is set for this sql do nothing and continue the loop. if($self->{methods}->{$method}->{sqls}->{$key}->{bad_params} && ref($self->{methods}->{$method}->{sqls}->{$key}->{bad_params}) eq 'ARRAY'){ foreach my $bad_param ( @{ $self->{methods}->{$method}->{sqls}->{$key}->{bad_params} }){ if(Scalar::Util::looks_like_number($param) && Scalar::Util::looks_like_number($bad_param)){ return 1 if $param == $bad_param; } return 1 if $param eq $bad_param; } } } } if(exists $self->{methods}->{$method}->{global_bad_params} && ref($self->{methods}->{$method}->{global_bad_params}) eq 'ARRAY'){ foreach my $bad_param ( @{ $self->{methods}->{$method}->{global_bad_params} }){ if(Scalar::Util::looks_like_number($param) && Scalar::Util::looks_like_number($bad_param)){ return 1 if $param == $bad_param; } return 1 if $param eq $bad_param; } } return; } =back =head1 CLASS INTERFACE =over 4 =item get_instance() Method for retrieving the current Test::MockDBI instance =cut sub get_instance{ return $instance; } =back =cut #################################### # # Mocked DBI API # (Method used to mock the DBI package's methods) # #################################### =pod _dbi__concat_hash_sorted This is basically a copy\paste from the DBI package itself. The method is used inside the prepare_cached method =cut sub _dbi__concat_hash_sorted { my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_; # $num_sort: 0=lexical, 1=numeric, undef=try to guess return undef unless defined $hash_ref; die "hash is not a hash reference" unless ref $hash_ref eq 'HASH'; my $keys = DBI::_get_sorted_hash_keys($hash_ref, $num_sort); my $string = ''; for my $key (@$keys) { $string .= $pair_separator if length $string > 0; my $value = $hash_ref->{$key}; if ($use_neat) { $value = DBI::neat($value, 0); } else { $value = (defined $value) ? "'$value'" : 'undef'; } $string .= $key . $kv_separator . $value; } return $string; } =pod _dbi__get_sorted_hash_keys This is basically a copy\paste from the DBI package itself. The method is used inside the prepare_cached method =cut sub _dbi__get_sorted_hash_keys { my ($hash_ref, $num_sort) = @_; if (not defined $num_sort) { my $sort_guess = 1; $sort_guess = (not DBI::looks_like_number($_)) ? 0 : $sort_guess for keys %$hash_ref; $num_sort = $sort_guess; } my @keys = keys %$hash_ref; no warnings 'numeric'; my @sorted = ($num_sort) ? sort { $a <=> $b or $a cmp $b } @keys : sort @keys; return \@sorted; } =pod _dbi_looks_like_number This is basically a copy\paste from the DBI package itself. The method is used inside the prepare_cached method =cut sub _dbi_looks_like_number { my @new = (); for my $thing(@_) { if (!defined $thing or $thing eq '') { push @new, undef; } else { push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0; } } return (@_ >1) ? @new : $new[0]; } =pod _dbi_connect Mocked DBI->connect method. The method takes the same arguments as the usual DBI->connect method. It returns a $dbh which has ref DBI::db =cut sub _dbi_connect{ my ($self, $dsn, $user, $pass, $attr) = @_; my $statement = 'CONNECT TO $dsn AS $user WITH $pass'; my ($status, $retval) = $instance->_has_fake_retval($statement); if($status){ if(ref($retval) eq 'CODE'){ return $retval->(); } return $retval; } my $object = bless({ AutoCommit => 1, Driver => undef, Name => undef, Statement => $statement, RowCacheSize => undef, Username => undef, #Common Warn => undef, Active => undef, Executed => undef, Kids => 0, ActiveKids => undef, CachedKids => undef, Type => 'db', ChildHandles => [], CompatMode => undef, InactiveDestroy => undef, AutoInactiveDestroy => undef, PrintWarn => undef, PrintError => undef, RaiseError => undef, HandleError => undef, HandleSetErr => undef, ErrCount => undef, ShowErrorStatement => undef, TraceLevel => undef, FetchHashKeyName => undef, ChopBlanks => undef, LongReadLen => undef, LongTruncOk => undef, TaintIn => undef, TaintOut => undef, Taint => undef, Profile => undef, ReadOnly => undef, Callbacks => undef, }, "DBI::db"); foreach my $key (keys %{ $attr }){ $object->{$key} = $attr->{$key} if(exists($object->{$key})); } return $object; } ########################################################## # # DEPRECATED OLD INTERFACE # ########################################################### sub set_retval_array{ warn 'set_retval_array is deprecated. Please use $instance->set_retval instead' . "\n"; my ($self, $dbi_testing_type, $matching_sql, @retval) = @_; my $regex = qr/$matching_sql/; if(ref($retval[0]) eq 'CODE'){ return $instance->set_retval( method => 'fetchrow_arrayref', sql => $regex, retval => $retval[0]); }else{ return $instance->set_retval( method => 'fetchrow_arrayref', sql => $regex, retval => [ \@retval ]); } } sub set_retval_scalar{ warn 'set_retval_scalar is deprecated. Please use $instance->set_retval instead' . "\n"; my ($self, $dbi_testing_type, $matching_sql, $retval) = @_; my @methods = qw(fetchall_arrayref fetchrow_arrayref fetchall_hashref fetchrow_hashref); my $regex = qr/$matching_sql/; #try to find out if the $retval is an arrayref only, or an arrayref of arrayref # or arrayref of hashrefs if(ref($retval) eq 'ARRAY'){ my $item = $retval->[0]; if(ref($item) eq 'ARRAY'){ #We most likely have an arrayref of arrayrefs #it should be applied to fetchall_arrayref and fetchrow_arrayref $instance->set_retval( method => 'fetchall_arrayref', sql => $regex, retval => $retval); $instance->set_retval( method => 'fetchrow_arrayref', sql => $regex, retval => $retval); }elsif(ref($item) eq 'HASH'){ #We most likely have an arrayref of hashrefs #it should be applied to fetchall_hashrefref and fetchrow_hashref $instance->set_retval( method => 'fetchall_hashref', sql => $regex, retval => $retval); $instance->set_retval( method => 'fetchrow_hashref', sql => $regex, retval => $retval); }elsif(!ref($item)){ #We only have 1 arrayref with values. This was used in the old Test::MockDBI tests #It was passed because you only called for instance fetchrow_arrayref once #We will wrap it in an array and hope for the best $instance->set_retval( method => 'fetchrow_arrayref', sql => $regex, retval => [$retval]); }else{ #We dont know, set the same retval for EVERYONE! foreach my $method ( @methods ){ $instance->set_retval( method => $method, sql => $regex, retval => $retval); } } }elsif(ref($retval) eq 'HASH'){ $instance->set_retval( method => 'fetchrow_hashref', sql => $regex, retval => [$retval]); }else{ #We dont know, set the same retval for EVERYONE! foreach my $method ( @methods ){ $instance->set_retval( method => $method, sql => $regex, retval => $retval); } } return 1; } sub set_rows{ warn 'set_rows is deprecated. Please use $instance->set_retval instead' . "\n"; my ($self, $dbi_testing_type, $matching_sql, $rows) = @_; my $regex = qr/$matching_sql/; return $instance->set_retval( method => 'rows', sql => $regex, retval => $rows ); } sub set_errstr{ warn "set_errstr is deprecated. Please use $instance->set_retval instead \n"; return; } sub _is_bad_param{ warn "_is_bad_param is deprecated and no longer functional. It allways returns 1\n"; return 1; } sub set_dbi_test_type{ warn "set_dbi_test_type is deprecated. Does nothing!\n"; return 1; } sub get_dbi_test_type{ warn "get_dbi_test_type is deprecated. Does nothing!\n"; return 1; } =head1 AUTHOR Mark Leighton Fisher, Emark-fisher@fisherscreek.comE Minor modifications (version 0.62 onwards) by Andreas Faafeng Eaff@cpan.orgE =head1 COPYRIGHT Copyright 2004, Fisher's Creek Consulting, LLC. Copyright 2004, DeepData, Inc. =head1 LICENSE This code is released under the same licenses as Perl itself. =cut 1; Test-MockDBI-0.70/lib/Test/MockDBI/0000755000175000017500000000000012022124715014530 5ustar affaffTest-MockDBI-0.70/lib/Test/MockDBI/St.pm0000644000175000017500000002166712013153136015467 0ustar affaffpackage Test::MockDBI::St; use strict; use warnings; use Test::MockDBI::Constants; use Test::MockDBI::Db; use Test::MockDBI::Base; use base qw(Test::MockDBI::Base); my $mockdbi = undef; sub import{ $mockdbi = $_[1]; } sub _dbi_bind_param{ my ($self, $p_num, $bind_value, $attr) = @_; #Clearing the dbi err/errstr $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } return if($mockdbi->_is_bad_bind_param($self->{Statement}, $bind_value)); #Check that the $p_num is a valid number if($p_num !~ m/^\d+$/){ $mockdbi->_set_dbi_err_errstr($self, err => 16, errstr => 'Illegal parameter number'); return; } if($p_num < 1 || $p_num > $self->{NUM_OF_PARAMS}){ $mockdbi->_set_dbi_err_errstr($self, err => 16, errstr => 'Illegal parameter number'); return; } #Verify that the bind_param attribute is a valid one #Rewrite this to resemble the DBI behaviour if($attr && $attr =~ m/^\d+$/){ $self->{ParamTypes}->{$p_num} = { TYPE => $attr}; }elsif($attr){ #Assume its a hash #Throw a warning as DBI does if( $attr->{TYPE} !~ m/^\d+$/){ my @caller = caller(1); warn 'Argument "' . $attr->{TYPE} .'" isn\'t numeric in subroutine entry at ' . $caller[1] . ' line ' . $caller[2] . '.' . "\n"; }else{ $self->{ParamTypes}->{$p_num} = $attr; } }else{ $self->{ParamTypes}->{$p_num} = { TYPE => SQL_VARCHAR }; } $self->{ParamValues}->{$p_num} = $bind_value; return 1; } sub _dbi_bind_param_inout{ my($self, $p_num, $bind_value, $max_length, $attr) = @_; $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if( ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } return if($mockdbi->_is_bad_bind_param($self->{Statement}, $bind_value)); if(!$self || !$p_num || !$bind_value || $max_length ){ #DBI just dies if it has to few parameters die('DBI bind_param_inout: invalid number of arguments: got handle + 2, expected handle + between 3 and 4 Usage: $h->bind_param_inout($parameter, \$var, $maxlen, [, \%attr])'); } #Check that the $p_num is a valid number if($p_num !~ m/^\d+$/){ $mockdbi->_set_dbi_err_errstr($self, err => 16, errstr => 'Illegal parameter number'); return; } if($p_num < 1 || $p_num > $self->{NUM_OF_PARAMS}){ $mockdbi->_set_dbi_err_errstr($self, err => 16, errstr => 'Illegal parameter number'); return; } #Verify that the bind_param attribute is a valid one if($attr && $attr =~ m/^\d+$/){ $self->{ParamTypes}->{$p_num} = { TYPE => $attr}; }elsif($attr){ #Assume its a hash #Throw a warning as DBI does if( $attr->{TYPE} !~ m/^\d+$/){ my @caller = caller(1); warn 'Argument "' . $attr->{TYPE} .'" isn\'t numeric in subroutine entry at ' . $caller[1] . ' line ' . $caller[2] . '.' . "\n"; }else{ $self->{ParamTypes}->{$p_num} = $attr; } }else{ $self->{ParamTypes}->{$p_num} = { TYPE => SQL_VARCHAR }; } if ( ref($bind_value) ne 'SCALAR' ) { #DBI just dies if $bind_value is not a SCALAR reference die('bind_param_inout needs a reference to a scalar value'); return; } $self->{ParamValues}->{$p_num} = $bind_value; push( @{ $self->{_fake}->{InoutParams} }, $p_num ); return 1; } sub _dbi_execute{ my ($self, @bind_values) = @_; $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } #Copied from the DBI documentation: # Active # Type: boolean, read-only # The Active attribute is true if the handle object is "active". This is rarely used in applications. # The exact meaning of active is somewhat vague at the moment. # For a database handle it typically means that the handle is connected to a database ($dbh->disconnect sets Active off). # For a statement handle it typically means that the handle is a SELECT that may have more data to fetch. # (Fetching all the data or calling $sth->finish sets Active off.) # # Due to the vague definition of the Active attribute i have taken the freedom to interpeter the attribute in the following way: # - The Active attribute is set to true on a statementhandler when the execute method is called on an already prepared select statement # - The Active attribute is set to false either if finish is called on the statementhandler or disconnect is called on the dbh # #Updating attributes $self->{Active} = 1 if $self->{Statement} =~ m/^select/i; $self->{Executed} = 1; #Update the parent activekids flag Test::MockDBI::Db::_update_active_kids($self->{Database}); if(ref($self->{_fake}->{InoutParams}) eq 'ARRAY' && scalar( @{ $self->{_fake}->{InoutParams} } ) > 0 ){ foreach my $p_num ( @{ $self->{_fake}->{InoutParams} } ){ my ($status, $retval) = $mockdbi->_has_inout_value($self->{Statement}, $p_num); ${ $self->{ParamValues}->{$p_num} } = $retval if $status; } } #Not enough parameters bound if( $self->{NUM_OF_PARAMS} != scalar(keys %{ $self->{ParamValues} })){ return '0E0'; } #Number of affected rows is not known return -1; } sub _dbi_fetchrow_arrayref{ my ($self) = @_; $mockdbi->_clear_dbi_err_errstr($self); #return if we are not executed return if( !$self->{Executed} ); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ my @caller = caller(1); if($caller[3] && $caller[3] =~ m/fetchrow_array$/){ return $retval; } return $retval->($self); } } #The resultset should be an array of hashes if(ref($retval) ne 'ARRAY'){ #Should implement support for RaiseError and PrintError return; } if(scalar( @{$retval} ) > 0){ my $row = shift @{ $retval }; if(ref($row) ne 'ARRAY'){ #Should implement support for RaiseError and PrintError return; } return $row; } #fetchrow_arrayref returns undef if no more rows are available, or an error has occured return; } sub _dbi_fetch{ return $_[0]->fetchrow_arrayref(); } sub _dbi_fetchrow_array{ my ($self) = @_; my $row = $self->fetchrow_arrayref(); return if !$row; return @{$row} if ref($row) eq 'ARRAY'; return $row->($self) if ref($row) eq 'CODE'; return $row; } sub _dbi_fetchrow_hashref{ my ($self) = @_; $mockdbi->_clear_dbi_err_errstr($self); #return if we are not executed return if( !$self->{Executed} ); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } } #The resultset should be an array of hashes if(ref($retval) ne 'ARRAY'){ #Should implement support for RaiseError and PrintError return; } if(scalar( @{$retval} ) > 0){ my $row = shift @{ $retval }; if(ref($row) ne 'HASH'){ #Should implement support for RaiseError and PrintError return; } return $row; } #fetchrow_hashref returns undef if no more rows are available, or an error has occured return; } sub _dbi_fetchall_arrayref{ my ($self) = @_; $mockdbi->_clear_dbi_err_errstr($self); #return if we are not executed return if( !$self->{Executed} ); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } } #The resultset should be an array of hashes if(ref($retval) ne 'ARRAY'){ #Should implement support for RaiseError and PrintError return; } return $retval; } sub _dbi_finish{ my ($self) = @_; $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } $self->{Active} = undef; #Update the parent activekids flag Test::MockDBI::Db::_update_active_kids($self->{Database}); return 1; } sub _dbi_rows{ my ($self) = @_; $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } return -1; } 1;Test-MockDBI-0.70/lib/Test/MockDBI/Constants.pm0000644000175000017500000000615112013150506017042 0ustar affaffpackage Test::MockDBI::Constants; use strict; use warnings; use Exporter; use base qw(Exporter); our @EXPORT = qw( SQL_ALL_TYPES SQL_ARRAY SQL_ARRAY_LOCATOR SQL_BIGINT SQL_BINARY SQL_BIT SQL_BLOB SQL_BLOB_LOCATOR SQL_BOOLEAN SQL_CHAR SQL_CLOB SQL_CLOB_LOCATOR SQL_DATE SQL_DATETIME SQL_DECIMAL SQL_DOUBLE SQL_FLOAT SQL_GUID SQL_INTEGER SQL_INTERVAL SQL_INTERVAL_DAY3 SQL_INTERVAL_DAY_TO_HOUR8 SQL_INTERVAL_DAY_TO_MINUTE9 SQL_INTERVAL_DAY_TO_SECOND0 SQL_INTERVAL_HOUR4 SQL_INTERVAL_HOUR_TO_MINUTE1 SQL_INTERVAL_HOUR_TO_SECOND2 SQL_INTERVAL_MINUTE5 SQL_INTERVAL_MINUTE_TO_SECOND3 SQL_INTERVAL_MONTH2 SQL_INTERVAL_SECOND6 SQL_INTERVAL_YEAR1 SQL_INTERVAL_YEAR_TO_MONTH7 SQL_LONGVARBINARY SQL_LONGVARCHAR SQL_MULTISET SQL_MULTISET_LOCATOR SQL_NUMERIC SQL_REAL SQL_REF SQL_ROW SQL_SMALLINT SQL_TIME SQL_TIMESTAMP SQL_TINYINT SQL_TYPE_DATE SQL_TYPE_TIME SQL_TYPE_TIMESTAMP SQL_TYPE_TIMESTAMP_WITH_TIMEZONE SQL_TYPE_TIME_WITH_TIMEZONE SQL_UDT SQL_UDT_LOCATOR SQL_UNKNOWN_TYPE SQL_VARBINARY SQL_VARCHAR SQL_WCHAR SQL_WLONGVARCHAR SQL_WVARCHAR ); use constant SQL_ALL_TYPES => 0; use constant SQL_ARRAY => 50; use constant SQL_ARRAY_LOCATOR => 51; use constant SQL_BIGINT => (-5); use constant SQL_BINARY => (-2); use constant SQL_BIT => (-7); use constant SQL_BLOB => 30; use constant SQL_BLOB_LOCATOR => 31; use constant SQL_BOOLEAN => 16; use constant SQL_CHAR => 1; use constant SQL_CLOB => 40; use constant SQL_CLOB_LOCATOR => 41; use constant SQL_DATE => 9; use constant SQL_DATETIME => 9; use constant SQL_DECIMAL => 3; use constant SQL_DOUBLE => 8; use constant SQL_FLOAT => 6; use constant SQL_GUID => (-11); use constant SQL_INTEGER => 4; use constant SQL_INTERVAL => 10; use constant SQL_INTERVAL_DAY => 103; use constant SQL_INTERVAL_DAY_TO_HOUR => 108; use constant SQL_INTERVAL_DAY_TO_MINUTE => 109; use constant SQL_INTERVAL_DAY_TO_SECOND => 110; use constant SQL_INTERVAL_HOUR => 104; use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111; use constant SQL_INTERVAL_HOUR_TO_SECOND => 112; use constant SQL_INTERVAL_MINUTE => 105; use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113; use constant SQL_INTERVAL_MONTH => 102; use constant SQL_INTERVAL_SECOND => 106; use constant SQL_INTERVAL_YEAR => 101; use constant SQL_INTERVAL_YEAR_TO_MONTH => 107; use constant SQL_LONGVARBINARY => (-4); use constant SQL_LONGVARCHAR => (-1); use constant SQL_MULTISET => 55; use constant SQL_MULTISET_LOCATOR => 56; use constant SQL_NUMERIC => 2; use constant SQL_REAL => 7; use constant SQL_REF => 20; use constant SQL_ROW => 19; use constant SQL_SMALLINT => 5; use constant SQL_TIME => 10; use constant SQL_TIMESTAMP => 11; use constant SQL_TINYINT => (-6); use constant SQL_TYPE_DATE => 91; use constant SQL_TYPE_TIME => 92; use constant SQL_TYPE_TIMESTAMP => 93; use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95; use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94; use constant SQL_UDT => 17; use constant SQL_UDT_LOCATOR => 18; use constant SQL_UNKNOWN_TYPE => 0; use constant SQL_VARBINARY => (-3); use constant SQL_VARCHAR => 12; use constant SQL_WCHAR => (-8); use constant SQL_WLONGVARCHAR => (-10); use constant SQL_WVARCHAR => (-9); 1;Test-MockDBI-0.70/lib/Test/MockDBI/Base.pm0000644000175000017500000000021412013150506015732 0ustar affaffpackage Test::MockDBI::Base; use warnings; use strict; sub _dbi_errstr{ return shift->{errstr}; } sub _dbi_err{ return shift->{err}; } 1;Test-MockDBI-0.70/lib/Test/MockDBI/Db.pm0000644000175000017500000001556512013153136015426 0ustar affaffpackage Test::MockDBI::Db; use strict; use warnings; use Test::MockDBI::Base; use base qw(Test::MockDBI::Base); my $mockdbi = undef; sub import{ $mockdbi = $_[1]; } sub _dbi_prepare{ my ($self, $statement, $attr) = @_; # Reset both errors as per DBI Rule $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($statement); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } #Seems like DBI dies if nothing is passed as a statement #We replicate the same behaviour, but is this wrong? #Doesnt DBI->prepare honor RaiseError \ PrintError ? unless( $statement ){ die('DBI prepare: invalid number of arguments: got handle + 0, expected handle + between 1 and 2 Usage: $h->prepare($statement [, \%attr])'); } #dbh->{Statment} should contain the most recent string #passed to prepare or do event if that call failed $self->{Statement} = $statement; my $num_of_params = ($statement =~ tr/?//); my $o_retval = bless { NUM_OF_FIELDS => undef, NUM_OF_PARAMS => $num_of_params, NAME => undef, NAME_lc => undef, NAME_uc => undef, NAME_hash => undef, NAME_lc_hash => undef, NAME_uc_hash => undef, TYPE => undef, PRECISION => undef, SCALE => undef, NULLABLE => undef, CursorName => undef, Database => $self, Statement => $statement, ParamValues => {}, ParamTypes => {}, ParamArray => undef, RowsInCache => undef, _fake => { InoutParams => [] }, #Common Warn => undef, Active => undef, Executed => undef, Kids => 0, #Should always be zero for a statementhandler see DBI documentation ActiveKids => undef, CachedKids => undef, Type => 'st', ChildHandles => undef, CompatMode => undef, InactiveDestroy => undef, AutoInactiveDestroy => undef, PrintWarn => undef, PrintError => undef, RaiseError => undef, HandleError => undef, HandleSetErr => undef, ErrCount => undef, ShowErrorStatement => undef, TraceLevel => undef, FetchHashKeyName => undef, ChopBlanks => undef, LongReadLen => undef, LongTruncOk => undef, TaintIn => undef, TaintOut => undef, Taint => undef, Profile => undef, ReadOnly => undef, Callbacks => undef, }, 'DBI::st'; push( @{ $self->{ChildHandles} }, $o_retval); $self->{Kids} = scalar( @{ $self->{ChildHandles} } ); $self->{ActiveKids} = Test::MockDBI::Db::_update_active_kids($self); return $o_retval; } sub _dbi_prepare_cached{ my ($self, $statement, $attr, $if_active) = @_; $attr = {} if !$attr; # Reset both errors as per DBI Rule $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($statement); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } my $cache = $self->{CachedKids} ||= {}; my $key = do { local $^W; join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0) }; my $sth = $cache->{$key}; if($sth){ return $sth unless ($sth->{Active}); Carp::carp("prepare_cached($statement) statement handle $sth still Active") unless ($if_active ||= 0); $sth->finish if $if_active <= 1; return $sth if $if_active <= 2; } $sth = $self->prepare($statement, $attr); $cache->{$key} = $sth if $sth; return $sth; } sub _dbi_do{ my($self, $statement, $attr, @bind_values) = @_; # Reset both errors as per DBI Rule $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($statement); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } my $sth = $self->prepare($statement, $attr) or return; $sth->execute(@bind_values) or return; #Updating dbh attributes $self->{Executed} = 1; my $rows = $sth->rows; ($rows == 0) ? "0E0" : $rows; # always return true if no error } sub _dbi_commit{ my ($self) = @_; # Reset both errors as per DBI Rule $mockdbi->_clear_dbi_err_errstr($self); #The executed attribute is updated even if the #call fails $self->{Executed} = undef; #Warning is displayed even if the method fails warn "commit ineffective with AutoCommit enabled" if $self->{AutoCommit}; my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } #Updating dbh attributes $self->{AutoCommit} = 1; return 1; } sub _dbi_rollback{ my ($self) = @_; # Reset both errors as per DBI Rule $mockdbi->_clear_dbi_err_errstr($self); #The executed attribute is updated even if the #call fails $self->{Executed} = undef; #Warning is displayed even if the method fails warn "rollback ineffective with AutoCommit enabled" if $self->{AutoCommit}; my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } $self->{AutoCommit} = 1; return 1; } sub _dbi_begin_work{ my ($self) = @_; # Reset both errors as per DBI Rule $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval($self->{Statement}); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } $self->{AutoCommit} = 0; return 1; } sub _dbi_ping{ my ($self) = @_; # Reset both errors as per DBI Rule $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval(); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } return 1; } sub _dbi_disconnect{ my ($self) = @_; # Reset both errors as per DBI Rule $mockdbi->_clear_dbi_err_errstr($self); my ($status, $retval) = $mockdbi->_has_fake_retval(); if($status){ $mockdbi->_set_fake_dbi_err_errstr($self); if(ref($retval) eq 'CODE'){ return $retval->($self); } return $retval; } #Set the Active flag to false for all childhandlers foreach my $ch ( @{ $self->{ChildHandlers} } ){ $ch->{Active} = undef; } Test::MockDBI::Db::_update_active_kids($self); return 1; } #This is a helper method, and not a part of the DBI specification sub _update_active_kids{ my ($self) = @_; my $cnt = scalar(grep{ $_->{Active} } @{$self->{ChildHandles}}); $self->{ActiveKids} = $cnt; return 1; } 1;Test-MockDBI-0.70/MANIFEST.SKIP0000644000175000017500000000113412004510233013522 0ustar affaff# Test-MockDBI specific settings ^DBI.cfg # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.tmp$ \.bak$ \.new$ \.sql$ \.patch$ \.log$ \.log\.[0-9]+$ ^\. # Avoid Devel::Cover files. \bcover_db\b # Skip debian directory \bdebian\b Test-MockDBI-0.70/META.json0000664000175000017500000000247312022124715013264 0ustar affaff{ "abstract" : "Mocked DBI interface for testing purposes", "author" : [ "Mark Leighton Fisher " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150", "keywords" : [ "Test", "Mock", "DBI", "database" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-MockDBI", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "CPAN::Meta" : 0 } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : 0 } }, "runtime" : { "requires" : { "Carp" : 0, "Clone" : 0, "DBI" : 0, "File::Spec::Functions" : 0, "Scalar::Util" : 0, "Test::Differences" : 0, "Test::MockObject" : "0.14", "Test::More" : 0, "Test::Warn" : 0 } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/aff/Test-MockDBI" } }, "version" : "0.70" } Test-MockDBI-0.70/samples/0000755000175000017500000000000012022124715013277 5ustar affaffTest-MockDBI-0.70/samples/DBD-setup.pl0000755000175000017500000000113112004510233015354 0ustar affaff# Create a sample database zipcodes.* using DBD::DBM, # which ships with DBI. # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time warnings use DBI; # database interface # ------ define variables my $dbh = ""; # DBI handle # ------ create database sample table $dbh = DBI->connect("dbi:DBM:"); $dbh->do(qq{ CREATE TABLE zipcodes ( last_modified TEXT ) }); $dbh->do(qq{ INSERT INTO zipcodes VALUES ( '1970-01-01' ) }); Test-MockDBI-0.70/TODO0000755000175000017500000000046612013150506012331 0ustar affaff- Implement some sort of plugin scheme so that you can modify functionality based on the dbtype provided in the dsn. Ala DBD::mysql. This will solve the issue of different quoting. - Better tests. - Increase number of DBI methods mocked up. - Make sure more of the dbh/sth attributes works as expected. Test-MockDBI-0.70/META.yml0000664000175000017500000000137012022124715013107 0ustar affaff--- abstract: 'Mocked DBI interface for testing purposes' author: - 'Mark Leighton Fisher ' build_requires: CPAN::Meta: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150' keywords: - Test - Mock - DBI - database license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-MockDBI no_index: directory: - t - inc requires: Carp: 0 Clone: 0 DBI: 0 File::Spec::Functions: 0 Scalar::Util: 0 Test::Differences: 0 Test::MockObject: 0.14 Test::More: 0 Test::Warn: 0 resources: repository: https://github.com/aff/Test-MockDBI version: 0.70 Test-MockDBI-0.70/MANIFEST0000644000175000017500000000264412022124715012772 0ustar affaffChanges HISTORY lib/Test/MockDBI.pm lib/Test/MockDBI/Base.pm lib/Test/MockDBI/Constants.pm lib/Test/MockDBI/Db.pm lib/Test/MockDBI/St.pm Makefile.PL MANIFEST MANIFEST.SKIP README samples/DBD-setup.pl t/00-env.t t/000-use.t t/001-connect.t t/002-prepare.t t/003-ping.t t/004-execute.t t/005-fetchrow_hashref.t t/006-bind_param.t t/007-bind_param_inout.t t/008-rows.t t/009-auto_commit.t t/010-fetchrow_arrayref.t t/011-prepare_cached.t t/012-do.t t/100-set-fake-retval.t t/101-set-fake-retval-coderef.t t/102-set-inout-value.t t/103-bad_method.t t/104-bad-params.t t/800-die-on-unsupported-method.t t/bad_param-1.t t/bad_param-2.t t/bad_param-ok-2of3.t t/bad_param-ok-none.t t/coderef-array-1.t t/coderef-array-many.t t/coderef-scalar-0.t t/coderef-scalar-1.t t/coderef-scalar-many.t t/connect.t t/fetch-0.t t/fetch-empty.t t/fetchall_arrayref-0.t t/fetchall_arrayref-1.t t/fetchall_arrayref-many.t t/fetchrow_array-0.t t/fetchrow_array-1.t t/fetchrow_array-different-sql.t t/fetchrow_array-many.t t/fetchrow_arrayref-0.t t/fetchrow_arrayref-1.t t/fetchrow_arrayref-different-sql.t t/fetchrow_arrayref-many.t t/fetchrow_hashref-1.t t/fetchrow_hashref-2.t t/fetchrow_hashref-many.t t/set_rows-different-numeric.t t/set_rows-no-arg.t t/set_rows-numeric.t t/set_rows-undef.t TODO META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-MockDBI-0.70/Changes0000755000175000017500000000561212022124611013130 0ustar affaffRevision history for Perl extension Test::MockDBI. 0.70 Thu Sep 6 15:47:46 CEST 2012 - Almost completely rewritten the code - Added support for more mocked methods - Test::MockDBI now returns the correct object types (DBI::db & DBI::st) - DBI::db methods is not available throught DBI::st object and vica versa - Deleted old tests, and written new ones. - Added mockup for all dbi object attributes (Not all of them actually have a value yet) - Handle "Stringification of regexes has changed" (see perl5140delta). Both older and new version of perl should work. 0.66 Tue July 24 11:25:08 CET 2012 - The database handle returns DBI::db instead of DBI - Added the support for attributes RaiseError, PrintError and AutoCommit with implementation - Added DBI::db::bind_param_inout() and DBI::db::begin_work() - DBI::db::commit() now works, rather than only pretending to work. - Added DBI::db::rollback() - Supports call to the method err 0.65 Mon Feb 7 07:46:08 CET 2011 - Added LICENSE = perl to Makefile.PL. - Removed duplicate 'use Data::Dumper' (See cpanratings). 0.64 Tue Feb 3 13:37:20 CET 2009 - Support non-interactive testing with PERL_MM_USE_DEFAULT, and/or AUTOMATED_TESTING 0.63 Wed Dec 31 14:29:14 CET 2008 - Added support for DBI::ping (bug #14055) 0.62 Thu Dec 4 14:05:50 CET 2008 - Added support for hash-based fetch methods. - Added customization of DBI->errstr(), now undef by default. - Rewritten test suite Test::Harness style. - Added underscore prefix to private subs to fit with Pod::Coverage. 0.61 Thu Feb 3 09:28:49 EST 2005 - Fixed version number in README. - Fixed copyright dates in README. - Moved test DBD setup to samples/DBD-setup.pl from samples/sample.pl. 0.60 Thu Jan 27 17:18:47 EST 2005 - Added DBI::do() and DBI::rows(). - DBI::bind_columns() now works, rather than only pretending to work. - DBI::fetchrow() was corrected to return an array. This function is so old, it is no longer documented in the main DBI docs. - The list-returning DBI fetch*() functions now return an empty list when set_retval_array() gives them an empty list or no list. - A list consisting of 1 undef element is now returned as such by the list-returning DBI fetch*() methods. - README now talks a little about the testing configuration file, DBI.cfg. - NOTE: The Perl Cookbook, 2nd Edition, recipe 10.10 has a good explanation of list/array return values :). 0.50 Wed Dec 1 08:34:30 EST 2004 - original version; created by h2xs 1.22 with options --compat-version=5.8.0 -AXfn Test::MockDBI - Separate test program sources are now in "t-src/*.PL", with a PL_FILES directive in Makefile.PL to create the actual test programs as "t/*.pl". Test-MockDBI-0.70/t/0000755000175000017500000000000012022124715012076 5ustar affaffTest-MockDBI-0.70/t/005-fetchrow_hashref.t0000644000175000017500000000416412013150506016110 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $instance = Test::MockDBI::get_instance(); my $dbh = DBI->connect('DBI:mysql:something', 'user1', 'password1'); { #Setting up a global resultset my @expected = ( { number => 1 }, { number => 2 }, { number => 3 } ); $instance->set_retval( method => 'fetchrow_hashref', retval => \@expected ); my $sth = $dbh->prepare('SELECT * FROM sometable'); $sth->execute(); my @got = (); my $cnt = 0; while( my $row = $sth->fetchrow_hashref()){ push(@got, $row); $cnt++; } is_deeply(\@got, \@expected, "Got the expected resultset"); cmp_ok($cnt, '==', scalar(@expected), "Executed the while loop the expected number of times"); } { #Testing setting a resultset based on the sql my @expected = ( { letter => 'A' }, { letter => 'B' }, { letter => 'C' } ); my $sql = "SELECT * FROM atable"; $instance->set_retval( method => 'fetchrow_hashref', retval => \@expected, sql => $sql ); my $sth = $dbh->prepare($sql); $sth->execute(); my @got = (); my $cnt = 0; while( my $row = $sth->fetchrow_hashref()){ push(@got, $row); $cnt++; } is_deeply(\@got, \@expected, "Got the expected resultset"); cmp_ok($cnt, '==', scalar(@expected), "Executed the while loop the expected number of times"); } { #Testing that a sql resultset should have precedence over a global resultset my @expected = ( { letter => 'A' }, { letter => 'B' }, { letter => 'C' } ); my @not_expected = ( { number => 1 }, { number => 2 }, { number => 3 } ); my $sql = "SELECT * FROM atable"; $instance->set_retval( method => 'fetchrow_hashref', retval => \@expected, sql => $sql ); $instance->set_retval( method => 'fetchrow_hashref', retval => \@not_expected ); my $sth = $dbh->prepare($sql); $sth->execute(); my @got = (); my $cnt = 0; while( my $row = $sth->fetchrow_hashref()){ push(@got, $row); $cnt++; } is_deeply(\@got, \@expected, "Got the expected resultset"); cmp_ok($cnt, '==', scalar(@expected), "Executed the while loop the expected number of times"); } done_testing();Test-MockDBI-0.70/t/004-execute.t0000644000175000017500000000054112013150506014223 0ustar affaffuse warnings; use strict; use Test::More; use_ok('Test::MockDBI'); my $dbh = DBI->connect('DBI:mysql:somedatabase', 'user1', 'password1'); { my $sth = $dbh->prepare("SELECT id FROM table1 where id = ?"); ok($sth->bind_param(1, 1), "bind_param called successfully"); cmp_ok($sth->execute(), '==', -1, "Execute returned -1"); } done_testing();Test-MockDBI-0.70/t/set_rows-different-numeric.t0000755000175000017500000000217212013153136017540 0ustar affaff# Test::MockDBI DBI::rows() return value when different numeric argument # $Id: set_rows-different-numeric.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 2; # ------ define variables my $dbh = ""; # mock DBI database handle my $tmd = ""; # Test::MockDBI object # ------ numeric #rows argument $tmd = get_instance Test::MockDBI; warning_like{ $tmd->set_rows(1, "some rows", 312); } qr/set_rows is deprecated/, "Legacy warning displayed"; $dbh = DBI->connect(); my $sth = $dbh->prepare("some rows"); cmp_ok($sth->rows(),q[==], 312, q[Expect numeric value in return]); __END__ =pod =head1 AUTHOR'S NOTE We won't bother to test non-numeric arguments, as I can't see any use for them but I can't see prohibiting them either. =cut Test-MockDBI-0.70/t/fetchall_arrayref-1.t0000755000175000017500000000275212013153136016106 0ustar affaff# Test::MockDBI fetchall_arrayref() with 1-element array returned # $Id: fetchall_arrayref-1.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 5; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = ""; # return value from fetchall_arrayref() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHALL_ARRAYREF", [ [ 1016 ] ]); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); $retval = $sth->fetchall_arrayref(); ok(!defined($retval), q{Expect undef for non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHALL_ARRAYREF"); $sth->execute(); $retval = $sth->fetchall_arrayref(); ok(defined($retval), q{Expect defined for non-matching sql}); isa_ok($retval, q{ARRAY}, q{Expect array ref}); is_deeply($retval, [ [1016] ], q{Expect array ref with 1 array ref element}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/fetchrow_array-different-sql.t0000755000175000017500000000407612013153136020054 0ustar affaff# Test::MockDBI fetch*() which return an array handle multiple SQL statements. # $Id: fetchrow_array-different-sql.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; use Test::Warn; plan tests => 7; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # what we are testing # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my @retval = (); # return value from fetchrow_array() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCHROW_ARRAY", "go deep", 476); } qr/set_retval_array is deprecated/, "Legacy warning displayed"; warning_like{ $md->set_retval_array(2, "SELECT zip5_zipcode.+'Chino Hills'", "Experian stuff", 1492); } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); ok(!defined($sth->fetchrow_array()), q{Expect undef on non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAY"); $sth->execute(); @retval = $sth->fetchrow_array(); is_deeply(\@retval, [ "go deep", 476 ], "Retval"); $sth->finish(); # test non-matching sql again $sth = $dbh->prepare("STILL oTheR SQL"); $sth->execute(); ok(!defined($sth->fetchrow_array()), q{Expect undef on another non-matching sql}); $sth->finish(); # test another matching sql $sth = $dbh->prepare("SELECT zip5_zipcode FROM ziplist5 WHERE zip5_cityname = 'Chino Hills'"); $sth->execute(); @retval = $sth->fetchrow_array(); is_deeply(\@retval, ["Experian stuff", 1492], q{Expect array ("Experian stuff", 1492)}); $sth->finish(); # test non-matching sql third time $sth = $dbh->prepare("LaSt sqL"); $sth->execute(); ok(!defined($sth->fetchrow_array()), q{Expect undef on another non-matching sql}); __END__ Test-MockDBI-0.70/t/fetch-0.t0000755000175000017500000000246412013153136013521 0ustar affaff# Test::MockDBI fetch() when given empty array to return # $Id: fetch-0.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 3; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my @retval = (); # return array from fetch() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCH", ()); # empty array } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); @retval = $sth->fetch(); cmp_ok(scalar(@retval), q{==}, 0, q{Expect 0 columns for non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCH"); @retval = $sth->fetch(); cmp_ok(scalar(@retval), q{==}, 0, q{Expect 0 columns for matching sql}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/coderef-array-1.t0000755000175000017500000000255012013153136015150 0ustar affaff# Test::MockDBI fetch*() with 1-element array returned from coderef # $Id: coderef-array-1.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 3; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my @retval = (); # return value from fetchrow_array() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCHROW_ARRAY", sub { return 1054;}); } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); ok(!defined($sth->fetchrow_array()), q{Expect undef for non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAY"); $sth->execute(); @retval = $sth->fetchrow_array(); is_deeply(\@retval, [ 1054 ], q{Expect array with element 1054}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/002-prepare.t0000644000175000017500000000176712013150506014230 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); #Testing that we actually get back a sth { my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); cmp_ok(ref($dbh), 'eq', 'DBI::db', 'Ref of the database handler is DBI::db'); my $sth = $dbh->prepare('SELECT * FROM sometable WHERE id = ?'); cmp_ok(ref($sth), 'eq', 'DBI::st', 'Ref of the database handler is DBI::st'); } #Test that the statement handler has the correct NUM_OF_PARAMS set { my @testdata = ( { sql => 'Something wierd ? ? ', num => 2 }, { sql => 'SELECT one, two FROM sometable where id = ? and number = ? and is_stupid = ?', num => 3 } ); my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); cmp_ok(ref($dbh), 'eq', 'DBI::db', 'Ref of the database handler is DBI::db'); foreach my $item ( @testdata ){ my $sth = $dbh->prepare($item->{sql}); cmp_ok($sth->{NUM_OF_PARAMS}, '==', $item->{num}, 'NUM_OF_PARAMS is set to ' . $item->{num}); } } done_testing();Test-MockDBI-0.70/t/103-bad_method.t0000644000175000017500000000646612017413034014665 0ustar affaff# Test::MockDBI bad DBI method tests # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More tests => 76; # advanced testing use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # what we are testing use Test::Warn; # ------ define variables my $md = Test::MockDBI::get_instance(); { #Testing bad_method on the raw DBI package warning_like{ is($md->bad_method("connect", 2, ""), 1, q{Expect 1}); } qr/bad_method in an deprecated way/, "Legacy call to bad_method displays warning"; is(DBI->connect(), undef, "DBI connect()"); #Reset the mock object $md->reset(); } { #Testing bad_method on the database handler my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1', { AutoCommit => undef }); #AutoCommit => undef to silence warnings! cmp_ok(ref($dbh), 'eq', 'DBI::db', 'Ref of dbh is DBI::db'); my @methods = qw( disconnect prepare prepare_cached do commit rollback ); #Legacy interface foreach my $method (@methods){ warning_like{ is($md->bad_method($method, 2, ""), 1, q{Expect 1}); } qr/bad_method in an deprecated way/, "Legacy call to bad_method displays warning"; } #Executing bad methods foreach my $method (@methods){ my $retval = 1; eval('$retval = $dbh->' . $method . '();'); ok(!$retval, $method . ' failed successfully'); } $md->reset(); #New interface is($md->bad_method( method => $_ ), 1, q{Expect 1}) for(@methods); #Executing bad methods is(eval('$dbh->' . $_ . '();'), undef, $_ . ' failed successfully') for(@methods); #Executing bad methods foreach my $method (@methods){ my $retval = 1; eval('$retval = $dbh->' . $method . '();'); ok(!$retval, $method . ' failed successfully'); } $md->reset(); } { #Testing bad_method in the statement handler my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1', { AutoCommit => undef }); #AutoCommit => undef to silence warnings my $sth = $dbh->prepare('select something from somewhere where anything = ?'); my @methods = qw( rows bind_param execute finish fetchall_arrayref fetchrow_arrayref fetchrow_array ); #Legacy interface foreach my $method (@methods){ warnings_like{ is($md->bad_method($method, 2, ""), 1, q{Expect 1}); } qr/bad_method in an deprecated way/, "Legacy call to bad_method displays warning"; } #Executing bad methods foreach my $method (@methods){ my $retval = 1; eval('$retval = $sth->' . $method . '();'); ok(!$retval, $method . ' failed successfully'); } $md->reset(); #New interface is($md->bad_method( method => $_), 1, q{Expect 1}) for(@methods); #Executing bad methods foreach my $method (@methods){ my $retval = 1; eval('$retval = $sth->' . $method . '();'); ok(!$retval, $method . ' failed successfully'); } $md->reset(); } { #Testing bad_method with sql $md->bad_method( sql => qr/.*/, method => 'prepare' ); my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1', { AutoCommit => undef }); #AutoCommit => undef to silence warnings my $sth = $dbh->prepare('select something from somewhere where anything = ?'); ok(!$sth, '$sth should be undef'); $md->reset(); } done_testing(); __END__Test-MockDBI-0.70/t/006-bind_param.t0000644000175000017500000000370412013150506014663 0ustar affaffuse strict; use warnings; use Test::More; use Test::MockDBI::Constants; use_ok('Test::MockDBI'); my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); { my $sth = $dbh->prepare('SELECT name FROM sometable where id = ? OR id = ? OR age = ? OR age = ?'); ok($sth->bind_param(1, 'Donald Duck'), "bind_param called successfully"); ok($sth->bind_param(2, 'Fetter Anton'), "bind_param called successfully"); ok($sth->bind_param(3, 25, SQL_INTEGER), "bind_param called successfully"); ok($sth->bind_param(4, 30, { TYPE => SQL_INTEGER }), "bind_param called successfully"); #Check that we have bound some variables cmp_ok($sth->{ParamValues}->{1}, 'eq', 'Donald Duck', "Param bound to position 1 eq Donald Duck"); cmp_ok($sth->{ParamValues}->{2}, 'eq', 'Fetter Anton', "Param bound to position 2 eq Fetter Anton"); cmp_ok($sth->{ParamValues}->{3}, '==', 25, "Param bound to position 3 == 25"); cmp_ok($sth->{ParamValues}->{4}, '==', 30, "Param bound to position 4 == 30"); #Check that the appropriate SQL types are set is_deeply( $sth->{ParamTypes}->{1}, { TYPE => SQL_VARCHAR }, 'Param type bound to position 1 is SQL_VARCHAR'); is_deeply( $sth->{ParamTypes}->{2}, { TYPE => SQL_VARCHAR }, 'Param type bound to position 2 is SQL_VARCHAR'); is_deeply( $sth->{ParamTypes}->{3}, { TYPE => SQL_INTEGER }, 'Param type bound to position 3 is SQL_INTEGER'); is_deeply( $sth->{ParamTypes}->{4}, { TYPE => SQL_INTEGER }, 'Param type bound to position 4 is SQL_INTEGER'); } { #Test that we get the appropriate warning if we bind a param with an invalid parameter number my $sth = $dbh->prepare('SELECT name FROM sometable where id = ?'); #0 should be invalid, DBI starts bind_param starts at 1 ok(!$sth->bind_param(0, 'Donald Duck'), "bind_param called unsuccessfully"); #2 should be invalid as we only have one placeholder in the sql ok(!$sth->bind_param(2, 'Donald Duck'), "bind_param called ununsuccessfully"); } done_testing();Test-MockDBI-0.70/t/coderef-scalar-1.t0000755000175000017500000000256412013153136015304 0ustar affaff# Test::MockDBI fetch*() with 1-element array returned from coderef # $Id: coderef-scalar-1.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 4; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = undef; # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHROW", sub { return [ 1016 ]; }); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); ok(!defined($retval), q{Expect 0 columns}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); ok(defined($retval), q{Expect defined for matching sql}); is_deeply($retval, [ 1016 ], q{Expect 1 element array with value 1016}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/fetchrow_arrayref-0.t0000755000175000017500000000260512013153136016141 0ustar affaff# Test::MockDBI fetchrow_arrayref() when given no array to return # $Id: fetchrow_arrayref-0.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 3; # ------ define variables my $dbh = undef; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = undef; # return array from fetchrow_arrayref() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHROW_ARRAYREF"); # return nothing (3rd arg) } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $retval = $sth->fetchrow_arrayref(); ok(!defined($retval), q{Expect undef with non-matching sql from fetchrow_arrayref}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAYREF"); $retval = $sth->fetchrow_arrayref(); ok(!defined($retval), q{Expect undef with matching sql from fetchrow_arrayref}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/012-do.t0000644000175000017500000000050612013150506013163 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $dbh = DBI->connect('DBI:mydb:somedb', 'user1', 'password1'); { #Do should default return -1 (Return value of rows) my $retval = $dbh->do('INSERT INTO something VALUES(1)'); cmp_ok($retval, '==', -1, '$dbh->do returned -1'); } done_testing();Test-MockDBI-0.70/t/fetchrow_arrayref-1.t0000755000175000017500000000265512013153136016147 0ustar affaff# Test::MockDBI fetchrow_arrayref() with 1-element array returned # $Id: fetchrow_arrayref-1.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 4; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = undef; # return array from fetchrow_arrayref() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHROW_ARRAYREF", [ 42 ]); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $retval = $sth->fetchrow_arrayref(); $sth->execute(); ok(!defined($retval), q{Expect 0 columns}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAYREF"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); ok(defined($retval), q{Expect 1 column in row}); is_deeply($retval, [ 42 ], q{Expect 1st column in row to contain 42}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/104-bad-params.t0000644000175000017500000000207312013153136014575 0ustar affaffuse strict; use warnings; use Test::More; use Test::Warn; use_ok('Test::MockDBI'); my $mockinst = Test::MockDBI::get_instance(); my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); { my $sql = 'SELECT id FROM db WHERE id < ?'; my $sth = $dbh->prepare($sql); #Setting 10 as a bad parameter ok($mockinst->bad_param( p_value => 10, sql => $sql), "Successfully set 10 to be a bad_param"); ok(!$sth->bind_param(1, 10), "bind_param fails for value 10"); ok($sth->bind_param(1, 11), "bind_param succeeds for value 11"); } { #Checking the legacy interface my $sql = 'SELECT id FROM db WHERE id < ?'; my $sth = $dbh->prepare($sql); #Setting 10 as a bad parameter warning_like{ ok($mockinst->bad_param(1, 1, 10), "Successfully set 10 to be a bad_param"); } qr/You have called bad_param in an deprecated way. Please consult the documentation/, "Warning displayed for legacy interface"; ok(!$sth->bind_param(1, 10), "bind_param fails for value 10"); ok($sth->bind_param(1, 11), "bind_param succeeds for value 11"); } done_testing();Test-MockDBI-0.70/t/fetchrow_array-0.t0000755000175000017500000000250212013153136015440 0ustar affaff# Test::MockDBI fetchrow_array() when given no array to return # $Id: fetchrow_array-0.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 3; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my @retval = (); # return array from fetchrow_array() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCHROW_ARRAY"); # return nothing (3rd arg) } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); @retval = $sth->fetchrow_array(); cmp_ok(scalar(@retval), q{==}, 0, q{Expect 0}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAY"); @retval = $sth->fetchrow_array(); cmp_ok(scalar(@retval), q{==}, 0, q{Expect 0}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/set_rows-undef.t0000755000175000017500000000170012013153136015227 0ustar affaff# Test::MockDBI DBI::rows() return value when undef argument # $Id: set_rows-undef.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 2; # ------ define variables my $dbh = ""; # mock DBI database handle my $tmd = ""; # Test::MockDBI object # ------ undef #rows argument $tmd = get_instance Test::MockDBI; warning_like{ $tmd->set_rows(1, "some rows", undef); } qr/set_rows is deprecated/, "Legacy warning displayed"; $dbh = DBI->connect(); my $sth = $dbh->prepare("some rows"); ok(!defined($sth->rows()), q{Expect rows() to be undef)}); __END__ Test-MockDBI-0.70/t/00-env.t0000755000175000017500000000053112013153136013271 0ustar affaff# $Id: 00-env.t 245 2008-12-04 13:00:40Z aff $ use strict; use warnings; use Config; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 1; use_ok( 'Test::MockDBI' ); diag( "Testing Test::MockDBI $Test::MockDBI::VERSION, Perl $], $^X, archname=$Config{archname}, byteorder=$Config{byteorder}" ); __END__ Test-MockDBI-0.70/t/bad_param-ok-none.t0000755000175000017500000000412512013153136015541 0ustar affaff# Test making DBI parameters bad # $Id: bad_param-ok-none.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Data::Dumper; use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # what we are testing plan tests => 13; # ------ define variables my $dbh = undef; # mock DBI database handle my $md = undef; # Test::MockDBI instance my @retval = (); # return array from fetchrow_array() my $select = undef; # DBI SQL SELECT statement handle $md = Test::MockDBI::get_instance(); isa_ok($md, q{Test::MockDBI}, q{Expect a Test::MockDBI reference}); # Set 2nd param bad (In mode --dbitest=2) warning_like{ like($md->bad_param(2, 2, "noblesville"), qr/^\d+$/, q{Expect a positive integer (bad_param))}); } qr/You have called bad_param in an deprecated way/, "Legacy warning displayed"; warning_like{ like($md->set_retval_scalar(2, "other SQL", [42]), qr/^\d+$/, q{Expect a positive integer (set_retval_scalar))}); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # Connect and prepare $dbh = DBI->connect("", "", ""); isa_ok($dbh, q{DBI::db}, q{Expect a DBI::db reference}); $select = $dbh->prepare("other SQL ? ? ?"); isa_ok($select, q{DBI::st}, q{Expect a DBI::st reference}); # Bind, execute and fetch is($select->bind_param(1, "46062"), 1, q{Expect 1 (bind_param 1))}); is($select->bind_param(2, "Noblesville"), 1, q{Expect 1 (bind_param 2 - note case sensitive!))}); is($select->bind_param(3, "IN"), 1, q{Expect 1 (bind_param 3))}); is($select->execute(), -1, q{Expect -1 (execute 1))}); cmp_ok($select->fetchrow_arrayref()->[0], q{==}, 42, q{Expect row->[0] == 42 since no params are bad}); is($select->finish(), 1, "finish()"); __END__ =pod =head1 TEST COMMENT This checks that setting the param 'noblesville' bad does not affect the param 'Noblesville'. =cut Test-MockDBI-0.70/t/coderef-scalar-many.t0000755000175000017500000000260512013153136016104 0ustar affaff# Test::MockDBI fetch*() with many-element array returned from coderef # $Id: coderef-scalar-many.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 4; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = undef; # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHROW", sub { return [ 1016, 1066 ]; }); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); ok(!defined($retval), q{Expect 0 columns}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); ok(defined($retval), q{Expect defined for matching sql}); is_deeply($retval, [ 1016, 1066 ], q{Expect 2 element array [ 1016, 1066 ]}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/009-auto_commit.t0000644000175000017500000000242712013153136015115 0ustar affaffuse strict; use warnings; use Test::More; use Test::Warn; use_ok('Test::MockDBI'); { #AutoCommit should reset after commit \ rollback calls my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); isa_ok($dbh, 'DBI::db'); cmp_ok($dbh->{AutoCommit}, '==', 1, 'AutoCommit defaults to 1'); $dbh->begin_work(); cmp_ok($dbh->{AutoCommit}, '==', 0, 'AutoCommit is 0'); $dbh->commit(); cmp_ok($dbh->{AutoCommit}, '==', 1, 'AutoCommit is 1'); $dbh->begin_work(); cmp_ok($dbh->{AutoCommit}, '==', 0, 'AutoCommit is 0'); $dbh->rollback(); cmp_ok($dbh->{AutoCommit}, '==', 1, 'AutoCommit is 1'); } { #Should be able to set AutoCommit on init my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1', { AutoCommit => 0 }); cmp_ok($dbh->{AutoCommit}, '==', 0, "AutoCommit is turned off"); } { #DBI should display a warning on commit without autocommit my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); warning_like{ $dbh->commit(); } qr/commit ineffective with AutoCommit enabled/, "commit displays warning when autocommit is enabled"; warning_like{ $dbh->rollback(); } qr/rollback ineffective with AutoCommit enabled/, "rollback displays warning when autocommit is enabled"; } done_testing();Test-MockDBI-0.70/t/001-connect.t0000644000175000017500000000221212013153136014206 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $mockinst = Test::MockDBI::get_instance(); #Testing that we actually get back a dbh { my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); cmp_ok(ref($dbh), 'eq', 'DBI::db', 'Ref of the database handler is DBI::db'); } #Testing that the connect attributes are correctly set { my %attr = ( AutoCommit => 1, RaiseError => 1, PrintError => 1 ); my $dbh = DBI->connect('DBI:Db2:somedb', 'user1', 'password1', \%attr); cmp_ok(ref($dbh), 'eq', 'DBI::db', 'Ref of the database handler is DBI::db'); foreach my $key (keys %attr){ cmp_ok($dbh->{$key}, '==', $attr{$key}, $key . ' is successfully set to ' . $attr{$key}); } } { #Check that we can set a fake retval $mockinst->bad_method( method => 'connect' ); my $dbh = DBI->connect(); #$dbh should now be undef ok(!$dbh, '$dbh is undef'); } { #Check that we can set a fake retval to a coderef $mockinst->set_retval( method => 'connect', retval => sub{ return 42; }); my $dbh = DBI->connect(); #$dbh should now be 42 cmp_ok($dbh, '==', 42, '$dbh should now be 42'); } done_testing();Test-MockDBI-0.70/t/set_rows-numeric.t0000755000175000017500000000171312013153136015574 0ustar affaff# Test::MockDBI DBI::rows() return value when numeric argument # $Id: set_rows-numeric.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 2; # ------ define variables my $dbh = ""; # mock DBI database handle my $tmd = ""; # Test::MockDBI object # ------ numeric #rows argument $tmd = get_instance Test::MockDBI; warning_like{ $tmd->set_rows(1, "some rows", 42); } qr/set_rows is deprecated/, "Legacy warning displayed"; $dbh = DBI->connect(); my $sth = $dbh->prepare("some rows"); cmp_ok($sth->rows(),q[==], 42, q[Expect numeric value in return]); __END__ Test-MockDBI-0.70/t/100-set-fake-retval.t0000644000175000017500000000731412013153136015557 0ustar affaffuse strict; use warnings; use Test::More; use Test::Warn; use_ok('Test::MockDBI'); my $instance = Test::MockDBI::get_instance(); my %methods = ( 'DBI::db' => ['prepare', 'prepare_cached', 'do', 'commit', 'rollback', 'begin_work', 'ping', 'disconnect'], 'DBI::st' => ['bind_param', 'bind_param_inout', 'execute', 'fetchrow_arrayref', 'fetchrow_array', 'fetchrow_hashref', 'fetchall_arrayref', 'finish', 'rows'] ); my $dbh = DBI->connect('DBI:mydb:somedb', 'user1', 'password1', { AutoCommit => undef } ); #AutoCommit to silence warnings! my $sth = $dbh->prepare('SELECT something FROM sometable'); $sth->execute(); #Make sure its executed { #Testing that we can set the returnvalue to plain undef #Testing the databasehandler foreach my $method ( @{ $methods{'DBI::db'} } ){ #Setting a fake retval for the prepare method $instance->set_retval( method => $method, retval => undef ); my $retval = $dbh->$method(); ok(!$retval, $method . ' returned undef'); } #Testing the statementhandler foreach my $method ( @{ $methods{'DBI::st'} } ){ #Setting a fake retval for the prepare method $instance->set_retval( method => $method, retval => undef); my $retval = $sth->$method(); ok(!$retval, $method . ' returned undef'); } #Resetting the mock instance $instance->reset(); } { #Testing that we can set the returnvalue and custom err and errstr #Testing the databasehandler foreach my $method ( @{ $methods{'DBI::db'} } ){ my %args = ( method => $method, retval => undef, err => 99, errstr => 'Custom DBI error' ); #Setting a fake retval for the prepare method $instance->set_retval( %args ); my $retval = $dbh->$method(); ok(!$retval, $method . ' returned undef'); cmp_ok($dbh->err, '==', $args{err}, '$sth->err is ' . $args{err}); cmp_ok($dbh->errstr, 'eq', $args{errstr}, '$sth->errstr is ' . $args{errstr}); } #Testing the statementhandler foreach my $method ( @{ $methods{'DBI::st'} } ){ my %args = ( method => $method, retval => undef, err => 99, errstr => 'Custom DBI error' ); #Setting a fake retval for the prepare method $instance->set_retval( %args ); my $retval = $sth->$method(); ok(!$retval, $method . ' returned undef'); cmp_ok($sth->err, '==', $args{err}, '$sth->err is ' . $args{err}); cmp_ok($sth->errstr, 'eq', $args{errstr}, '$sth->errstr is ' . $args{errstr}); } $instance->reset(); } { #Setting a fake retval should fail if no method is provided my %args = ( retval => undef, err => 99, errstr => 'Custom DBI error' ); warning_like{ ok(!$instance->set_retval( %args ), "set_retval fails without a method"); } qr/No method provided/, "set_retval displays warning on no method"; } { #Method must be a scalar string my %args = ( method => sub{ return 'somemethod';}, retval => undef, err => 99, errstr => 'Custom DBI error' ); warning_like{ ok(!$instance->set_retval( %args ), "set_retval fails with an invalid method"); } qr/Parameter method must be a scalar string/, "set_retval displays warning on invalid method"; } { #If provided sql must be a scalar string my %args = ( method => 'prepare', sql => ['sql'], retval => undef, err => 99, errstr => 'Custom DBI error' ); warning_like{ ok(!$instance->set_retval( %args ), "set_retval fails with an invalid sql"); } qr/Parameter SQL must be a scalar string/, "set_retval displays warning on invalid sql"; } { #A retval must be provided my %args = ( method => 'prepare', err => 99, errstr => 'Custom DBI error' ); warning_like{ ok(!$instance->set_retval( %args ), "set_retval fails without a retval"); } qr/No retval provided/, "set_retval displays warning when called without a retval"; } done_testing();Test-MockDBI-0.70/t/fetchrow_hashref-1.t0000755000175000017500000000247312013153136015752 0ustar affaff# $Id: fetchrow_hashref-1.t 236 2008-12-04 10:28:12Z aff $ use strict; use warnings; # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=42"; } use Data::Dumper; use Test::More; use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local version of Test::MockDBI use Test::MockDBI; plan tests => 4; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $hashref = undef; # ------ set up return values for DBI fetchrow_hashref() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(42, "FETCHROW_HASHREF", { key => 'value' }); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); $hashref = $sth->fetchrow_hashref(); ok(!defined($hashref), q{Expect fetchrow_hashref to return undefined value for non-matching sql}); $sth->finish(); # matching sql $sth = $dbh->prepare("FETCHROW_HASHREF"); $sth->execute(); $hashref = $sth->fetchrow_hashref(); isa_ok($hashref, q{HASH}, q{Expect fetchrow_hashref to return a HASH ref}) or diag(q{hashref:}.Dumper($hashref)); is_deeply($hashref, { key => 'value' }, q{Expect fetchrow_hashref to return { key => value }}); __END__ Test-MockDBI-0.70/t/fetchall_arrayref-0.t0000755000175000017500000000247712013153136016111 0ustar affaff# Test::MockDBI fetchall_arrayref() when given no array to return # $Id: fetchall_arrayref-0.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 3; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = ""; # return value from fetchall_arrayref() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCHALL_ARRAYREF"); } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $retval = $sth->fetchall_arrayref(); ok(!defined($retval), q{Expect undef for non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHALL_ARRAYREF"); $retval = $sth->fetchall_arrayref(); ok(!defined($retval), q{Expect defined for non-matching sql}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/coderef-array-many.t0000755000175000017500000000264412013153136015760 0ustar affaff# Test::MockDBI fetch*() with many-element array returned from coderef # (for our purposes, 2 == many) # $Id: coderef-array-many.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 3; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my @retval = (); # return value from fetchrow_array() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCHROW_ARRAY", sub { return (1054, 1066); }); } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); ok(!defined($sth->fetchrow_array()), q{Expect undef for non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAY"); $sth->execute(); @retval = $sth->fetchrow_array(); is_deeply(\@retval, [ 1054, 1066 ], q{Expect array with element 1054, 1066}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/007-bind_param_inout.t0000644000175000017500000000602512013150506016101 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $mockdbi = Test::MockDBI::get_instance(); my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); isa_ok($dbh, 'DBI::db'); { #Checking that bind_param_inout works my $number = 10; #The sql to be used my $sql = 'CALL PROCEDURE update_number(?)'; #Setting the retval for the inout parameter #This should ensure that $number is 15 after execute is called $mockdbi->set_inout_value($sql, 1, 15); my $sth = $dbh->prepare($sql); $sth->bind_param_inout(1, \$number); $sth->execute(); cmp_ok($number, '==', 15, '$number should be 15'); } { #Having a mixture of normal params and inout params my $inout1 = 10; my $inout2 = 20; my $sql = 'CALL PROCEDURE switchandmultiply(?, ?, ?)'; #Setting the retval for the inout parameter #This should ensure that $inout1 is 40 after execute is called $mockdbi->set_inout_value($sql, 1, 40); #This should ensure that $inout2 is 20 after execute is called $mockdbi->set_inout_value($sql, 3, 20); my $sth = $dbh->prepare($sql); $sth->bind_param_inout(1, \$inout1); $sth->bind_param(2, 2); $sth->bind_param_inout(3, \$inout2); $sth->execute(); cmp_ok($inout1, '==', 40, '$inout1 == 40'); cmp_ok($inout2, '==', 20, '$inout2 == 20'); } { #Bind param should die if it has to few parameters my $sth = $dbh->prepare('CALL something(?, ?)'); eval{ #No parameters provided. DBI dies $sth->bind_param_inout(); }; ok($@, '$@ is set'); like($@, qr/bind_param_inout: invalid number of arguments/, "Correct error thrown"); } { #bind_param_inout should return undef if $p_num is a non digit my $sth = $dbh->prepare('CALL something(?, ?)'); my $inout = 'something'; #$p_num is a non digit ok(!$sth->bind_param_inout('asdf', \$inout), 'Return undef on non-digit $p_num'); cmp_ok($sth->err, '==', 16, '$sth->err is set to 16'); cmp_ok($sth->errstr, 'eq', 'Illegal parameter number', '$sth->errstr is set to \'llegal parameter number\''); } { #bind_param_inout should return undef if we try to bind to many values my $sth = $dbh->prepare('CALL something(?, ?)'); my $inout1 = 'something'; my $inout2 = 'somethingelse'; my $inout3 = 'somethingelseelse'; #$p_num is a non digit ok($sth->bind_param_inout(1, \$inout1), 'bind_param_inout #1'); ok($sth->bind_param_inout(2, \$inout2), 'bind_param_inout #2'); ok(!$sth->bind_param_inout(3, \$inout3), 'bind_param_inout #3 fails'); cmp_ok($sth->err, '==', 16, '$sth->err is set to 16'); cmp_ok($sth->errstr, 'eq', 'Illegal parameter number', '$sth->errstr is set to \'llegal parameter number\''); } { #The bind_param_inout $bind_value must be a scalar ref my $sth = $dbh->prepare('CALL something(?, ?)'); eval{ $sth->bind_param_inout(1, 'something'); }; ok($@, '$@ is set - dies on bind_param_inout not being scalar ref'); like($@, qr/bind_param_inout needs a reference to a scalar value/, "Error is bind_param_inout needs a reference to a scalar value") } done_testing();Test-MockDBI-0.70/t/011-prepare_cached.t0000644000175000017500000000255012013150506015506 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $mockinst = Test::MockDBI::get_instance(); my $dbh = DBI->connect('DBI:somedb:something', 'user1', 'password1'); { #Without attributes my $sth1 = $dbh->prepare_cached('select id from users'); cmp_ok(ref($sth1), 'eq', 'DBI::st', 'Statement handler #1 is a DBI::st'); my $sth2 = $dbh->prepare_cached('select id from users'); cmp_ok(ref($sth2), 'eq', 'DBI::st', 'Statement handler #2 is a DBI::st'); cmp_ok($sth1, 'eq', $sth2, "$sth1 eq $sth2"); my $sth3 = $dbh->prepare_cached('select id from users where id = ?'); cmp_ok(ref($sth3), 'eq', 'DBI::st', 'Statement handler #3 is a DBI::st'); cmp_ok($sth2, 'ne', $sth3, "$sth2 ne $sth3"); } { #With attributes my $sth1 = $dbh->prepare_cached('select id from users', { something => 1 }); cmp_ok(ref($sth1), 'eq', 'DBI::st', 'Statement handler #1 is a DBI::st'); my $sth2 = $dbh->prepare_cached('select id from users', { something => 1 }); cmp_ok(ref($sth2), 'eq', 'DBI::st', 'Statement handler #2 is a DBI::st'); cmp_ok($sth1, 'eq', $sth2, "$sth1 eq $sth2"); my $sth3 = $dbh->prepare_cached('select id from users', { somethingelse => 1 }); cmp_ok(ref($sth3), 'eq', 'DBI::st', 'Statement handler #3 is a DBI::st'); cmp_ok($sth1, 'ne', $sth3, "$sth1 ne $sth3"); } done_testing();Test-MockDBI-0.70/t/fetch-empty.t0000755000175000017500000000244212013153136014514 0ustar affaff# Test::MockDBI fetch() when given no array to return # $Id: fetch-empty.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 3; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my @retval = (); # return array from fetch() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCH"); } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); @retval = $sth->fetch(); cmp_ok(scalar(@retval), q{==}, 0, q{Expect 0 columns for non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCH"); @retval = $sth->fetch(); cmp_ok(scalar(@retval), q{==}, 0, q{Expect 0 columns for matching sql}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/set_rows-no-arg.t0000755000175000017500000000166412013153136015322 0ustar affaff# Test::MockDBI DBI::rows() return value when no argument # $Id: set_rows-no-arg.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 2; # ------ define variables my $dbh = ""; # mock DBI database handle my $tmd = ""; # Test::MockDBI object # ------ no #rows argument $tmd = get_instance Test::MockDBI; warning_like{ $tmd->set_rows(1, "some rows"); } qr/set_rows is deprecated/, "Legacy warning displayed"; $dbh = DBI->connect(); my $sth = $dbh->prepare("some rows"); ok(!defined($sth->rows()), q{Expect rows() to be undef)}); __END__ Test-MockDBI-0.70/t/fetchrow_hashref-many.t0000755000175000017500000000417112013153136016553 0ustar affaff# $Id: fetchrow_hashref-many.t 236 2008-12-04 10:28:12Z aff $ use strict; use warnings; # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } use Data::Dumper; use Test::More; use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local version of Test::MockDBI use Test::MockDBI; plan tests => 11; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $hashref = undef; # ------ set up return values for DBI fetchrow_hashref() methods my $arrayref = [ { key1line1 => 'value1', key2line1 => 'value2' }, { key1line2 => 'value3', key2line2 => 'value4' }, { key1line3 => 'value5', key2line3 => 'value6' }, ]; $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHROW_HASHREF", sub { shift @$arrayref }); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; my $sth = $dbh->prepare("FETCHROW_HASHREF"); $sth->execute(); # row 1 $hashref = $sth->fetchrow_hashref(); ok($hashref, q{Expect fetchrow_hashref to return true for first row}); isa_ok($hashref, q{HASH}, q{Expect fetchrow_hashref to return a HASH ref first row}); is_deeply( $hashref, { key1line1 => 'value1', key2line1 => 'value2' }, q{Expect key value pairs line 1} ); # row 2 $hashref = $sth->fetchrow_hashref(); ok($hashref, q{Expect fetchrow_hashref to return true for second row}); isa_ok($hashref, q{HASH}, q{Expect fetchrow_hashref to return a HASH ref second row}); is_deeply( $hashref, { key1line2 => 'value3', key2line2 => 'value4' }, q{Expect key value pairs line 2} ); # row 3 $hashref = $sth->fetchrow_hashref(); ok($hashref, q{Expect fetchrow_hashref to return true for third row}); isa_ok($hashref, q{HASH}, q{Expect fetchrow_hashref to return a HASH ref second row}); is_deeply( $hashref, { key1line3 => 'value5', key2line3 => 'value6' }, q{Expect key value pairs line 3} ); # row 4 - expected to be undefined $hashref = $sth->fetchrow_hashref(); ok(!$hashref, q{Expect fetchrow_hashref to return false the fourth time}) or diag(q{rv:}.Dumper($hashref)); __END__ Test-MockDBI-0.70/t/010-fetchrow_arrayref.t0000644000175000017500000000407112013150506016274 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $instance = Test::MockDBI::get_instance(); my $dbh = DBI->connect('DBI:mysql:something', 'user1', 'password1'); { #Setting up a global resultset my @expected = ( [1, 2, 3], [4, 5, 6], [7, 8, 9] ); $instance->set_retval( method => 'fetchrow_arrayref', retval => \@expected ); my $sth = $dbh->prepare('SELECT * FROM sometable'); $sth->execute(); my @got = (); my $cnt = 0; while( my $row = $sth->fetchrow_arrayref()){ push(@got, $row); $cnt++; } is_deeply(\@got, \@expected, "Got the expected resultset"); cmp_ok($cnt, '==', scalar(@expected), "Executed the while loop the expected number of times"); } { #Testing setting a resultset based on the sql my @expected = ( [1, 2, 3], [4, 5, 6], [7, 8, 9] ); my $sql = "SELECT * FROM atable"; $instance->set_retval( method => 'fetchrow_arrayref', retval => \@expected, sql => $sql ); my $sth = $dbh->prepare($sql); $sth->execute(); my @got = (); my $cnt = 0; while( my $row = $sth->fetchrow_arrayref()){ push(@got, $row); $cnt++; } is_deeply(\@got, \@expected, "Got the expected resultset"); cmp_ok($cnt, '==', scalar(@expected), "Executed the while loop the expected number of times"); } { #Testing that a sql resultset should have precedence over a global resultset my @expected = ( [1, 2, 3], [4, 5, 6], [7, 8, 9] ); my @not_expected = ( ['A', 'B', 'C'], ['D', 'E', 'F'], ['G', 'H', 'J'] ); my $sql = "SELECT * FROM atable"; $instance->set_retval( method => 'fetchrow_arrayref', retval => \@expected, sql => $sql ); $instance->set_retval( method => 'fetchrow_arrayref', retval => \@not_expected ); my $sth = $dbh->prepare($sql); $sth->execute(); my @got = (); my $cnt = 0; while( my $row = $sth->fetchrow_arrayref()){ push(@got, $row); $cnt++; } is_deeply(\@got, \@expected, "Got the expected resultset"); cmp_ok($cnt, '==', scalar(@expected), "Executed the while loop the expected number of times"); } done_testing();Test-MockDBI-0.70/t/fetchrow_arrayref-different-sql.t0000755000175000017500000000421612013153136020545 0ustar affaff# Test::MockDBI fetch*() which return an array handle multiple SQL statements. # $Id: fetchrow_arrayref-different-sql.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; use Test::Warn; plan tests => 7; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # what we are testing # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = ""; # return value from fetchrow_arrayref() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHROW_ARRAYREF", [ "go deep", 476 ]); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; warning_like{ $md->set_retval_scalar(2, "SELECT zip5_zipcode.+'Chino Hills'", [ "Experian stuff", 1492 ]); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); ok(!defined($sth->fetchrow_arrayref()), q{Expect undef on non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAYREF"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); is_deeply($retval, [ "go deep", 476 ], q{Expect array ref [ "go deep", 476 ]}); $sth->finish(); # test non-matching sql again $sth = $dbh->prepare("STILL oTheR SQL"); $sth->execute(); ok(!defined($sth->fetchrow_arrayref()), q{Expect undef on another non-matching sql}); $sth->finish(); # test another matching sql $sth = $dbh->prepare("SELECT zip5_zipcode FROM ziplist5 WHERE zip5_cityname = 'Chino Hills'"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); is_deeply($retval, ["Experian stuff", 1492], q{Expect array ("Experian stuff", 1492)}); $sth->finish(); # test non-matching sql third time $sth = $dbh->prepare("LaSt sqL"); $sth->execute(); ok(!defined($sth->fetchrow_arrayref()), q{Expect undef on another non-matching sql}); __END__ Test-MockDBI-0.70/t/fetchrow_array-1.t0000755000175000017500000000265012013153136015445 0ustar affaff# Test::MockDBI fetchrow_array() with 1-element array returned # $Id: fetchrow_array-1.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 4; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my @retval = (); # return array from fetchrow_array() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCHROW_ARRAY", 42); } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); @retval = $sth->fetchrow_array(); cmp_ok(scalar(@retval), q{==}, 0, q{Expect 0 columns}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAY"); $sth->execute(); @retval = $sth->fetchrow_array(); cmp_ok(scalar(@retval), q{==}, 1, q{Expect 1 column in row}); cmp_ok($retval[0], q{==}, 42, q{Expect 1st column in row to contain 42}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/fetchrow_arrayref-many.t0000755000175000017500000000277212013153136016753 0ustar affaff# Test::MockDBI fetchrow_arrayref() with many-element array returned # (For our purposes, 2 eq many.) # $Id: fetchrow_arrayref-many.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 4; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = undef; # return array from fetchrow_arrayref() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHROW_ARRAYREF", [ "go deep", 476 ]); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); ok(!defined($retval), q{Expect 0 columns}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAYREF"); $sth->execute(); $retval = $sth->fetchrow_arrayref(); ok(defined($retval), q{Expect 1 column in row}); is_deeply($retval, [ "go deep", 476 ], q{Expect 1st column in row to contain [ "go deep", 476 ]}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/fetchrow_hashref-2.t0000755000175000017500000000314012013153136015743 0ustar affaff# $Id: fetchrow_hashref-2.t 236 2008-12-04 10:28:12Z aff $ use strict; use warnings; # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=42"; } use Data::Dumper; use Test::More; use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local version of Test::MockDBI use Test::MockDBI; plan tests => 7; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $hashref = undef; # ------ set up return values for DBI fetchrow_hashref() methods $dbh = DBI->connect("", "", ""); my $arref = [ { key1 => 'value1' }, { key2 => 'value2' }, ]; warning_like{ $md->set_retval_scalar(42, "FETCHROW_HASHREF", sub { shift @$arref }); # shift off on hashref each time } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; my $sth = $dbh->prepare("FETCHROW_HASHREF"); ok($sth, "sth is defined"); # row 1 $sth->execute(); my $rv = $sth->fetchrow_hashref(); isa_ok($rv, q{HASH}, q{Expect fetchrow_hashref to return a HASH ref the first time}) or diag(q{rv:}.Dumper($rv)); is_deeply($rv, { key1 => 'value1' }, q{Expect { key1 => 'value1' }}); # row 2 $rv = $sth->fetchrow_hashref(); isa_ok($rv, q{HASH}, q{Expect fetchrow_hashref to return a HASH ref the second time}) or diag(q{rv:}.Dumper($rv)); is_deeply($rv, { key2 => 'value2' }, q{Expect { key2 => 'value2' }}) or diag(q{rv:}.Dumper($rv)); # row 3 - undefined $hashref = $sth->fetchrow_hashref(); ok(!$hashref, q{Expect fetchrow_hashref to return false the third time}) or diag(q{rv:}.Dumper($hashref)); __END__ Test-MockDBI-0.70/t/000-use.t0000644000175000017500000000021712013150506013351 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); use_ok('Test::MockDBI::Db'); use_ok('Test::MockDBI::St'); done_testing();Test-MockDBI-0.70/t/fetchall_arrayref-many.t0000755000175000017500000000313012013153136016701 0ustar affaff# Test::MockDBI fetchall_arrayref() with many-element array returned # (For our purposes, 2 eq many.) # $Id: fetchall_arrayref-many.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 5; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = ""; # return value from fetchall_arrayref() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCH", [ [ "go deep", 476 ], [ 1066, "Yellow Pages" ] ]); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); $retval = $sth->fetchall_arrayref(); ok(!defined($retval), q{Expect undef for non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHALL_ARRAYREF"); $sth->execute(); $retval = $sth->fetchall_arrayref(); ok(defined($retval), q{Expect defined for non-matching sql}); isa_ok($retval, q{ARRAY}, q{Expect array ref}); is_deeply( $retval, [ [ "go deep", 476 ], [ 1066, "Yellow Pages" ] ], q{Expect array ref with 2 array ref elements} ); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/bad_param-ok-2of3.t0000755000175000017500000000356312013153136015360 0ustar affaff# Test making DBI parameters bad # $Id: bad_param-ok-2of3.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Data::Dumper; use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # what we are testing plan tests => 12; # ------ define variables my $dbh = undef; # mock DBI database handle my $md = undef; # Test::MockDBI instance my @retval = (); # return array from fetchrow_array() my $select = undef; # DBI SQL SELECT statement handle $md = Test::MockDBI::get_instance(); isa_ok($md, q{Test::MockDBI}, q{Expect a Test::MockDBI reference}); # Set 2nd param bad (In mode --dbitest=2) warning_like{ like($md->bad_param(2, 2, "noblesville"), qr/^\d+$/, q{Expect a positive integer (bad_param))}); } qr/You have called bad_param in an deprecated way/, "Legacy warning displayed"; warning_like{ like($md->set_retval_scalar(2, "other SQL", [42]), qr/^\d+$/, q{Expect a positive integer (set_retval_scalar))}); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # Connect and prepare $dbh = DBI->connect("", "", ""); isa_ok($dbh, q{DBI::db}, q{Expect a DBI::db reference}); $select = $dbh->prepare("other SQL ? ? ?"); isa_ok($select, q{DBI::st}, q{Expect a DBI::st reference}); # Bind, execute and fetch is($select->bind_param(1, "46062"), 1, q{Expect 1 (bind_param 1))}); is($select->bind_param(2, "noblesville"), undef, q{Expect undef "bad" (bind_param 2))}); is($select->bind_param(3, "IN"), 1, q{Expect 1 (bind_param 3))}); cmp_ok($select->execute(), 'eq', '0E0', q{Expect 0E0 (execute 1))}); is($select->finish(), 1, "finish()"); __END__ Test-MockDBI-0.70/t/102-set-inout-value.t0000644000175000017500000000121712013150506015622 0ustar affaffuse strict; use warnings; use Test::More; use Test::Warn; use_ok('Test::MockDBI'); my $mockinst = Test::MockDBI::get_instance(); { #Call should fail if no sql is provided warning_like{ ok(!$mockinst->set_inout_value(undef, 1, 15), "undef provided as sql"); } qr/Parameter SQL must be a scalar string/, "Calling set_inout_value without sql generates warning"; } { #Call should fail if no sql is provided warning_like{ ok(!$mockinst->set_inout_value('CALL proc(?)', 'asdf'), "p_num is not numeric"); } qr/Parameter p_num must be numeric/, "Calling set_inout_value without a numeric p_num generates a warning"; } done_testing();Test-MockDBI-0.70/t/connect.t0000755000175000017500000000124012013153136013713 0ustar affaff# DBI connect() for mock DBI. # $Id: connect.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More tests => 2; # advanced testing use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # what we are testing # ------ define variables my $dbh = DBI->connect("universe", "mortal", "root-password"); isa_ok($dbh, q{DBI::db}, q{Expect a DBI::db reference}); is($dbh->disconnect(), 1, q{Expect disconnect() == 1}); __END__ Test-MockDBI-0.70/t/003-ping.t0000644000175000017500000000035212013150506013515 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); #Testing that ping is available { ok($dbh->can('ping'), "Ping is available"); } done_testing();Test-MockDBI-0.70/t/coderef-scalar-0.t0000755000175000017500000000242212013153136015274 0ustar affaff# Test::MockDBI fetch*() with 0-element array returned from coderef # $Id: coderef-scalar-0.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 3; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my $retval = undef; # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_scalar(2, "FETCHROW", sub {}); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $retval = $sth->fetchrow_arrayref(); ok(!defined($retval), q{Expect 0 columns}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW"); $retval = $sth->fetchrow_arrayref(); ok(!defined($retval), q{Expect undef for matching sql since sub returns undef}); $sth->finish(); __END__ =pod =cut Test-MockDBI-0.70/t/bad_param-1.t0000755000175000017500000000341112013153136014330 0ustar affaff# Test making DBI parameters bad # $Id: bad_param-1.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use Data::Dumper; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # what we are testing plan tests => 10; # ------ define variables my $dbh = undef; # mock DBI database handle my $md = undef; # Test::MockDBI instance my @retval = (); # return array from fetchrow_array() my $select = undef; # DBI SQL SELECT statement handle # ------ set up return values for DBI fetch*() methods $md = Test::MockDBI::get_instance(); isa_ok($md, q{Test::MockDBI}, q{Expect a Test::MockDBI reference}); # Set 1st param bad (In mode --dbitest=2) warning_like{ like($md->bad_param(2, 1, "jimbo"), qr/^\d+$/, q{Expect a positive integer (bad_param))}); } qr/called bad_param in an deprecated way/, "Legacy warning displayed"; warning_like{ like($md->set_retval_scalar(2, "SOmE SQL ?", [42]), qr/^\d+$/, q{Expect a positive integer (set_retval_scalar))}); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # Connect and prepare $dbh = DBI->connect("", "", ""); isa_ok($dbh, q{DBI::db}, q{Expect a DBI::db reference}); $select = $dbh->prepare("SOmE SQL ?"), isa_ok($select, q{DBI::st}, q{Expect a DBI::st reference}); # Bind, execute and fetch is($select->bind_param(1, "jimbo"), undef, q{Expect undef (bind_param))}); cmp_ok($select->execute(), 'eq', '0E0', q{Expect 0E0 (execute -1))}); is($select->finish(), 1, q{Expect 1 (finish) }); __END__ Test-MockDBI-0.70/t/008-rows.t0000644000175000017500000000167112013150506013564 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $mock = Test::MockDBI::get_instance(); my $dbh = DBI->connect('DBI:mysql:somedb', 'user1', 'password1'); sub get_sth{ my $sth = $dbh->prepare('SELECT something FROM somewhere WHERE location = ?'); $sth->bind_param(1, 'anywhere'); $sth->execute(); return $sth; } { #Check that rows default returns -1 my $sth = get_sth(); cmp_ok($sth->rows(), '==', -1, '$sth->rows default returns -1'); } { my $resultset = [ { A => 1 }, { B => 1 }]; $mock->set_retval( method => 'fetchrow_hashref', retval => $resultset ); #Check that we can get rows to return the right number of rows my $sth = get_sth(); $mock->set_retval( sql => 'SELECT something FROM somewhere WHERE location = ?', retval => sub{ return scalar( @{ $resultset } ); }, method => 'rows' ); cmp_ok($sth->rows(), '==', 2, '$sth->rows returns 2'); } done_testing();Test-MockDBI-0.70/t/bad_param-2.t0000755000175000017500000000344212013153136014335 0ustar affaff# Test making DBI parameters bad # $Id: bad_param-2.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use Data::Dumper; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # what we are testing plan tests => 11; # ------ define variables my $dbh = undef; # mock DBI database handle my $md = undef; # Test::MockDBI instance my @retval = (); # return array from fetchrow_array() my $select = undef; # DBI SQL SELECT statement handle $md = Test::MockDBI::get_instance(); isa_ok($md, q{Test::MockDBI}, q{Expect a Test::MockDBI reference}); # Set 2nd param bad (In mode --dbitest=2) warning_like{ like($md->bad_param(2, 2, "noblesville"), qr/^\d+$/, q{Expect a positive integer (bad_param))}); } qr /bad_param in an deprecated way/, "Legacy warning displayed"; warning_like{ like($md->set_retval_scalar(2, "other SQL", [42]), qr/^\d+$/, q{Expect a positive integer (set_retval_scalar))}); } qr/set_retval_scalar is deprecated/, "Legacy warning displayed"; # Connect and prepare $dbh = DBI->connect("", "", ""); isa_ok($dbh, q{DBI::db}, q{Expect a DBI::db reference}); $select = $dbh->prepare("other SQL ? ? "); isa_ok($select, q{DBI::st}, q{Expect a DBI::st reference}); # Bind, execute and fetch is($select->bind_param(1, "46062"), 1, q{Expect 1 (bind_param 1))}); is($select->bind_param(2, "noblesville"), undef, q{Expect undef (bind_param 2))}); cmp_ok($select->execute(), 'eq', '0E0', q{Expect 0E0 (execute -1))}); is($select->finish(), 1, q{Expect 1 (finish) }); __END__ Test-MockDBI-0.70/t/fetchrow_array-many.t0000755000175000017500000000300412013153136016243 0ustar affaff# Test::MockDBI fetchrow_array() with many-element array returned # (For our purposes, 2 eq many.) # $Id: fetchrow_array-many.t 246 2008-12-04 13:01:22Z aff $ # ------ enable testing mock DBI BEGIN { push @ARGV, "--dbitest=2"; } # ------ use/require pragmas use strict; # better compile-time checking use warnings; # better run-time checking use Test::More; # advanced testing use Test::Warn; use File::Spec::Functions; use lib catdir qw ( blib lib ); # use local module use Test::MockDBI; # module we are testing plan tests => 4; # ------ define variables my $dbh = ""; # mock DBI database handle my $md = Test::MockDBI::get_instance(); my @retval = (); # return array from fetchrow_array() # ------ set up return values for DBI fetch*() methods $dbh = DBI->connect("", "", ""); warning_like{ $md->set_retval_array(2, "FETCHROW_ARRAY", "go deep", 476); } qr/set_retval_array is deprecated/, "Legacy warning displayed"; # test non-matching sql my $sth = $dbh->prepare("other SQL"); $sth->execute(); @retval = $sth->fetchrow_array(); cmp_ok(scalar(@retval), q{==}, 0, q{Expect 0 columns for non-matching sql}); $sth->finish(); # test matching sql $sth = $dbh->prepare("FETCHROW_ARRAY"); $sth->execute(); @retval = $sth->fetchrow_array(); cmp_ok(scalar(@retval), q{==}, 2, q{Expect 2 column in row for matching sql}); is_deeply(\@retval, [ "go deep", 476 ], q{Expect 1st row to contain ["go deep", 476]}); $sth->finish(); __END__ Test-MockDBI-0.70/t/800-die-on-unsupported-method.t0000644000175000017500000000041512013150506017604 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $dbh = DBI->connect('DBI:mysql:something', 'user1', 'password1'); #take_imp_data will probably never be implemented! eval{ $dbh->take_imp_data(); }; ok($@, '$@ should be set'); done_testing();Test-MockDBI-0.70/t/101-set-fake-retval-coderef.t0000644000175000017500000000266112013153136017165 0ustar affaffuse strict; use warnings; use Test::More; use_ok('Test::MockDBI'); my $instance = Test::MockDBI::get_instance(); #Test all methods with a coderef retval my %methods = ( 'DBI::db' => ['prepare', 'prepare_cached', 'do', 'commit', 'rollback', 'begin_work', 'ping', 'disconnect'], 'DBI::st' => ['bind_param', 'bind_param_inout', 'execute', 'fetchrow_arrayref', 'fetchrow_array', 'fetchrow_hashref', 'fetchall_arrayref', 'finish', 'rows'] ); my $dbh = DBI->connect('DBI:mydb:somedb', 'user1', 'password1', { AutoCommit => undef }); #AutoCommit => undef to silence warnings! my $sth = $dbh->prepare('SELECT something FROM sometable'); $sth->execute(); #Make sure its executed { #Testing the databasehandler foreach my $method ( @{ $methods{'DBI::db'} } ){ #Setting a fake retval for the prepare method $instance->set_retval( method => $method, retval => sub { return "The returnvalue"; }); my $retval = $dbh->$method(); cmp_ok($retval, 'eq', 'The returnvalue', $method . ' returned \'The returnvalue\''); } #Testing the statementhandler foreach my $method ( @{ $methods{'DBI::st'} } ){ #Setting a fake retval for the prepare method $instance->set_retval( method => $method, retval => sub { return "The returnvalue"; }); my $retval = $sth->$method(); cmp_ok($retval, 'eq', 'The returnvalue', $method . ' returned \'The returnvalue\''); } } done_testing();Test-MockDBI-0.70/README0000755000175000017500000000520612013150506012516 0ustar affaffTest/MockDBI version 0.70 ========================= Test::MockDBI lets you test DBI interfaces by mocking-up the DBI interface with Test::MockObject in any way you choose. Standard output of the resulting program can then be examined as to whether your program correctly uses the DBI. Mock DBI interfaces like Test::MockDBI improve upon DBI tracing facilities like DBI::trace() and DBD::Mock, as you can modify the behavior of the DBI at the interface in (nearly) any way you choose. There are 3 basic ways to change DBI behavior with Test::MockDBI: bad_method Force a DBI method to fail when the current SQL matches the supplied pattern. bad_param Force a DBI method to fail when the current input parameters match the supplied pattern. set retval Force specific return values when the current SQL matches the supplied pattern. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install Makefile.PL will ask you for DBI configuration parameters, placing them into ./DBI.cfg. This DBI.cfg is not removed even by "make distclean", which should make repeated testing a little easier. DEPENDENCIES This module requires these other modules and libraries: DBI Test::MockObject Scalar::Util Carp Test::Warn Test::More Test::MockDBI has been tested with Test::MockObject v0.14 on Linux. WHY CHOOSE Test::MockDBI OVER DBI::trace() OR DBD::Mock? Test::MockDBI has a major advantage over DBI::trace() or DBD::Mock -- Test::MockDBI lets you change how the mocked DBI functions behave, along with modifying what data is returned by the mocked DBI functions. These changes and modifications can be made specific to particular SQL statement patterns. This ability to modify DBI function behavior and DBI-returned data makes it easier to test code that has different branches for different DBI behaviors -- you can test that a failure within DBI or returned DB data that is different than normal is processed correctly by your module or program. If you are taking over a large code base, Test::MockDBI will help in understanding the code by allowing you to safely check how the code behaves under different database conditions without modifying any databases (production or otherwise). AUTHOR Mark Leighton Fisher, mark-fisher@fisherscreek.com. COPYRIGHT AND LICENCE Copyright (C) 2004-2005 Fisher's Creek Consulting, LLC. Copyright (C) 2004-2005 DeepData, Inc. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.