t/01basics.t - metacpan.org

#!perl -w

use strict;

use Test::More tests => 130;
use File::Spec;
use Config;

$|=1;

## ----------------------------------------------------------------------------
## 01basic.t - test of some basic DBI functions
## ----------------------------------------------------------------------------
# Mostly this script takes care of testing the items exported by the 3
# tags below (in this order):
#		- :sql_types
#		- :squl_cursor_types
#		- :util
# It also then handles some other class methods and functions of DBI, such
# as the following:
#		- $DBI::dbi_debug & its relation to DBI->trace
#		- DBI->internal
#			and then tests on that return value:
#			- $i->debug
#			- $i->{DebugDispatch}
#			- $i->{Warn}
#			- $i->{Attribution}
#			- $i->{Version}
#			- $i->{private_test1}
#			- $i->{cachedKids}
#			- $i->{Kids}
#			- $i->{ActiveKids}
#			- $i->{Active}
#			- and finally that it will not autovivify
#		- DBI->available_drivers
#		- DBI->installed_versions (only for developers)
## ----------------------------------------------------------------------------

## load DBI and export some symbols
BEGIN {
        diag "--- Perl $] on $Config{archname}";

	use_ok('DBI', qw(
					:sql_types
					:sql_cursor_types
					:utils
					));
}


## ----------------------------------------------------------------------------
## testing the :sql_types exports

cmp_ok(SQL_GUID                          , '==', -11, '... testing sql_type');
cmp_ok(SQL_WLONGVARCHAR					 , '==', -10, '... testing sql_type');
cmp_ok(SQL_WVARCHAR                      , '==', -9,  '... testing sql_type');
cmp_ok(SQL_WCHAR                         , '==', -8,  '... testing sql_type');
cmp_ok(SQL_BIT                           , '==', -7,  '... testing sql_type');
cmp_ok(SQL_TINYINT                       , '==', -6,  '... testing sql_type');
cmp_ok(SQL_BIGINT                        , '==', -5,  '... testing sql_type');
cmp_ok(SQL_LONGVARBINARY                 , '==', -4,  '... testing sql_type');
cmp_ok(SQL_VARBINARY                     , '==', -3,  '... testing sql_type');
cmp_ok(SQL_BINARY                        , '==', -2,  '... testing sql_type');
cmp_ok(SQL_LONGVARCHAR                   , '==', -1,  '... testing sql_type');
cmp_ok(SQL_UNKNOWN_TYPE					 , '==', 0,   '... testing sql_type');
cmp_ok(SQL_ALL_TYPES					 , '==', 0,   '... testing sql_type');
cmp_ok(SQL_CHAR							 , '==', 1,   '... testing sql_type');
cmp_ok(SQL_NUMERIC						 , '==', 2,   '... testing sql_type');
cmp_ok(SQL_DECIMAL						 , '==', 3,   '... testing sql_type');
cmp_ok(SQL_INTEGER						 , '==', 4,   '... testing sql_type');
cmp_ok(SQL_SMALLINT						 , '==', 5,   '... testing sql_type');
cmp_ok(SQL_FLOAT						 , '==', 6,   '... testing sql_type');
cmp_ok(SQL_REAL							 , '==', 7,   '... testing sql_type');
cmp_ok(SQL_DOUBLE						 , '==', 8,   '... testing sql_type');
cmp_ok(SQL_DATETIME						 , '==', 9,   '... testing sql_type');
cmp_ok(SQL_DATE							 , '==', 9,   '... testing sql_type');
cmp_ok(SQL_INTERVAL						 , '==', 10,  '... testing sql_type');
cmp_ok(SQL_TIME							 , '==', 10,  '... testing sql_type');
cmp_ok(SQL_TIMESTAMP					 , '==', 11,  '... testing sql_type');
cmp_ok(SQL_VARCHAR						 , '==', 12,  '... testing sql_type');
cmp_ok(SQL_BOOLEAN						 , '==', 16,  '... testing sql_type');
cmp_ok(SQL_UDT							 , '==', 17,  '... testing sql_type');
cmp_ok(SQL_UDT_LOCATOR					 , '==', 18,  '... testing sql_type');
cmp_ok(SQL_ROW							 , '==', 19,  '... testing sql_type');
cmp_ok(SQL_REF							 , '==', 20,  '... testing sql_type');
cmp_ok(SQL_BLOB							 , '==', 30,  '... testing sql_type');
cmp_ok(SQL_BLOB_LOCATOR					 , '==', 31,  '... testing sql_type');
cmp_ok(SQL_CLOB							 , '==', 40,  '... testing sql_type');
cmp_ok(SQL_CLOB_LOCATOR					 , '==', 41,  '... testing sql_type');
cmp_ok(SQL_ARRAY						 , '==', 50,  '... testing sql_type');
cmp_ok(SQL_ARRAY_LOCATOR				 , '==', 51,  '... testing sql_type');
cmp_ok(SQL_MULTISET						 , '==', 55,  '... testing sql_type');
cmp_ok(SQL_MULTISET_LOCATOR				 , '==', 56,  '... testing sql_type');
cmp_ok(SQL_TYPE_DATE					 , '==', 91,  '... testing sql_type');
cmp_ok(SQL_TYPE_TIME					 , '==', 92,  '... testing sql_type');
cmp_ok(SQL_TYPE_TIMESTAMP				 , '==', 93,  '... testing sql_type');
cmp_ok(SQL_TYPE_TIME_WITH_TIMEZONE		 , '==', 94,  '... testing sql_type');
cmp_ok(SQL_TYPE_TIMESTAMP_WITH_TIMEZONE  , '==', 95,  '... testing sql_type');
cmp_ok(SQL_INTERVAL_YEAR                 , '==', 101, '... testing sql_type');
cmp_ok(SQL_INTERVAL_MONTH                , '==', 102, '... testing sql_type');
cmp_ok(SQL_INTERVAL_DAY                  , '==', 103, '... testing sql_type');
cmp_ok(SQL_INTERVAL_HOUR                 , '==', 104, '... testing sql_type');
cmp_ok(SQL_INTERVAL_MINUTE               , '==', 105, '... testing sql_type');
cmp_ok(SQL_INTERVAL_SECOND               , '==', 106, '... testing sql_type');
cmp_ok(SQL_INTERVAL_YEAR_TO_MONTH        , '==', 107, '... testing sql_type');
cmp_ok(SQL_INTERVAL_DAY_TO_HOUR          , '==', 108, '... testing sql_type');
cmp_ok(SQL_INTERVAL_DAY_TO_MINUTE        , '==', 109, '... testing sql_type');
cmp_ok(SQL_INTERVAL_DAY_TO_SECOND        , '==', 110, '... testing sql_type');
cmp_ok(SQL_INTERVAL_HOUR_TO_MINUTE       , '==', 111, '... testing sql_type');
cmp_ok(SQL_INTERVAL_HOUR_TO_SECOND       , '==', 112, '... testing sql_type');
cmp_ok(SQL_INTERVAL_MINUTE_TO_SECOND     , '==', 113, '... testing sql_type');

