use strict;
use Win32::SqlServer;

use vars qw(%repdata %totaltime %timeexceded);

# Set seed for random number. We want a known seed, so that all tests
# are run with the same data.
srand(98734);

# Set string-sizes to use for tests.
my @listlens = (20, 200, 650, 2000, 10000);

# Number of tests to run.
my $no_of_tests = 100;

# Which call types to test. Sometimes it can make a difference. Normally we
# test with RPC.
my $test_rpc = 1;
my $test_cmdtext = 0;

# Max time in minutes you permit one method to consume. When a method has
# exceeded this this time, it will not be run in further tests. (But at least
# two for the current list length will be carried out.)
my $maxtime = 15;

# Server, passsword for sa (undef = integrated security) and name of database.
my $server = ($ARGV[0] or '.\NELJÄ');
my $password = $ARGV[1];
my $bcplogin = "-S $server";
my $dbname = 'listtest';
my $X = new Win32::SqlServer;

# Uncomment this to get a log of all SQL statements in sql.log
#open T, ">sql.log";
#$X->{logHandle} = \*T;


$X->setloginproperty('Server', $server);
$X->setloginproperty('Database', 'tempdb');

if ($password) {
   $X->setloginproperty('Username', 'sa');
   $X->setloginproperty('Password', $password);
   $bcplogin .= " -U sa -P $password";
}
else {
   $bcplogin .= " -T";
}


$X->connect();

die "The server you connect to is not running SQL 2005!\n"
     if $X->{SQL_version} !~ /^9\./;

$X->sql(<<SQLEND);
SET NOCOUNT ON;
SET ANSI_DEFAULTS ON
SET IMPLICIT_TRANSACTIONS OFF
SET CURSOR_CLOSE_ON_COMMIT OFF
SQLEND


# First see if our database already exsists.
if (not $X->sql_one("SELECT db_id('$dbname')")) {

   # Nope, create it.
   $X->sql("CREATE DATABASE $dbname COLLATE Slovenian_CS_AS");
   $X->sql("ALTER DATABASE $dbname SET RECOVERY SIMPLE");
   $X->sql("ALTER DATABASE $dbname MODIFY FIlE (NAME ='$dbname', SIZE = 195)");
   $X->sql("ALTER DATABASE $dbname MODIFY FIlE (NAME ='${dbname}_log', SIZE = 100)");
   $X->sql("ALTER DATABASE $dbname MODIFY FIlE (NAME ='${dbname}_log', SIZE = 650)");
   $X->sql("USE $dbname");

   # Create a table with numbers, used by several functions.
   $X->sql(<<SQLEND);
   CREATE TABLE Numbers (Number int NOT NULL PRIMARY KEY);
   WITH digits (d) AS (
      SELECT 1 UNION SELECT 2 UNION SELECT 3 UNION
      SELECT 4 UNION SELECT 5 UNION SELECT 6 UNION
      SELECT 7 UNION SELECT 8 UNION SELECT 9 UNION
      SELECT 0)
   INSERT Numbers (Number)
      SELECT Number
      FROM   (SELECT i.d + ii.d * 10 + iii.d * 100 + iv.d * 1000 +
                     v.d * 10000 + vi.d * 100000 AS Number
              FROM   digits i
              CROSS  JOIN digits ii
              CROSS  JOIN digits iii
              CROSS  JOIN digits iv
              CROSS  JOIN digits v
              CROSS  JOIN digits vi) AS Numbers
      WHERE  Number > 0
   UPDATE STATISTICS Numbers WITH FULLSCAN
SQLEND


   # Create table for the test words. (Indexes will come later).
   $X->sql(<<SQLEND);
   CREATE TABLE usrdictwords
      (wordno int          NOT NULL,
       word   nvarchar(50) NOT NULL,
       guid   char(36)     NOT NULL)
SQLEND

   # Load it with data.
   system("bcp $dbname..usrdictwords in usrdictwords.bcp $bcplogin -b 2000000 -w -t;") or

   # Create indexes.
   $X->sql('CREATE UNIQUE CLUSTERED INDEX wordno_ix ON usrdictwords(wordno)');
   $X->sql('CREATE UNIQUE INDEX word_ix ON usrdictwords(word)');

   # Create tables to receive test data, one per optype/datatype.
   $X->sql(<<SQLEND);
   CREATE TABLE Int_JOIN   (word   nvarchar(50) NULL)
   CREATE TABLE Int_UNPACK (number int NULL)
   CREATE TABLE Str_JOIN   (wordno int NULL,
                            guid   char(36) NULL)
   CREATE TABLE Str_UNPACK (word   nvarchar(50) NULL)
SQLEND

   # Shrink the log.
   $X->sql("DBCC SHRINKFILE('${dbname}_log', 100)");

   # Make sure that as much as statiistics as possible is off.
   $X->sql("ALTER DATABASE $dbname SET AUTO_UPDATE_STATISTICS OFF");
}
else {
   # We have the database. Clean it up since the last run. Drop all loaded
   # procedures and functions, so that we can reload them.
   $X->sql("USE $dbname");
   $X->sql("IF object_id('timings') IS NOT NULL DROP TABLE timings");
   $X->sql("IF object_id('tmp') IS NOT NULL DROP TABLE tmp");
   my @drops = $X->sql(<<SQLEND, Win32::SqlServer::SCALAR);
   SELECT 'DROP ' +
           CASE WHEN type IN ('P', 'PC') THEN 'PROCEDURE'
                WHEN type IN ('FN', 'FS', 'FT', 'IF', 'TF') THEN 'FUNCTION'
           END + ' ' + name
   FROM   sys.objects
   WHERE  type IN ('P', 'PC', 'FN', 'FS', 'FT', 'IF', 'TF')
SQLEND
   $X->sql(join("\n", @drops)) if @drops;

   # And drop assemblies too.
   @drops = $X->sql(<<SQLEND, Win32::SqlServer::SCALAR);
      SELECT 'DROP ASSEMBLY ' + name FROM sys.assemblies
SQLEND
   $X->sql(join("\n", @drops)) if @drops;
}

