view release on metacpan or  search on metacpan

t/80proxy.t  view on Meta::CPAN

#!/usr/bin/perl
# -*- perl -*-
# vim:sw=4:ts=8

use strict;
use warnings;

use DBI;
use Config;
require VMS::Filespec if $^O eq 'VMS';
require Cwd;

my $haveFileSpec = eval { require File::Spec };
my $failed_tests = 0;

$| = 1;
$^W = 1;

# $\ = "\n"; # XXX Triggers bug, check this later (JW, 1998-12-28)

# Can we load the modules? If not, exit the test immediately:
# Reason is most probable a missing prerequisite.
#
# Is syslog available (required for the server)?

eval {
    local $SIG{__WARN__} = sub { $@ = shift };
    require Storable;
    require DBD::Proxy;
    require DBI::ProxyServer;
    require RPC::PlServer;
    require Net::Daemon::Test;
};
if ($@) {
    if ($@ =~ /^Can't locate (\S+)/) {
	print "1..0 # Skipped: modules required for proxy are probably not installed (e.g., $1)\n";
	exit 0;
    }
    die $@;
}

if ($DBI::PurePerl) {
    # XXX temporary I hope
    print "1..0 # Skipped: DBD::Proxy currently has a problem under DBI::PurePerl\n";
    exit 0;
}

{
    my $numTest = 0;
    sub _old_Test($;$) {
	my $result = shift; my $str = shift || '';
	printf("%sok %d%s\n", ($result ? "" : "not "), ++$numTest, $str);
	$result;
    }
    sub Test ($;$) {
	my($ok, $msg) = @_;
	$msg = ($msg) ? " ($msg)" : "";
	my $line = (caller)[2];
	++$numTest;
	($ok) ? print "ok $numTest at line $line\n" : print "not ok $numTest\n";
	warn "# failed test $numTest at line ".(caller)[2]."$msg\n" unless $ok;
        ++$failed_tests unless $ok;
	return $ok;
    }
}


# Create an empty config file to make sure that settings aren't
# overloaded by /etc/dbiproxy.conf
my $config_file = "./dbiproxytst.conf";
unlink $config_file;
(open(FILE, ">$config_file")  and
 (print FILE "{}\n")          and
 close(FILE))
    or die "Failed to create config file $config_file: $!";

my $debug = ($ENV{DBI_TRACE}||=0) ? 1 : 0;
my $dbitracelog = "dbiproxy.dbilog";

my ($handle, $port, @child_args);

my $numTests = 136;

if (@ARGV) {
    $port = $ARGV[0];
}
else {

    unlink $dbitracelog;
    unlink "dbiproxy.log";
    unlink "dbiproxy.truss";

    # Uncommentand adjust this to isolate pure-perl client from server settings:
    # local $ENV{DBI_PUREPERL} = 0;

    # If desperate uncomment this and add '-d' after $^X below:
    # local $ENV{PERLDB_OPTS} = "AutoTrace NonStop=1 LineInfo=dbiproxy.dbg";

    # pass our @INC to children (e.g., so -Mblib passes through)
    $ENV{PERL5LIB} = join($Config{path_sep}, @INC);

    # server DBI trace level always at least 1
    my $dbitracelevel = DBI->trace(0) || 1;
    @child_args = (
	#'truss', '-o', 'dbiproxy.truss',
	$^X, 'dbiproxy', '--test', # --test must be first command line arg
	"--dbitrace=$dbitracelevel=$dbitracelog", # must be second arg
	'--configfile', $config_file,
	($dbitracelevel >= 2 ? ('--debug') : ()),
	'--mode=single',
	'--logfile=STDERR',
	'--timeout=90'
    );
    warn " starting test dbiproxy process: @child_args\n" if DBI->trace(0);
    ($handle, $port) = Net::Daemon::Test->Child($numTests, @child_args);
}

my $dsn = "DBI:Proxy:hostname=127.0.0.1;port=$port;debug=$debug;dsn=DBI:ExampleP:";

print "Making a first connection and closing it immediately.\n";
Test(eval { DBI->connect($dsn, '', '', { 'PrintError' => 1 }) })