## ----------------------------------------------------------------------------
## testing the :sql_cursor_types exports

cmp_ok(SQL_CURSOR_FORWARD_ONLY,  '==', 0, '... testing sql_cursor_types');
cmp_ok(SQL_CURSOR_KEYSET_DRIVEN, '==', 1, '... testing sql_cursor_types');
cmp_ok(SQL_CURSOR_DYNAMIC,       '==', 2, '... testing sql_cursor_types');
cmp_ok(SQL_CURSOR_STATIC,        '==', 3, '... testing sql_cursor_types');
cmp_ok(SQL_CURSOR_TYPE_DEFAULT,  '==', 0, '... testing sql_cursor_types');

## ----------------------------------------------------------------------------
## test the :util exports

## testing looks_like_number

my @is_num = looks_like_number(undef, "", "foo", 1, ".", 2, "2");

ok(!defined $is_num[0], '... looks_like_number : undef -> undef');
ok(!defined $is_num[1], '... looks_like_number : "" -> undef (eg "don\'t know")');
ok( defined $is_num[2], '... looks_like_number : "foo" -> defined false');
ok(        !$is_num[2], '... looks_like_number : "foo" -> defined false');
ok(		    $is_num[3], '... looks_like_number : 1 -> true');
ok(		   !$is_num[4], '... looks_like_number : "." -> false');
ok(			$is_num[5], '... looks_like_number : 1 -> true');
ok(			$is_num[6], '... looks_like_number : 1 -> true');

## testing neat

cmp_ok($DBI::neat_maxlen, '==',  1000, "... $DBI::neat_maxlen initial state is 400");

