view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

		sub quote_identifier { (my $n = $_[1]) =~ s/`/``/g; return "`$n`" }
		sub selectall_arrayref {
			my $self = shift;
			die "SELECT command denied\n" if $self->{denied};
			return $self->{rows};
		}
		sub disconnect { $_[0]{disconnected}++; return 1 }
		package Stub::STH;
		sub new { my ($c, %a) = @_; return bless { NAME => $a{names} }, $c }
		sub execute { return 1 }
	}

	# Runs $code with DBI->connect answering $dbh (or failing when it is undef)
	# and a driver present, so no server and no installed DBD are needed.
	my $with_dbi = sub {
		my ($dbh, $code) = @_;
		require DBI;
		local $INC{'DBD/MariaDB.pm'} = __FILE__;
		my @calls;
		Test::Mockingbird::mock('DBI::connect', sub { shift; push @calls, [ @_ ]; return $dbh });
		my $ok  = eval { $code->(\@calls); 1 };
		my $err = $@;
		Test::Mockingbird::unmock('DBI::connect');
		croak_rethrow($err) unless $ok;
		return;
	};

	# Purpose: the settings come from configuration but end up in a DSN string,
	# so each part is checked before it is spliced in; and nothing in an error
	# may repeat the password.
	subtest 'DataSource::_mariadb_dsn -- the settings are checked first' => sub {
		my $fn = \&Database::BI::Model::DataSource::_mariadb_dsn;
		throws_ok { $fn->($DSX{server}, undef) }
			qr/\ADataSource: no MariaDB server is called "mock"; add it to mariadb_servers/, 'no settings';
		throws_ok { $fn->($DSX{server}, 'database=shop') } qr/no MariaDB server is called/, 'settings that are not a hash';
		for my $bad ([ database => 'shop;host=evil' ], [ database => '' ], [ host => 'a b' ],
				[ host => 'x;port=1' ], [ port => '33o6' ], [ port => '-1' ]) {
			my ($key, $value) = @{$bad};
			my %settings = (database => $DSX{database}, $key => $value);
			throws_ok { $fn->($DSX{server}, \%settings) }
				qr/\ADataSource: MariaDB server "mock" needs a valid $key in mariadb_servers/,
				"$key '$value' cannot reach the DSN";
		}
		require DBI;
		local $INC{'DBD/MariaDB.pm'} = __FILE__;
		Test::Mockingbird::mock('DBI::connect', sub { die "Access denied for user\n" });
		throws_ok { $ds->mariadb_tables($DSX{server}, { database => $DSX{database}, password => $DSX{password} }) }
			qr/\ADataSource: cannot connect to MariaDB server "mock": Access denied for user/, 'a refused connection names the server';
		throws_ok { $ds->mariadb_tables($DSX{server}, { database => $DSX{database}, password => $DSX{password} }) }
			qr/\A(?!.*\Q$DSX{password}\E)/s, 'and never the password';
		Test::Mockingbird::unmock('DBI::connect');
	};

	subtest 'DataSource::_mariadb_dsn -- what connects, without connecting' => sub {
		my $fn  = \&Database::BI::Model::DataSource::_mariadb_dsn;
		my $dbh = Stub::DBH->new;
		$with_dbi->($dbh, sub {
			my ($calls) = @_;
			my @got = $fn->($DSX{server}, { database => $DSX{database}, username => 'u', password => $DSX{password} });
			like $got[0], $DSX{dsn_re}, 'a DSN built only from checked parts, with a time-out';
			is_deeply [ @got[1, 2] ], [ 'u', $DSX{password} ], 'and the credentials';
			is scalar @{$calls}, 0, 'nothing is connected: Database::Join::Catalog and Database::Abstraction do that';
		});
	};

	# Purpose: the driver is optional; without one the reader is told what to
	# install rather than seeing a Perl error.
	subtest 'DataSource::_mariadb_dsn -- no driver' => sub {
		my $fn = \&Database::BI::Model::DataSource::_mariadb_dsn;
		local @INC = (sub { my (undef, $file) = @_; die "hidden\n" if $file =~ m{\ADBD/(?:MariaDB|mysql)\.pm\z}; return }, @INC);
		local $INC{'DBD/MariaDB.pm'};
		local $INC{'DBD/mysql.pm'};
		delete $INC{'DBD/MariaDB.pm'};
		delete $INC{'DBD/mysql.pm'};
		throws_ok { $fn->($DSX{server}, { database => $DSX{database} }) }
			qr/\ADataSource: DBD::MariaDB or DBD::mysql must be installed to open MariaDB server "mock"/,
			'says which modules';
	};

	subtest 'DataSource::mariadb_tables -- tables and their columns, in order' => sub {
		my $dbh = Stub::DBH->new(rows => [ [ 'b', 'id' ], [ 'b', 'x' ], [ 'a', 'k' ] ]);
		$with_dbi->($dbh, sub {
			my $got = $ds->mariadb_tables($DSX{server}, { database => $DSX{database} });
			is_deeply $got, [ { name => 'b', columns => [qw(id x)] }, { name => 'a', columns => ['k'] } ],
				'one entry a table, in the order the server listed them';
			is $dbh->{disconnected}, 1, 'the handle is closed';
			memory_cycle_ok $got, 'and the list holds no cycle';
		});
		my $denied = Stub::DBH->new(denied => 1);
		$with_dbi->($denied, sub {
			local $@ = 'kept';
			throws_ok { $ds->mariadb_tables($DSX{server}, { database => $DSX{database} }) }
				qr/\ADataSource: cannot connect to MariaDB server "mock": SELECT command denied/, 'a refused query';
			is $denied->{disconnected}, 1, 'still closes the handle';
		});
		throws_ok { $ds->mariadb_tables($DSX{server}, {}) } qr/needs a valid database/, 'bad settings never connect';
	};

	# Purpose: the constructor is where a bad table or server must be found,
	# not at the first read; and a handle opened to find out is always closed.
	subtest 'DataSource::_new_from_mariadb -- refusals' => sub {
		my $fn = \&Database::BI::Model::DataSource::_new_from_mariadb;
		throws_ok { $fn->($ds, { server => $DSX{server} }) } qr/table/i, 'no table';
		throws_ok { $fn->($ds, { server => $DSX{server}, table => 'a`b' }) } qr/\Q"a`b"\E|a`b/, 'a table name that could break out of its quotes';
		throws_ok { $fn->($ds, { server => '../x', table => $DSX{table}, mariadb => {} }) }
			qr/no MariaDB server is called "\.\.\/x"/, 'a server name that is not a name';
		my $dbh = Stub::DBH->new(missing => $DSX{table});
		$with_dbi->($dbh, sub {
			throws_ok { $fn->($ds, { server => $DSX{server}, table => $DSX{table}, mariadb => { database => $DSX{database} } }) }
				qr/\ADataSource: cannot read table "orders" on MariaDB server "mock": /, 'a table the server does not have';
			is $dbh->{disconnected}, 1, 'and the handle is closed';
		});
		my $ok = Stub::DBH->new(names => [qw(id amount)], primary => ['id']);
		$with_dbi->($ok, sub {
			Test::Mockingbird::mock('Database::Abstraction::new', sub { die "no backend\n" });
			require Database::Abstraction;
			throws_ok { $fn->($ds, { server => $DSX{server}, table => $DSX{table}, mariadb => { database => $DSX{database} } }) }
				qr/\ADataSource: failed to initialise database backend for table "orders": no backend/, 'D::A refusing it';
			Test::Mockingbird::unmock('Database::Abstraction::new');
		});
	};