# -*-Perl-*-Birds-Eye.Net xxxx_api_fast.pm Database TesterBack to Birds-Eye.Net Script Archive
#
#<![CDATA[#<PRE>
######################### DO NOT REMOVE THIS HEADER #################################
# #
# Birds-Eye Network Services, LLC #
# Birds-Eye.Net's xxxx_api_fast.pm Database Tester #
# xxxx_api_fast_tester.pm #
# #
# This perl module contains a collection of subroutines for performing a variety #
# database tests for use in checking consistancy across xxxx_api_fast modules. #
# #
# By: Bruce Bahlmann #
# (C) Copyright, Birds-Eye Network Services, LLC, ALL RIGHTS RESERVED #
# #
# NOTICE: All use of the software (in whole or in part) is restricted. Any sale, #
# marketing, distribution, or transfer of software copies, associated data, source #
# code, information (including manuals), configuration files, or licenses are #
# restricted. Internal use of this software requires a license and/or express #
# written permission from Birds-Eye Network Services, LLC. Any other use of this #
# software is restricted. This software is not sold as part of an enterprise #
# license and thus is restricted as such. #
# #
# To purchase access rights to this software contact: #
# Birds-Eye.Net, LLC #
# info[_at_]birds-eye.net #
# OR go to www.birds-eye.net/consulting to obtain a license #
# #
######################### DO NOT REMOVE THIS HEADER #################################
# Birds-Eye.Net's xxxx_api_fast.pm Database Tester
#
# Created by Bruce Bahlmann
# January 14, 2004
#
# Revision History:
# 01/14/2004 00.01 initial release that performs most database checks
#
use mysql_api_fast qw(delete_mysql_db indexs_mysql_db bulk_save_hash_mysql_db obtain_hash_mysql_db lookup_hash_mysql_db modify_hash_mysql_db);
use file_api_fast qw(delete_file_db indexs_file_db bulk_save_hash_file_db obtain_hash_file_db lookup_hash_file_db modify_hash_file_db);
use sdbm_api_fast qw(delete_sdbm_db indexs_sdbm_db obtain_hash_sdbm_db bulk_save_hash_sdbm_db lookup_hash_sdbm_db modify_hash_sdbm_db);
my $dbtype = lc("file"); ## file|sdbm|mysql -- not yet works for mysql (which is still "in progress")
my %db;
$db{'dbtype'} = 'DBI:mysql';
$db{'dbname'} = 'call_features';
$db{'dbhost'} = 'localhost';
$db{'dbun'} = 'root';
$db{'dbpw'} = '';
$db{'dbtable'} = 'tests';
my $mysql_db = \%db;
my $file_db = "dbtest.txt";
my $sdbm_db = "dbtest";
my $file;
my %ha;
my %hb;
my %hc;
my %hd;
my %he;
&load_data;
## test one dimentional hash data
if (1) {
## TEST file_api_fast.pm
print "\nTesting DATABASE against one dimentional hash operations:\n";
&drop_db($dbtype);
if (1) {
&{("bulk_save_hash_$dbtype\_db")}($file,\%ha);
my $thr = &{("obtain_hash_$dbtype\_db")}($file);
print "->hash bulk save & obtain: " . &ck_one_dim_hashes(\%ha,$thr) . "\n";
my %th;
%th = %ha;
foreach (keys %hb) { $th{$_} = $hb{$_}; my %xh; $xh{$_} = $hb{$_}; &{("modify_hash_$dbtype\_db")}($file,$_,%xh); }
my $thr = &{("obtain_hash_$dbtype\_db")}($file);
print "->interop modify & obtain: " . &ck_one_dim_hashes(\%th,$thr) . "\n";
&drop_db($dbtype);
}
if (1) {
my %tp;
$tp{'0111'} = 'hi';
&{("modify_hash_$dbtype\_db")}($file,'0111',%tp);
my %th = &{("lookup_hash_$dbtype\_db")}($file,'0111');
print "->hash record save/retrieve [empty database]: " . &ck_one_dim_hashes(\%tp,\%th) . "\n";
&drop_db($dbtype);
&{("bulk_save_hash_$dbtype\_db")}($file,\%ha);
&{("modify_hash_$dbtype\_db")}($file,'0111',%tp);
my %th = &{("lookup_hash_$dbtype\_db")}($file,'0111');
print "->hash record save/retrieve [loaded database]: " . &ck_one_dim_hashes(\%tp,\%th) . "\n";
&drop_db($dbtype);
}
if (1) {
my %th = &{("lookup_hash_$dbtype\_db")}($file,'0222');
print "->lookup non existant hash record [empty database]: ";
if (exists $th{'null_flag'}) { print "passed -> null_flag = [$th{'null_flag'}]\n"; }
else { print "FAILED - null_flag does not exist\n"; }
&{("bulk_save_hash_$dbtype\_db")}($file,\%ha);
my %th = &{("lookup_hash_$dbtype\_db")}($file,'0222');
print "->lookup non existant hash record [loaded database]: ";
if (exists $th{'null_flag'}) { print "passed -> null_flag = [$th{'null_flag'}]\n"; }
else { print "FAILED - null_flag does not exist\n"; }
&{("modify_hash_$dbtype\_db")}($file,'test',%ha);
my %th = &{("lookup_hash_$dbtype\_db")}($file,'test');
print "->lookup hash record that exists: ";
if (!exists $th{'null_flag'}) { print "passed\n"; } else
{ print "FAILED -> null_flag = [$th{'null_flag'}]\n"; }
&drop_db($dbtype);
}
if (1) {
&{("bulk_save_hash_$dbtype\_db")}($file,\%ha);
my %th;
%th = %ha;
delete $th{'0104'};
my $tr = &{("delete_$dbtype\_db")}($file,'0104');
my $thr = &{("obtain_hash_$dbtype\_db")}($file);
print "->delete hash record: " . &ck_one_dim_hashes(\%th,$thr) . "\n";
&drop_db($dbtype);
}
if (1) {
&{("bulk_save_hash_$dbtype\_db")}($file,\%ha);
my @tkeys = keys %ha;
my @keys = &{("indexs_$dbtype\_db")}($file);
print "->match indexs w/ bulk save : " . &ck_arrays(\@tkeys,\@keys) . "\n";
&drop_db($dbtype);
}
print "\nTesting DATABASE against two dimentional hash operations:\n";
if (1) {
&{("bulk_save_hash_$dbtype\_db")}($file,\%hd);
my $thr = &{("obtain_hash_$dbtype\_db")}($file);
print "->hash bulk save & obtain: " . &ck_two_dim_hashes(\%hd,$thr) . "\n";
my %th;
%th = %hd;
foreach (keys %he) { my %xh; %xh = %{$he{$_}}; %{$th{$_}} = %xh; &{("modify_hash_$dbtype\_db")}($file,$_,%xh); }
my $thr = &{("obtain_hash_$dbtype\_db")}($file);
print "->interop modify & obtain: " . &ck_two_dim_hashes(\%th,$thr) . "\n";
&drop_db($dbtype);
}
}
##################### maint routines ####################
sub load_data {
## one dimentional data
$ha{'0101'} = 'hi';
$ha{'0102'} = 'hi again';
$ha{'0103'} = 'bye';
$ha{'0104'} = 'bye again';
$ha{'0105'} = 'test this';
$ha{'0106'} = 'test this again';
$hb{'0201'} = 'hello';
$hb{'0202'} = 'hello again';
$hb{'0203'} = 'goodbye';
$hb{'0204'} = 'goodbye again';
$hb{'0205'} = 'wish to test';
$hb{'0206'} = 'wish again';
$hc{'0301'} = 'still';
$hc{'0302'} = 'still again';
$hc{'0303'} = 'yet';
$hc{'0304'} = 'yet again';
$hc{'0305'} = 'finally to test';
$hc{'0306'} = 'finally again';
%{$hd{'0401'}} = %ha;
%{$hd{'0402'}} = %hb;
%{$hd{'0403'}} = %hc;
%{$he{'0501'}} = %ha;
%{$he{'0502'}} = %hb;
%{$he{'0503'}} = %hc;
if ($dbtype eq 'file') { $file = $file_db; } elsif ($dbtype eq 'sdbm') { $file = $sdbm_db; } else { $file = $mysql_db; }
}
##########################
sub drop_db {
my ($db) = @_;
if ($db eq 'file') {
unlink $file;
} elsif ($db eq 'sdbm') {
unlink "$file\.pag";
unlink "$file\.dir";
}
}
##########################
sub ck_two_dim_hashes {
my ($har,$hbr) = @_;
my $result = "passed";
my @keysa = keys %$har;
my @keysb = keys %$hbr;
## check number of keys -- are they equal?
if (@keysa != @keysb) {
$result = "FAILED";
print "Keys not equal\n";
foreach (@keysa) { print "A-> [$_]\n"; }
foreach (@keysb) { print "B-> [$_]\n"; }
}
## check key fields -- are they the same?
foreach (@keysa) {
my $match == 0;
foreach my $x (@keysb) {
$match = 1 if ($x eq $_);
}
if (!$match) {
print "Key in A not matched: [$_]\n";
$result = "FAILED";
}
}
## check key-field values -- are they the same?
foreach (@keysa) {
foreach my $x (keys %{$$har{$_}}) {
my $match == 0;
foreach my $y (keys %{$$hbr{$_}}) {
$match = 1 if ($$har{$_}{$x} eq $$hbr{$_}{$y});
}
if (!$match) {
print "Key [$x] in A not matched: [$$har{$_}{$x}]\n";
$result = "FAILED";
#print %{$$har{$_}};
}
}
foreach my $x (keys %{$$hbr{$_}}) {
my $match == 0;
foreach my $y (keys %{$$har{$_}}) {
$match = 1 if ($$hbr{$_}{$x} eq $$har{$_}{$y});
}
if (!$match) {
print "Key [$x] in B not matched: [$$hbr{$_}{$x}]\n";
$result = "FAILED";
#print %{$$hbr{$_}};
}
}
}
return("$result");
}
##########################
sub ck_one_dim_hashes {
my ($har,$hbr) = @_;
my $result = "passed";
my @keysa = keys %$har;
my @keysb = keys %$hbr;
## check number of keys -- are they equal?
if (@keysa != @keysb) {
$result = "FAILED";
print "Keys not equal\n";
foreach (@keysa) { print "A-> [$_]\n"; }
foreach (@keysb) { print "B-> [$_]\n"; }
}
## check key fields -- are they the same?
foreach (@keysa) {
my $match == 0;
foreach my $x (@keysb) {
$match = 1 if ($x eq $_);
}
if (!$match) {
print "Key in A not matched: [$_]\n";
$result = "FAILED";
}
}
## check key-field values -- are they the same?
foreach (@keysa) {
if ($$har{$_} ne $$hbr{$_}) {
print "Has value mismatch: A->[$$har{$_}] B->[$$hbr{$_}]\n";
$result = "FAILED";
}
}
return("$result");
}
##########################
sub ck_arrays {
my ($keysa,$keysb) = @_;
my $result = "passed";
## check number of keys -- are they equal?
if (@$keysa != @$keysb) {
$result = "FAILED";
print "Keys not equal\n";
foreach (@$keysa) { print "A-> [$_]\n"; }
foreach (@$keysb) { print "B-> [$_]\n"; }
}
## check key fields -- are they the same?
foreach (@$keysa) {
my $match == 0;
foreach my $x (@$keysb) {
$match = 1 if ($x == $_);
}
if (!$match) {
print "Key in A not matched: [$_]\n";
$result = "FAILED";
}
}
return("$result");
}
]]></plaintext></span>