is(neat(1 + 1), "2",	 '... neat : 1 + 1 -> "2"');
is(neat("2"),   "'2'",   '... neat : 2 -> "\'2\'"');
is(neat(undef), "undef", '... neat : undef -> "undef"');

## testing neat_list

is(neat_list([ 1 + 1, "2", undef, "foobarbaz"], 8, "|"), "2|'2'|undef|'foo...'", '... test array argument w/separator and maxlen');
is(neat_list([ 1 + 1, "2", undef, "foobarbaz"]), "2, '2', undef, 'foobarbaz'", '... test array argument w/out separator or maxlen');


## ----------------------------------------------------------------------------
## testing DBI functions

## test DBI->internal

my $switch = DBI->internal;

isa_ok($switch, 'DBI::dr');

## checking attributes of $switch

# NOTE:
# check too see if this covers all the attributes or not

# TO DO:
# these three can be improved
$switch->debug(0);
pass('... test debug');
$switch->{DebugDispatch} = 0;	# handled by Switch
pass('... test DebugDispatch');
$switch->{Warn} = 1;			# handled by DBI core
pass('... test Warn');

like($switch->{'Attribution'}, qr/DBI.*? by Tim Bunce/, '... this should say Tim Bunce');

# is this being presumptious?
is($switch->{'Version'}, $DBI::VERSION, '... the version should match DBI version');

cmp_ok(($switch->{private_test1} = 1), '==', 1, '... this should work and return 1');
cmp_ok($switch->{private_test1},       '==', 1, '... this should equal 1');

is($switch->{CachedKids}, undef, '... CachedKids should be undef initially');
my $cache = {};
$switch->{CachedKids} = $cache;
is($switch->{CachedKids}, $cache,      '... CachedKids should be our ref');

cmp_ok($switch->{Kids},       '==', 0, '... this should be zero');
cmp_ok($switch->{ActiveKids}, '==', 0, '... this should be zero');

ok($switch->{Active}, '... Active flag is true');