# Create table for storing test result.
$X->sql(<<SQLEND);
   CREATE TABLE timings (method    varchar(20)   NOT NULL,
                         datatype  char(3)       NOT NULL
                            CHECK (datatype IN ('Str', 'Int')),
                         optype    char(6)       NOT NULL
                            CHECK (optype IN ('UNPACK', 'JOIN')),
                         listlen   int           NOT NULL,
                         testrun   tinyint       NOT NULL,
                         calltype  char(3)       NOT NULL
                            CHECK (calltype IN ('RPC', 'CMD')),
                         tookms    int           NOT NULL,
                         inputsize int          NOT NULL,
                         PRIMARY KEY(method, datatype, optype, listlen, testrun))
SQLEND

# And stored procedure for inserting the data.
$X->sql(<<'SQLEND');
   CREATE PROCEDURE insert_timing @method    varchar(20),
                                  @datatype  char(3),
                                  @optype    varchar(6),
                                  @listlen   int,
                                  @testrun   tinyint,
                                  @calltype  char(3),
                                  @tookms    int,
                                  @inputsize int AS
      INSERT timings(method, datatype, optype, listlen, testrun,
                     calltype, tookms, inputsize)
         VALUES (@method, @datatype, @optype, @listlen, @testrun,
                 @calltype, @tookms, @inputsize)
SQLEND

# Get function files and test procedure in the current directory.
my (@sql_files, @testsps, @cs_files);
{ opendir (D, '.') or die "Cannot read current directory: $!\n";
  my @filesindir = readdir(D);
  @cs_files  = grep(/\.cs$/i, @filesindir);
  @sql_files = grep(/\.sqlfun$/i, @filesindir);
  @testsps   = grep(/\.testsp$/i, @filesindir);
  closedir(D);
}

if (not @sql_files) {
   die "Did not find any functions to test in current directory.\n";
}

if (not @testsps) {
   die "Did not find any test procedures in current directory.\n";
}

# First load C# files, by compiling and the creating an assembly.
foreach my $file (@cs_files) {
   my $basename = $file;
   $basename =~ s/\.cs$//i;
   unlink("$basename.dll");
   system("csc /nologo /target:library $file") and die "Compilation of '$file' failed.";
   open(F, "$basename.dll") or die "Cannot open '$basename.dll' $!\n";
   binmode(F);
   my $dll = join('', <F>);
   close F;
   $X->{BinaryAsStr} = 0;
   $X->sql("CREATE ASSEMBLY $basename FROM \@dll",
           {'@dll' => ['varbinary(MAX)', $dll]});
}

# Load them all.
foreach my $file (@sql_files, @testsps) {
   open (F, $file) or die "Cannot open $file: $!\n";
   my $filetext = join('', <F>);
   close F;
   my @batches = split(/\n\s*go\s+/i, $filetext);
   foreach my $batch (@batches) {
      next if $batch !~ /\S/;
      $X->sql($batch, Win32::SqlServer::NORESULT);
   }
   if ($file =~ /\.testsp$/i) {
      $file =~ s/\.testsp$/_test/i;
      if ($file !~ /^[\$A-Z0-9]+_(Str|Int)_(JOIN|UNPACK)_test$/) {
         die "Test file '$file' is incorrectly named.\n";
      }
   }
}

# Read all the words from the test table.
my $words = $X->sql('SELECT word FROM usrdictwords ORDER BY wordno',
                    Win32::SqlServer::SCALAR);
