10examp.t

SinFP是一种新的识别对方计算机操作系统类型的工具

#!perl -Tw

use lib qw(blib/arch blib/lib);	# needed since -T ignores PERL5LIB
use DBI qw(:sql_types);
use Config;
use Cwd;

$^W = 1;

my $haveFileSpec = eval { require File::Spec };
require VMS::Filespec if $^O eq 'VMS';

# originally 246 tests
use Test::More tests => 253;
#use Test::More 'no_plan';

# "globals"
my ($r, $dbh);

## testing tracing to file
sub trace_to_file {

	my $trace_file = "dbitrace.log";

	SKIP: {
		skip "no trace file to clean up", 2 unless (-e $trace_file);
	
		is(unlink( $trace_file ), 1, "Remove trace file: $trace_file" );
		ok( !-e $trace_file, "Trace file actually gone" );
	}

	my $orig_trace_level = DBI->trace;
	DBI->trace(3, $trace_file);		# enable trace before first driver load
	
	$dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef);
	die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh;

	isa_ok($dbh, 'DBI::db');

	$dbh->dump_handle("dump_handle test, write to log file", 2);

	DBI->trace(0, undef);	# turn off and restore to STDERR
	
	SKIP: {
		skip "cygwin has buffer flushing bug", 1 if ($^O =~ /cygwin/i);
		ok( -s $trace_file, "trace file size = " . -s $trace_file);
	}

	is( unlink( $trace_file ), 1, "Remove trace file: $trace_file" );
	ok( !-e $trace_file, "Trace file actually gone" );

	DBI->trace($orig_trace_level);	# no way to restore previous outfile XXX
}

trace_to_file();

# internal hack to assist debugging using DBI_TRACE env var. See DBI.pm.
DBI->trace(@DBI::dbi_debug) if @DBI::dbi_debug;

my $dbh2;
eval {
    $dbh2 = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1, AutoCommit => 0 });
};
like($@, qr/install_driver\(NoneSuch\) failed/, '... we should have an exception here');
ok(!$dbh2, '... $dbh2 should not be defined');

$dbh2 = DBI->connect('dbi:ExampleP:', '', '');
ok($dbh ne $dbh2);

sub check_connect_cached {
	# connect_cached
	# ------------------------------------------
	# This test checks that connect_cached works
	# and how it then relates to the CachedKids 
	# attribute for the driver.

	my $dbh_cached_1 = DBI->connect_cached('dbi:ExampleP:', '', '');
	my $dbh_cached_2 = DBI->connect_cached('dbi:ExampleP:', '', '');
	my $dbh_cached_3 = DBI->connect_cached('dbi:ExampleP:', '', '', { examplep_foo => 1 });
	
	isa_ok($dbh_cached_1, "DBI::db");
	isa_ok($dbh_cached_2, "DBI::db");
	isa_ok($dbh_cached_3, "DBI::db");
	
	is($dbh_cached_1, $dbh_cached_2, '... these 2 handles are cached, so they are the same');
	isnt($dbh_cached_3, $dbh_cached_2, '... this handle was created with different parameters, so it is not the same');

	my $drh = $dbh->{Driver};
	isa_ok($drh, "DBI::dr");
	
	my @cached_kids = values %{$drh->{CachedKids}};	
	ok(eq_set(\@cached_kids, [ $dbh_cached_1, $dbh_cached_3 ]), '... these are our cached kids');

	$drh->{CachedKids} = {};	
	cmp_ok(scalar(keys %{$drh->{CachedKids}}), '==', 0, '... we have emptied out cache');	
}

check_connect_cached();

$dbh->{AutoCommit} = 1;
$dbh->{PrintError} = 0;

ok($dbh->{AutoCommit} == 1);
cmp_ok($dbh->{PrintError}, '==', 0, '... PrintError should be 0');

SKIP: {
	skip "cant test this if we have DBI::PurePerl", 1 if $DBI::PurePerl;
	$dbh->{Taint} = 1;	
	ok($dbh->{Taint}      == 1);
}

is($dbh->{FetchHashKeyName}, 'NAME', '... FetchHashKey is NAME');
like($dbh->{example_driver_path}, qr/DBD\/ExampleP\.pm$/, '... checking the example driver_path');

sub check_quote {
	# checking quote
	is($dbh->quote("quote's"),         "'quote''s'", '... quoting strings with embedded single quotes');
	is($dbh->quote("42", SQL_VARCHAR), "'42'",       '... quoting number as SQL_VARCHAR');
	is($dbh->quote("42", SQL_INTEGER), "42",         '... quoting number as SQL_INTEGER');
	is($dbh->quote(undef),			   "NULL",		 '... quoting undef as NULL');
}

