Форум программистов [Powered by Invision Power Board]

Код

################################################################################
# sub make_test_conf - configure for test (save to ./t/test.conf)
# Parameters: <none>
# Return value: <none>
################################################################################
sub make_test_conf
{
    my $test_conf = './t/test.conf';
    my ($dsn, $user, $pass, $path, $db, $host);

    # read cached config if available
    if (-r $test_conf)
    {
        print "\nReading cached test configuration...";
        open F, $test_conf or die "Can't open $test_conf: $!";
        local @ARGV = ($test_conf);
        ($dsn, $user, $pass) = map {chomp;$_} <>;
        ($db) = $dsn =~ /(?:db|database)=([^;]+);/;
        ($host) = $dsn =~ /(?:host|hostname)=([^;]+);/;
        $path = ($host ? "$host:" : '') . $db;
        close F;
    }

    # ask for database path
    DBPATH: {
        for (1..3) {
            last if $path = prompt("\nFull path to your test database: ", $path);
        }
        die "Must specify a test database" unless $path;

        ($db, $host) = reverse split /:/, $path;

        # no longer necessary
        #PFW - isql on windows doesn't seem to work without the localhost in the db path
        #my $hostpath = $path;
        #if ($path =~ /^localhost:(.+)/) {
        #    $hostpath = $1;
        #}

        # if DB doesn't exist ask for creation
        if ((!$host || $host =~ /localhost/) && !-f $db or
            $host && $host !~ /localhost/)
        {
            print <<"EOM";
$path does not exist.
Trying to create the test database..
Please enter a username with CREATE DATABASE permission.
EOM
            $user = prompt("Username :", $user);
            $pass = prompt("Password :", $pass);
            create_test_db($path, $user, $pass);
            last DBPATH;
        }
        else
        {
            print <<"EOM";
$db exists.
Trying to use an existing database..
Please enter a username to connect.
EOM
            $user = prompt("Username :", $user);
            $pass = prompt("Password :", $pass);

            # check dialect
            my $dialect;
            my $gstat = $IB_Bin_path . "/" . test_files($IB_Bin_path, [qw(gstat gstat.exe)]);
            local *GSTAT;
            open GSTAT, "$gstat -user $user -password $pass -h $path |" or die "Can't execute $gstat: $!";
            while (<GSTAT>) { ($dialect) = $_ =~ /dialect\s+(\d)/i and last }

            unless (defined $dialect) {
                print <<"EOM";

Dialect of $path is UNKNOWN.
This test requires a database of dialect 3. You may specify a non-existent database to create a new one.
EOM
                my $is_proceed = prompt("Proceed anyway or create a NEW test database (P/N)?", "P");
                last DBPATH if $is_proceed =~ /P/i;
                $path = undef, goto DBPATH;
            }
            unless ($dialect == 3) {
                print <<"EOM";
The dialect of $path is: $dialect !!.
This test requires a database of dialect 3. Please specify a non-existent database to create a new one.
EOM
                $path = undef, goto DBPATH;
            }
        }
    }

    # save test config to file
    open F, ">$test_conf" or die "Can't write $test_conf: $!";
    print F 'dbi:InterBase:' . ($host ? "host=$host;" : '') . "db=$db;ib_dialect=3;ib_charset=ISO8859_1\n$user\n$pass\n";
    close F;
}

################################################################################
# sub create_test_db - Creates the test database
# Parameters:
#  0: path to testdatabase to be created
#  1: username used to connect to the DB
#  2: password
# Return value: <none>
################################################################################
sub create_test_db
{
    my ($path, $user, $pass) = @_;

    # create the SQL file with CREATE statement
    open(T, ">./t/create.sql") or die "Can't write to t/create.sql";
    while(<DATA>)
    {
        s/__TESTDB__/$path/;
        s/__USER__/$user/;
        s/__PASS__/$pass/;
        print T;
    }
    close T;

    # try to find isql
    my $isql;
    if (-x "$IB_Bin_path/$isql_name") { 
        $isql = "$IB_Bin_path/$isql_name"; 
    } else {
        for (split /:/, $ENV{PATH})
        {
            s#/+$##g;
            if (-x "$_/$isql_name") {
                $isql = "$_/$isql_name"; last; 
            }
        }
    }

    EXEC:
    {
        for (1..3)
        {
            $isql = prompt("Enter full path to isql: ", $isql);
            last EXEC if (-x $isql);
        }
        die "Unable to execute isql. Aborting..";
    }

    #PFW - isql on windows doesn't seem to work without the localhost in the db path
    my $hostpath = $path;
    if ($path =~ /^localhost:(.+)/) {
        $hostpath = $1;
    }
    # if test db directory doesn't exist -> try to create
    my $dir = dirname $hostpath;
    unless (-d $dir)
    {
        print "Can't find $dir. Trying to mkdir..\n";
        system('mkdir', '-p', $dir) == 0
        or die "Can't mkdir -p $dir";
    }

    # try to execute isql and create the test database
    system($isql, '-sql_dialect', 3, '-i', './t/create.sql') == 0
    or die "Fail calling $isql -i t/create/sql: $?";
}