if (not @$words) {
   die "The usrdictwords table is empty.\n";
}
print "There are $#$words words.\n";

# Truncate log.
$X->sql("ALTER DATABASE $dbname SET RECOVERY SIMPLE");
$X->sql("ALTER DATABASE $dbname SET RECOVERY BULK_LOGGED");


my @whichtest;

foreach my $listlen (@listlens) {
   # Ditch all cached plans for a new size.
   $X->sql_sp('sp_recompile', ['usrdictwords']);

   # Loop for tests
   foreach my $testrun (0..$no_of_tests) {
      my $teststr = '';
      my $testnumstr = '';
      my @testwords;
      my @testnums;
      my %used_nums;
      foreach my $i (1..$listlen) {
         $teststr .=  ',' . ' ' x int(rand(4)) if $teststr;
         $testnumstr .=  ',' . ' ' x int(rand(4)) if $testnumstr;
         my $wordno;
         do {
              $wordno = int(rand($#$words + 1));
         } until not $used_nums{$wordno}++;
         my $word = $$words[$wordno];
         $teststr .= $$words[$wordno];
         $testnumstr .= $wordno;
         push(@testwords, $word);
         push(@testnums, $wordno);
      }

      @testwords = sort @testwords;
      @testnums  = sort @testnums;

      foreach my $testsp (@testsps) {
         my ($tookms, $sqldata, $input, $testdata);

         my ($method, $datatype, $optype) = split(/_/, $testsp);

         # Check íf the method has exceeded the maximum time. EXEC$B here
         # follows EXEC$A, since EXEC$B presumes that EXEC$A runs.
         my $meth = ($method eq 'EXEC$B' ? 'EXEC$A' : $method);
         $totaltime{$meth} = 0 if not exists $totaltime{$meth};
         next if $timeexceded{$meth} or
                 $totaltime{$meth} > $maxtime * 60 * 1000 and $testrun > 2 or
                 $totaltime{$meth} > 5 * $maxtime * 60 * 1000;

         @whichtest = ($method, $datatype, $optype, $listlen, $testrun);

         # Set which input string and which comparison data to use for this test.
         if ($datatype eq 'Str' and $optype eq 'UNPACK') {
            $input = $teststr;
            $testdata = \@testwords;
         }
         elsif ($datatype eq 'Int' and $optype eq 'UNPACK') {
            $input = $testnumstr;
            $testdata = \@testnums;
         }
         elsif ($datatype eq 'Str' and $optype eq 'JOIN') {
            $input = $teststr;
            $testdata = \@testnums;
         }
         elsif ($datatype eq 'Int' and $optype eq 'JOIN') {
            $input = $testnumstr;
            $testdata = \@testwords;
         }
         else {
            die "Unexpected: datatype = '$datatype', optype = '$optype'.\n";
         }

         # Special precautions depending on method.
         if ($method =~ /^(ITER|CLR)/ and $method !~ /^CLR\$(FIX|ADAM)/) {
            # For the iterative and CLR methods, the integer list is space-separated.
            $input =~ s/,/ /g if $datatype eq 'Int';
         }

         if (grep($method eq $_, (qw(REALSLOW SLOW$LIKE)))) {
            # These methods does not handle the blanks.
            $input =~ s/ //g;
         }

         if (grep($method eq $_, (qw(EXEC$A EXEC$B)))) {
            # For EXEC we must quote all strings.
            if ($datatype eq 'Str') {
               $input =~ s/'/'\'/g;
               $input =~ s/,/\',/g;
               $input =~ s/(, *)/$1\'/g;
               $input = "'$input'";
            }
         }

         if ($method =~ /^XMLATTR/) {
            # For XML methods, bulid XML string. This is attribute-centred.
            my ($elem, $attr) = ($datatype eq 'Str' ? qw(Word Item) : qw(Num num));
            $input =~ s!, *!"/><$elem $attr="!g;
            $input = "<Root><$elem $attr =\"" . $input . '"/></Root>';
         }

         if ($method =~ /^XMLELEM/) {
            # And this is element-centred.
            my ($sec, $thrd) = ($datatype eq 'Str' ? qw(Word Item) : qw(Num num));
            $input =~ s!, *!</$thrd></$sec><$sec><$thrd>!g;
            $input = "<Root><$sec><$thrd>" . $input . "</$thrd></$sec></Root>";
         }

         if ($method eq 'FIX$BINARY') {
            $X->{BinaryAsStr} = 0;
            my @array = split(/\s*,\s*/, $input);
            foreach my $a (@array) {
               $a = reverse(pack('l', $a));
            }
            $input = join('', @array);
         }
         elsif ($method =~ /FIX/) {
            my $len = ($datatype eq 'Str' ? 30 : 9);
            $input =~ s/\s+//g;
            $input =~ s/([^,]+),/$1 . ' ' x ($len - length($1))/eg;
         }


         my $calltype;
         if ($test_rpc and $test_cmdtext) {
            $calltype = ($testrun % 2 ? 'RPC' : 'CMD');
         }
         elsif ($test_rpc) {
            $calltype = 'RPC';
         }
         elsif ($test_cmdtext) {
            $calltype = 'CMD';
         }
         else {
            die "No calltype is active!\n";
         }

         # Have a transaction around the call, to make sure that log truncation
         # does happen in a timed zone.
         $X->sql('BEGIN TRANSACTION');

         if ($calltype eq 'RPC') {
            $sqldata = $X->sql_sp("dbo.$testsp", [$input, \$tookms], Win32::SqlServer::SCALAR);
         }
         else {
            unless ($method =~ /\$BINARY/) {
               $input =~ s/'/'\'/g;
               $input = "'$input'";
            }
            else {
               $input = "0x" . unpack("H*", $input);
            }
            my $results = $X->sql(<<SQLEND, Win32::SqlServer::SCALAR, Win32::SqlServer::MULTISET);
DECLARE \@tookms int
EXEC dbo.$testsp $input, \@tookms OUTPUT
SELECT \@tookms
SQLEND
            $sqldata = $$results[0];
            $tookms = $$results[1][0];
         }

         $X->sql('COMMIT TRANSACTION');


         $X->sql_sp('dbo.insert_timing', [@whichtest, $calltype, $tookms, length($input)]);
         verify_return($testdata, $sqldata, \@whichtest);

         # Save total time used for the method.
         $totaltime{$method} += $tookms;
      }
   }

   # Check for methods that have exceeded the max time. If they only have
   # exceeded it doubly, we permit it to run it twice on the next level as
   # well.
   foreach my $method (keys %totaltime) {
      next if $totaltime{$method} < 2 * $maxtime * 60 * 1000;
      $timeexceded{$method}++;
   }
}

# Get data about test.
my @testresult = $X->sql(<<SQLEND);
   SELECT listlen, datatype, optype, method, calltype,
          cnt = COUNT(*), avgms = AVG(tookms), minms = MIN(tookms),
          maxms = MAX(tookms), stddev = round(STDEV(tookms), 0),
          varcoeff = CASE WHEN avg(tookms) > 0
                          THEN STDEV(tookms) / avg(tookms)
                     END
   FROM   timings
   WHERE  testrun > 0
   GROUP  BY listlen, datatype, optype, method, calltype
   ORDER  BY listlen, datatype, optype DESC, avgms, method
SQLEND


$= = 1000;
foreach my $result (@testresult) {
   %repdata = %$result;
   $repdata{'stddev'} = '' if not defined $repdata{'stddev'};
   $repdata{'varcoeff'} = '' if not defined $repdata{'varcoeff'};
   write;
}


sub verify_return {
    my ($testdata, $sqldata, $whichtest) = @_;

    my $descr = join('/', @$whichtest);

    if ($#$sqldata != $#$testdata) {
       print "!!!! In test $descr we had " . ($#$testdata  + 1) . " items, " .
             "but we got " . ($#$sqldata + 1) . " items back!!!!\n";

    }

    my $lastix = ($#$sqldata < $#$testdata ? $#$sqldata : $#$testdata);

    @$sqldata = sort(@$sqldata);

    my @diffs = grep($$testdata[$_] ne $$sqldata[$_], (0..$lastix));
    if (@diffs) {
       print "!!!! There are " . ($#diffs + 1) . " differences in test $descr. " .
             "Printing first three.\n";
       foreach my $diffix (@diffs[0..2]) {
          last if not defined $diffix;
          print "    At index $diffix we had '$$testdata[$diffix]'. " .
                " We got '$$sqldata[$diffix]'.\n"
       }
    }
}



format STDOUT_TOP =
Listlen Data Optype Method            Call Cnt    Avg    Min    Max  Stdev  Varcoeff
------- ---- ------ ------            ---- ---    ---    ---    ---  -----  --------
.

format STDOUT =
 @>>>>> @<<  @<<<<< @<<<<<<<<<<<<<<<  @<<< @>> @>>>>> @>>>>> @>>>>> @>>>>>  @>>>>>
{
 $repdata{'listlen'},
 $repdata{'datatype'},
 $repdata{'optype'},
 $repdata{'method'},
 $repdata{'calltype'},
 $repdata{'cnt'},
 $repdata{'avgms'},
 $repdata{'minms'},
 $repdata{'maxms'},
 $repdata{'stddev'},
 $repdata{'varcoeff'}
}
.