check_quote();

my $get_info = $dbh->{examplep_get_info} || {};

sub check_quote_identifier {
	# quote_identifier
	$get_info->{29}  ='"';					# SQL_IDENTIFIER_QUOTE_CHAR
	$dbh->{examplep_get_info} = $get_info;	# trigger STORE
	
	is($dbh->quote_identifier('foo'),             '"foo"',       '... properly quotes foo as "foo"');
	is($dbh->quote_identifier('f"o'),             '"f""o"',      '... properly quotes f"o as "f""o"');
	is($dbh->quote_identifier('foo','bar'),       '"foo"."bar"', '... properly quotes foo, bar as "foo"."bar"');
	is($dbh->quote_identifier(undef,undef,'bar'), '"bar"',       '... properly quotes undef, undef, bar as "bar"');

	is($dbh->quote_identifier('foo',undef,'bar'), '"foo"."bar"', '... properly quotes foo, undef, bar as "foo"."bar"');

	$get_info->{41}  ='@';                  # SQL_CATALOG_NAME_SEPARATOR
	$get_info->{114} = 2;                   # SQL_CATALOG_LOCATION
	$dbh->{examplep_get_info} = $get_info;	# trigger STORE

	# force cache refresh
	$dbh->{dbi_quote_identifier_cache} = undef; 
	is($dbh->quote_identifier('foo',undef,'bar'), '"bar"@"foo"', '... now quotes it as "bar"@"foo" after flushing cache');
}

check_quote_identifier();


print "others\n";
eval { $dbh->commit('dummy') };
ok($@ =~ m/DBI commit: invalid number of arguments:/, $@)
	unless $DBI::PurePerl && ok(1);

ok($dbh->ping, "ping should return true");

# --- errors
my $cursor_e = $dbh->prepare("select unknown_field_name from ?");
is($cursor_e, undef, "prepare should fail");
ok($dbh->err, "sth->err should be true");
ok($DBI::err, "DBI::err should be true");
cmp_ok($DBI::err,    'eq', $dbh->err   , "\$DBI::err should match \$dbh->err");
like($DBI::errstr, qr/Unknown field names: unknown_field_name/, "\$DBI::errstr should contain error string");
cmp_ok($DBI::errstr, 'eq', $dbh->errstr, "\$DBI::errstr should match \$dbh->errstr");


# --- func
ok($dbh->errstr eq $dbh->func('errstr'));

my $std_sql = "select mode,size,name from ?";
my $csr_a = $dbh->prepare($std_sql);
ok(ref $csr_a);
ok($csr_a->{NUM_OF_FIELDS} == 3);

SKIP: {
	skip "dont test for DBI::PurePerl", 3 if $DBI::PurePerl;
    ok(tied %{ $csr_a->{Database} });	# ie is 'outer' handle
    ok($csr_a->{Database} eq $dbh, "$csr_a->{Database} ne $dbh")
	unless $dbh->{mx_handle_list} && ok(1); # skip for Multiplex tests
    ok(tied %{ $csr_a->{Database}->{Driver} });	# ie is 'outer' handle
}

my $driver_name = $csr_a->{Database}->{Driver}->{Name};
ok($driver_name eq 'ExampleP');

# --- FetchHashKeyName
$dbh->{FetchHashKeyName} = 'NAME_uc';
my $csr_b = $dbh->prepare($std_sql);
ok(ref $csr_b);

ok($csr_a != $csr_b);

ok("@{$csr_b->{NAME_lc}}" eq "mode size name");	# before NAME
ok("@{$csr_b->{NAME_uc}}" eq "MODE SIZE NAME");
ok("@{$csr_b->{NAME}}"    eq "mode size name");
ok("@{$csr_b->{ $csr_b->{FetchHashKeyName} }}" eq "MODE SIZE NAME");

ok("@{[sort keys   %{$csr_b->{NAME_lc_hash}}]}" eq "mode name size");
ok("@{[sort values %{$csr_b->{NAME_lc_hash}}]}" eq "0 1 2");
ok("@{[sort keys   %{$csr_b->{NAME_uc_hash}}]}" eq "MODE NAME SIZE");
ok("@{[sort values %{$csr_b->{NAME_uc_hash}}]}" eq "0 1 2");