# test attribute warnings
{
	my $warn = "";
	local $SIG{__WARN__} = sub { $warn .= "@_" };
	$switch->{FooBarUnknown} = 1;
	like($warn, qr/Can't set.*FooBarUnknown/, '... we should get a warning here');

	$warn = "";
	$_ = $switch->{BarFooUnknown};
	like($warn, qr/Can't get.*BarFooUnknown/, '... we should get a warning here');

	$warn = "";
	my $dummy = $switch->{$_} for qw(private_foo dbd_foo dbi_foo); # special cases
	cmp_ok($warn, 'eq', "", '... we should get no warnings here');
}

# is this here for a reason? Are we testing anything?

$switch->trace_msg("Test \$h->trace_msg text.\n", 1);
DBI->trace_msg("Test DBI->trace_msg text.\n", 1);

## testing DBI->available_drivers

my @drivers = DBI->available_drivers();
cmp_ok(scalar(@drivers), '>', 0, '... we at least have one driver installed');

# NOTE:
# we lowercase the interpolated @drivers array
# so that our reg-exp will match on VMS & Win32

like(lc("@drivers"), qr/examplep/, '... we should at least have ExampleP installed');

# call available_drivers in scalar context

my $num_drivers = DBI->available_drivers;
cmp_ok($num_drivers, '>', 0, '... we should at least have one driver');

## testing DBI::hash

cmp_ok(DBI::hash("foo1"  ), '==', -1077531989, '... should be -1077531989');
cmp_ok(DBI::hash("foo1",0), '==', -1077531989, '... should be -1077531989');
cmp_ok(DBI::hash("foo2",0), '==', -1077531990, '... should be -1077531990');
SKIP: {
    skip("Math::BigInt < 1.56",2)
	if $DBI::PurePerl && !eval { require Math::BigInt; require_version Math::BigInt 1.56 };
    skip("Math::BigInt $Math::BigInt::VERSION broken",2)
	if $DBI::PurePerl && $Math::BigInt::VERSION =~ /^1\.8[45]/;
    my $bigint_vers = $Math::BigInt::VERSION || "";
    if (!$DBI::PurePerl) {
        cmp_ok(DBI::hash("foo1",1), '==', -1263462440);
        cmp_ok(DBI::hash("foo2",1), '==', -1263462437);
    }
    else {
        # for PurePerl we use Math::BigInt but that's often caused test failures that
        # aren't DBI's fault. So we just warn (via a skip) if it's not working right.
        skip("Seems like your Math::BigInt $Math::BigInt::VERSION has a bug",2)
            unless (DBI::hash("foo1X",1) == -1263462440) && (DBI::hash("foo2",1) == -1263462437);
        ok(1, "Math::BigInt $Math::BigInt::VERSION worked okay");
        ok(1);
    }
}

is(data_string_desc(""), "UTF8 off, ASCII, 0 characters 0 bytes");
is(data_string_desc(42), "UTF8 off, ASCII, 2 characters 2 bytes");
is(data_string_desc("foo"), "UTF8 off, ASCII, 3 characters 3 bytes");
is(data_string_desc(undef), "UTF8 off, undef");
is(data_string_desc("bar\x{263a}"), "UTF8 on, non-ASCII, 4 characters 6 bytes");
is(data_string_desc("\xEA"), "UTF8 off, non-ASCII, 1 characters 1 bytes");

is(data_string_diff(   "",   ""), "");
is(data_string_diff(   "",undef), "String b is undef, string a has 0 characters");
is(data_string_diff(undef,undef), "");
is(data_string_diff("aaa","aaa"), "");

is(data_string_diff("aaa","aba"), "Strings differ at index 1: a[1]=a, b[1]=b");
is(data_string_diff("aba","aaa"), "Strings differ at index 1: a[1]=b, b[1]=a");
is(data_string_diff("aa" ,"aaa"), "String a truncated after 2 characters");
is(data_string_diff("aaa","aa" ), "String b truncated after 2 characters");

is(data_diff(   "",   ""), "");
is(data_diff(undef,undef), "");
is(data_diff("aaa","aaa"), "");

is(data_diff(   "",undef),
	join "","a: UTF8 off, ASCII, 0 characters 0 bytes\n",
		"b: UTF8 off, undef\n",
		"String b is undef, string a has 0 characters\n");
is(data_diff("aaa","aba"),
	join "","a: UTF8 off, ASCII, 3 characters 3 bytes\n",
		"b: UTF8 off, ASCII, 3 characters 3 bytes\n",
		"Strings differ at index 1: a[1]=a, b[1]=b\n");
is(data_diff(pack("C",0xEA), pack("U",0xEA)),
	join "", "a: UTF8 off, non-ASCII, 1 characters 1 bytes\n",
		 "b: UTF8 on, non-ASCII, 1 characters 2 bytes\n",
		 "Strings contain the same sequence of characters\n");
is(data_diff(pack("C",0xEA), pack("U",0xEA), 1), ""); # no logical difference


## ----------------------------------------------------------------------------
# restrict this test to just developers

SKIP: {
	skip 'developer tests', 4 unless -d ".svn" || -d ".git";

    if ($^O eq "MSWin32" && eval { require Win32API::File }) {
        Win32API::File::SetErrorMode(Win32API::File::SEM_FAILCRITICALERRORS());
    }

	print "Test DBI->installed_versions (for @drivers)\n";
	print "(If one of those drivers, or the configuration for it, is bad\n";
	print "then these tests can kill or freeze the process here. That's not the DBI's fault.)\n";
	$SIG{ALRM} = sub {
		die "Test aborted because a driver (one of: @drivers) hung while loading"
		   ." (almost certainly NOT a DBI problem)";
	};
	alarm(20);

	## ----------------------------------------------------------------------------
	## test installed_versions

	# scalar context
	my $installed_versions = DBI->installed_versions;

	is(ref($installed_versions), 'HASH', '... we got a hash of installed versions');
	cmp_ok(scalar(keys(%{$installed_versions})), '>=', 1, '... make sure we have at least one');

	# list context
	my @installed_drivers = DBI->installed_versions;

	cmp_ok(scalar(@installed_drivers), '>=', 1, '... make sure we got at least one');
	like("@installed_drivers", qr/Sponge/, '... make sure at least one of them is DBD::Sponge');
}

## testing dbi_debug

cmp_ok($DBI::dbi_debug, '==',  0, "... DBI::dbi_debug's initial state is 0");

SKIP: {
    my $null = File::Spec->devnull();
    skip "cannot find : $null", 2 unless ($^O eq "MSWin32" || -e $null);

    DBI->trace(15,$null);
    cmp_ok($DBI::dbi_debug, '==', 15, "... DBI::dbi_debug is 15");
    DBI->trace(0, undef);
    cmp_ok($DBI::dbi_debug, '==',  0, "... DBI::dbi_debug is 0");
}

1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)