SKIP: {
	skip "do not test with DBI::PurePerl", 15 if $DBI::PurePerl;
	
    # Check Taint* attribute switching

    #$dbh->{'Taint'} = 1; # set in connect
    ok($dbh->{'Taint'});
    ok($dbh->{'TaintIn'} == 1);
    ok($dbh->{'TaintOut'} == 1);

    $dbh->{'TaintOut'} = 0;
    ok($dbh->{'Taint'} == 0);
    ok($dbh->{'TaintIn'} == 1);
    ok($dbh->{'TaintOut'} == 0);

    $dbh->{'Taint'} = 0;
    ok($dbh->{'Taint'} == 0);
    ok($dbh->{'TaintIn'} == 0);
    ok($dbh->{'TaintOut'} == 0);

    $dbh->{'TaintIn'} = 1;
    ok($dbh->{'Taint'} == 0);
    ok($dbh->{'TaintIn'} == 1);
    ok($dbh->{'TaintOut'} == 0);

    $dbh->{'TaintOut'} = 1;
    ok($dbh->{'Taint'} == 1);
    ok($dbh->{'TaintIn'} == 1);
    ok($dbh->{'TaintOut'} == 1);
}

# get a dir always readable on all platforms
my $dir = getcwd() || cwd();
$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
# untaint $dir
$dir =~ m/(.*)/; $dir = $1 || die;


# ---

my($col0, $col1, $col2, $rows);
my(@row_a, @row_b);

ok($csr_a->{Taint} = 1) unless $DBI::PurePerl && ok(1);
#$csr_a->trace(5);
ok($csr_a->bind_columns(undef, \($col0, $col1, $col2)) );
ok($csr_a->execute( $dir ), $DBI::errstr);

@row_a = $csr_a->fetchrow_array;
ok(@row_a);

# check bind_columns
ok($row_a[0] eq $col0) or print "$row_a[0] ne $col0\n";
ok($row_a[1] eq $col1) or print "$row_a[1] ne $col1\n";
ok($row_a[2] eq $col2) or print "$row_a[2] ne $col2\n";
#$csr_a->trace(0);


SKIP: {

    # Check Taint attribute works. This requires this test to be run
    # manually with the -T flag: "perl -T -Mblib t/examp.t"
    sub is_tainted {
	my $foo;
	return ! eval { ($foo=join('',@_)), kill 0; 1; };
    }

    skip " Taint attribute tests skipped\n", 19 unless(is_tainted($^X) && !$DBI::PurePerl);

    $dbh->{'Taint'} = 0;
    my $st;
    eval { $st = $dbh->prepare($std_sql); };
    ok(ref $st);

    ok($st->{'Taint'} == 0);

    ok($st->execute( $dir ));

    my @row = $st->fetchrow_array;
    ok(@row);

    ok(!is_tainted($row[0]));
    ok(!is_tainted($row[1]));
    ok(!is_tainted($row[2]));

    $st->{'TaintIn'} = 1;

    @row = $st->fetchrow_array;
    ok(@row);

    ok(!is_tainted($row[0]));
    ok(!is_tainted($row[1]));
    ok(!is_tainted($row[2]));

    $st->{'TaintOut'} = 1;

    @row = $st->fetchrow_array;
    ok(@row);

    ok(is_tainted($row[0]));
    ok(is_tainted($row[1]));
    ok(is_tainted($row[2]));

    $st->finish;

    # check simple method call values
    #ok(1);
    # check simple attribute values
    #ok(1); # is_tainted($dbh->{AutoCommit}) );
    # check nested attribute values (where a ref is returned)
    #ok(is_tainted($csr_a->{NAME}->[0]) );
    # check checking for tainted values

    $dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
    eval { $dbh->prepare($^X); 1; };
    ok($@ =~ /Insecure dependency/, $@);
    eval { $csr_a->execute($^X); 1; };
    ok($@ =~ /Insecure dependency/, $@);
    undef $@;

    $dbh->{'TaintIn'} = $csr_a->{'TaintIn'} = 0;

    eval { $dbh->prepare($^X); 1; };
    ok(!$@);
    eval { $csr_a->execute($^X); 1; };
    ok(!$@);

    # Reset taint status to what it was before this block, so that
    # tests later in the file don't get confused
    $dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
}


SKIP: {
	skip "do not test with DBI::PurePerl", 1 if $DBI::PurePerl;
    $csr_a->{Taint} = 0;
    ok($csr_a->{Taint} == 0);
}

ok($csr_b->bind_param(1, $dir));
ok($csr_b->execute());
@row_b = @{ $csr_b->fetchrow_arrayref };
ok(@row_b);

ok("@row_a" eq "@row_b");
@row_b = $csr_b->fetchrow_array;
ok("@row_a" ne "@row_b");

ok($csr_a->finish);
ok($csr_b->finish);

$csr_a = undef;	# force destruction of this cursor now
ok(1);

print "fetchrow_hashref('NAME_uc')\n";
ok($csr_b->execute());
my $row_b = $csr_b->fetchrow_hashref('NAME_uc');
ok($row_b);
ok($row_b->{MODE} == $row_a[0]);