use strict;
use threads;
use threads::shared;
use Win32::SqlServer;

use vars qw(%repdata);

# Don't buffer print.
$| = 1;

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

# Number of tests to run for the standard test.
my $no_of_tests = 100;

# Max time in minutes you permit one test procedure to consume. When a procedure
# 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.) Used by the standard
# test only.
my $maxtime = 3;

# Query timeout in seconds. If a procedure exceeds this time, it is immediately
# taken off the race course. 0 = no timeout.
my $query_timeout = 0;

# Whether to catch query plans. Only honoured for single-threaded test.
my $catch_query_plans = 0;

# Whether to run the multithread test or the standard test, and in such case
# for how many threads to use, and which list lengths to use.
my $domultithread = 0;
my $total_threadtests = 10000;
my @no_of_threads = (1, 5, 25, 100);
my @thread_listlens = (20, 20, 20, 5, 50, 50, 100, 100, 200, 650, 2000);

# Set to 1 if run the multi-thread tests with a cold buffer for each procedure.
# This makes the test to take quite longer!
my $use_cold_cache = 1;

# Whether to restart an interrupted test. Only supported for multi-thread
# test. On a restart no procedure are reloaded, no tables emptied. Beware
# that new test data will be generated which could skew the test.
my $restart = (0 and $domultithread);



# Server, passsword for sa (undef = integrated security) and name of database.
my $server = ($ARGV[0] or '.');
my $password = $ARGV[1];
my $bcplogin = "-S $server" . (defined $password ? " -U sa -P $password" : " -T");
my $dbname = 'listtest';
my $X = setupconnection();

# Fix for bad XML performance in SQL 2008.
$X->sql('DBCC TRACEON(4130)');

my @testsps;

# Uncomment this to get a log of all SQL statements in sql.log. When running
# multithread tests, the calls from the subthreads are not logged.
#open T, ">sql.log";
#$X->{LogHandle} = \*T;

# 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 fn_nums, used for some tests.
   $X->sql(<<'SQLEND');
   CREATE FUNCTION dbo.fn_nums(@n AS bigint) RETURNS TABLE AS
   RETURN
     WITH
     L0   AS(SELECT 1 AS c UNION ALL SELECT 1),
     L1   AS(SELECT 1 AS c FROM L0 AS A, L0 AS B),
     L2   AS(SELECT 1 AS c FROM L1 AS A, L1 AS B),
     L3   AS(SELECT 1 AS c FROM L2 AS A, L2 AS B),
     L4   AS(SELECT 1 AS c FROM L3 AS A, L3 AS B),
     L5   AS(SELECT 1 AS c FROM L4 AS A, L4 AS B),
     Nums AS(SELECT ROW_NUMBER() OVER(ORDER BY c) AS n FROM L5)
     SELECT TOP (@n) n AS Number FROM Nums WHERE n <= @n;
SQLEND

   # 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)');

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

   # Make sure that as much as statistics as possible is off.
   $X->sql("ALTER DATABASE $dbname SET AUTO_UPDATE_STATISTICS OFF");

   # And this is not a restart.
   $restart = 0;
}
elsif ($restart == 0) {
   # 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");

   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 + ' ' + quotename(s.name) + '.' + quotename(o.name)
   FROM   sys.objects o
   JOIN   sys.schemas s ON s.schema_id = o.schema_id
   WHERE  type IN ('P', 'PC', 'FN', 'FS', 'FT', 'IF', 'TF')
     AND  o.name <> 'fn_nums'
SQLEND
   $X->sql(join("\n", @drops)) if @drops;

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

   # And table types.
   @drops = $X->sql("SELECT 'DROP TYPE ' + name FROM sys.types WHERE is_table_type = 1",
                       Win32::SqlServer::SCALAR);
   $X->sql(join("\n", @drops)) if @drops;

   # XML Schema collections
   @drops = $X->sql("SELECT 'DROP XML SCHEMA COLLECTION ' + name FROM sys.xml_schema_collections WHERE schema_id = 1",
                       Win32::SqlServer::SCALAR);
   $X->sql(join("\n", @drops)) if @drops;

}
else {
   # This is a restart. Set the database, and find out which test procedures
   # that are currently loaded.
   $X->sql("USE $dbname");

   @testsps = $X->sql(<<'SQLEND', Win32::SqlServer::SCALAR);
   SELECT name FROM sys.objects WHERE type = 'P' AND name LIKE '%[_]test' ORDER BY NAME
SQLEND

   if (not @testsps) {
      die "There are no test procedures in the database $dbname!\n";
   }
}

goto reload_done if $restart;

# (Re)sreate table types.
$X->sql(<<SQLEND);
   CREATE TYPE intlist_tbltype AS TABLE (n int NOT NULL)
   CREATE TYPE stringlist_tbltype AS TABLE (str nvarchar(50) NOT NULL)
   CREATE TYPE intlist_pktype AS TABLE (n int NOT NULL PRIMARY KEY)
   CREATE TYPE stringlist_pktype AS TABLE (str nvarchar(50) NOT NULL PRIMARY KEY)
SQLEND


# This procedure is used to generate random numbers to get testdata.
$X->sql(<<'SQLEND');
   CREATE PROCEDURE generate_wordnos @listlen  int,
                                     @totalcnt int AS

   DECLARE @rowc int

   DECLARE @t TABLE (wordno int NOT NULL PRIMARY KEY)
   DECLARE @u TABLE (wordno int NOT NULL PRIMARY KEY)

   INSERT @t (wordno)
      SELECT DISTINCT abs(checksum(newid())) % @totalcnt
      FROM   fn_nums(@listlen)
   SELECT @rowc = @@rowcount

   SELECT @listlen -= @rowc

   WHILE @listlen > 0
   BEGIN
      INSERT @u (wordno)
         SELECT DISTINCT abs(checksum(newid())) % @totalcnt
         FROM   fn_nums(@listlen)

      INSERT @t (wordno)
         SELECT wordno FROM @u u
         WHERE  NOT EXISTS (SELECT * FROM @t t WHERE t.wordno = u.wordno)
      SELECT @rowc = @@rowcount

      SELECT @listlen -= @rowc

      DELETE @u
   END

   SELECT wordno FROM @t ORDER BY newid()
SQLEND

# Get function files and test procedure in the current directory.
my (@sql_files, @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");
   my $csc = 'C:\Windows\Microsoft.NET\Framework\v2.0.50727\csc.exe  /nologo /target:library';
   system("$csc $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->sql("CREATE ASSEMBLY $basename FROM \@dll",
           {'@dll' => ['varbinary(MAX)', $dll]});
}


# Load all SQL files and test procedures.
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|EXISTS|UNPACK|COUNT)_test$/) {
         die "Test file '$file' is incorrectly named.\n";
      }
   }
}

# Make sure database is in simple recovery.
$X->sql("ALTER DATABASE $dbname SET RECOVERY SIMPLE");

reload_done:

# Get the test words. To save memory in the multithread tests, this area is
# shared across threads. (Although the threads do not access them itself.
my $words : shared = shared_clone(get_all_testwords());

# And here is on more area that is shared accross threads. This area is used
# only in multi-thread tests, but declared on script level.
my @thread_testdata : shared;

if ($domultithread) {
   run_multithread_test();
}
else {
  run_standard_test();
}

#exit;

#--------------------- multithread test -------------------------------
sub run_multithread_test {

   goto tables_done if $restart;

   $X->sql("IF object_id('threadtimings') IS NOT NULL DROP TABLE threadtimings");
   $X->sql("IF object_id('threadclientms') IS NOT NULL DROP TABLE threadclientms");

   # Timing tables for the multithread test.
   $X->sql(<<SQLEND);
   -- Per proc execution.
   CREATE TABLE threadtimings
          (method      varchar(20)  NOT NULL,
           datatype    char(3)      NOT NULL
              CHECK (datatype IN ('Str', 'Int')),
           optype      char(6)      NOT NULL
              CHECK (optype IN ('UNPACK', 'EXISTS', 'JOIN', 'COUNT')),
           noofthreads smallint     NOT NULL,
           threadid    smallint     NOT NULL,
           testrun     smallint     NOT NULL,
           listlen     int          NOT NULL,
           tookms      int          NOT NULL,
           PRIMARY KEY(method, datatype, optype, noofthreads, threadid, testrun))

   -- Client-side timings are in a separate table, because they are for the
   -- whole test, not per proc execution.
   CREATE TABLE threadclientms
          (method      varchar(20)  NOT NULL,
           datatype    char(3)      NOT NULL
              CHECK (datatype IN ('Str', 'Int')),
           optype      char(6)      NOT NULL
              CHECK (optype IN ('UNPACK', 'EXISTS', 'JOIN', 'COUNT')),
           noofthreads smallint     NOT NULL,
           threadid    smallint     NOT NULL,
           clientms    int          NOT NULL,
           starttime   datetime2(3) NOT NULL,
           PRIMARY KEY(method, datatype, optype, noofthreads, threadid))
SQLEND

   # A table type that permits us to store all times at ones.
   $X->sql(<<SQLEND);
   CREATE TYPE threadtime_type AS TABLE (testrun  smallint NOT NULL,
                                         listlen  int      NOT NULL,
                                         tookms   int      NOT NULL,
                                         PRIMARY KEY (testrun))
SQLEND

   # A stored procedure for inserting to the tables.
   $X->sql(<<'SQLEND');
   CREATE PROCEDURE insert_threadtimings @method      varchar(20),
                                         @datatype    char(3),
                                         @optype      char(6),
                                         @noofthreads int,
                                         @threadid    smallint,
                                         @timings     threadtime_type READONLY,
                                         @clientms    int,
                                         @starttime   datetime2(3) AS
   INSERT threadtimings(method, datatype, optype, noofthreads,
                        threadid, testrun, listlen, tookms)
      SELECT @method, @datatype, @optype, @noofthreads,
             @threadid, testrun, listlen, tookms
      FROM   @timings

   INSERT threadclientms (method, datatype, optype, noofthreads,
                          threadid, clientms, starttime)
      VALUES(@method, @datatype, @optype, @noofthreads,
             @threadid, @clientms, @starttime)
SQLEND

   # Create stored procedures for client-side timings. While both the multi-
   # thread and the standard mechanism uses the same mechanism, the multi-thread
   # procdures do a little more.
   $X->sql(<<'SQLEND');
   CREATE PROCEDURE start_client_timer AS
      -- First wait for the main thread to release the application to give
      -- us a go head.
      EXEC sp_getapplock 'Startsignal', 'Shared', 'Session'
      -- The save the current time into context_info.
      DECLARE @d2 datetime2(3) = sysdatetime()
      DECLARE @b varbinary(128) = convert(varbinary(128), @d2)
      SET CONTEXT_INFO @b
SQLEND

   $X->sql(<<'SQLEND');
   CREATE PROCEDURE get_clientms @clientms  int          OUTPUT,
                                 @starttime datetime2(3) OUTPUT AS
      DECLARE @now datetime2(3) = sysdatetime()
      -- Release the application lock while we are at it.
      EXEC  sp_releaseapplock 'Startsignal', 'Session'
      SELECT @starttime = convert(datetime2(3), context_info())
      SELECT @clientms = datediff(ms, @starttime, @now)
SQLEND

   $X->sql(<<'SQLEND');
   CREATE PROCEDURE already_tested @method      varchar(20),
                                   @datatype    char(3),
                                   @optype      char(6),
                                   @noofthreads int AS
      SELECT CASE WHEN EXISTS (SELECT *
                               FROM   threadclientms
                               WHERE  method   = @method
                                 AND  datatype = @datatype
                                 AND  optype   = @optype
                                 AND  noofthreads = @noofthreads)
                 THEN 1
                 ELSE 0
             END
SQLEND

   tables_done:

   # Now generate testdata for all runs in advance.
   for my $i (0.. $total_threadtests) {
       my $listlen_ix = $i % @thread_listlens;
       my @testnums = $X->sql_sp('dbo.generate_wordnos',
                                 [$thread_listlens[$listlen_ix], $#$words + 1],
                                 Win32::SqlServer::SCALAR);
       my @testwords = map($$words[$_], @testnums);
       my @sortwords = sort(@testwords);
       my @sortnums  = sort(@testnums);

       push(@thread_testdata, shared_clone({Numbers => \@sortnums,
                                            Words   => \@sortwords,
                                            Wordstr => join(',', @testwords),
                                            Numstr  => join(',', @testnums),
                                            Listlen => $thread_listlens[$listlen_ix]}));
   }

   # Loop over the various number of threads to test for.
   foreach my $no_of_threads (@no_of_threads) {

      # Iterate over the procedures.
      foreach my $testsp (reverse @testsps) {
         my ($method, $datatype, $optype) = split(/_/, $testsp);

         # We never run multi-threaded tests for EXISTS to save time.
         next if $optype eq "EXISTS";

         # EXEC$B is not meaningful to run for the multi-thread test.
         next if $method eq 'EXEC$B';

         # And skip TVP methods. Due to the overhead in the API this would
         # not be a fair test.
         #next if $method =~ /^TVP/;

         if ($restart) {
            my $istested = $X->sql_sp('already_tested',
                               [$method, $datatype, $optype, $no_of_threads],
                               Win32::SqlServer::SINGLEROW,
                               Win32::SqlServer::SCALAR);
            next if $istested;
         }

         print "Testing $testsp - $no_of_threads threads\n";

         # Get the test data in form which is approoriate for the tets procedure.
         foreach my $td (@thread_testdata) {
            my ($input, $testdata, $extra) =
                      determine_input($method, $datatype, $optype,
                                      $td->{Numbers}, $td->{Words},
                                      $td->{Numstr}, $td->{Wordstr});
            next if not defined $input;

            # We save the input to two different places depending on whether
            # it's a reference or not, because else Perl crashes.
            $td->{Input} = (ref $input ? undef : $input);
            $td->{RefInput} = (ref $input ? shared_clone($input) : undef);
            $td->{Testdata} = $testdata;
            $td->{Extra}    = (ref $extra ? shared_clone($extra) : undef);
         }

         # Flush the procedure, so that not plans from previous tests
         # plays tricks on us.
         $X->sql('DBCC FREEPROCCACHE WITH NO_INFOMSGS');

         # And flush the buffer cache to have all tests starts with the same
         # presumptions.
         if ($use_cold_cache) {
            $X->sql('DBCC DROPCLEANBUFFERS WITH NO_INFOMSGS');
         }

         # Make a first call to the procedure, to get the call profile (which
         # the threads will steal) and to make sure that there is a plan in
         # cache.
         $X->sql_sp($testsp, [($thread_testdata[0]->{Input} or
                               $thread_testdata[0]->{RefInput}), 0, undef,
                              @{$thread_testdata[0]->{Extra}}]);


         # Take out an applicaiton lock, that will be the start signal
         # for the threads.
         $X->sql_sp('sp_getapplock', ['Startsignal', 'Exclusive', 'Session', 0]);

         # Go on and create the threads.
         my (@threads);
         for my $threadid (1..$no_of_threads) {
             my $th = threads->create({'context' => 'list'},
                                       \&testthread,
                                       $testsp, $threadid, $no_of_threads);
             if ($th) {
                push(@threads, $th);
             }
             else {
                warn "Creatíon of thread $threadid failed: $!\n";
             }
         }

         # Permit all threads to connect and reach the synchronisation
         # point.
         sleep(2);

         # Release the application lock to start the tests.
         $X->sql_sp('sp_releaseapplock', ['Startsignal', 'Session']);

         # As long as there are active threads, just relax.
         sleep(1) while threads->list(threads::joinable) < @threads;

         # All threads are done. Join them and store their results.
         my @whichtest = ($method, $datatype, $optype, $no_of_threads);
         my @result;
         foreach my $th (@threads) {
            my ($threadid, $timings, $clientms, $starttime) = $th->join();
            if ($timings) {
               $X->sql_sp('insert_threadtimings', [@whichtest,
                           $threadid, $timings, $clientms, $starttime]);
            }
         }
      }
   }
}

# And this is the procedure that implements the thread itself.
sub testthread {
   my ($testsp, $threadid, $no_of_threads) = @_;

   # Setup the connection, and move to the database.
   my $olle = setupconnection();
   $olle->sql("USE $dbname");

   # This is not really supported, but hey I'm the author of Win32::SqlServer,
   # so I know this works, or at least I think it does.
   $olle->{procs} = $X->{procs};
   $olle->{tabletypes} = $X->{tabletypes};

   # Wait for the starting signal and start the client timer.
   $olle->sql_sp('start_client_timer');

   # And run the test procedure like a maniac. We pick testdata in a way so
   # that all thread use different data.
   my @timings;
   my $runs = int($total_threadtests / $no_of_threads);
   for my $testrun (1..$runs) {
      my $test_ix = ($threadid - 1) * $runs + $testrun;
      my $tookms;
      my $input = ($thread_testdata[$test_ix]->{Input} or
                   $thread_testdata[$test_ix]->{RefInput});
      my $extra = $thread_testdata[$test_ix]->{Extra};
      my $retdata = $olle->sql_sp($testsp, [$input, 0, \$tookms, @$extra],
                                  Win32::SqlServer::SCALAR);
      push(@timings, {'testrun' => $testrun,
                      'listlen' => $thread_testdata[$test_ix]->{Listlen},
                      'tookms'  => $tookms});
      #verify_return($thread_testdata[$test_ix]->{Testdata}, $retdata,
      #              [$testsp]);
   }

   # And the client-side timing.
   my ($clientms, $starttime);
   $olle->sql_sp('get_clientms', [\$clientms, \$starttime]);

   # Return
   return($threadid, \@timings, $clientms, \$starttime);
}



#--------------------- standard test ---------------------------------
sub run_standard_test {
   my(%totaltime, %timeexceded);

   # Timing table for the standard test.
   $X->sql("IF object_id('timings') IS NOT NULL DROP TABLE timings");
   $X->sql(<<SQLEND);
   -- This table is for the standard test.
   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', 'EXISTS', 'JOIN', 'COUNT')),
                         listlen   int            NOT NULL,
                         testrun   tinyint        NOT NULL,
                         tookms    int            NOT NULL,
                         clientms  int            NOT NULL,
                         inputsize int            NOT NULL,
                         starttime datetime2(3)   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,
                                  @tookms    int,
                                  @clientms  int,
                                  @inputsize int,
                                  @starttime datetime2(3) AS
      INSERT timings(method, datatype, optype, listlen, testrun,
                     tookms, clientms, inputsize, starttime)
         VALUES (@method, @datatype, @optype, @listlen, @testrun,
                 @tookms, @clientms, @inputsize, @starttime)
SQLEND

   # Procedure for client-side timings. Those for the standar test are simpler.
   $X->sql(<<'SQLEND');
   CREATE PROCEDURE start_client_timer AS
      DECLARE @d2 datetime2(3) = sysdatetime()
      DECLARE @b varbinary(128) = convert(varbinary(128), @d2)
      SET CONTEXT_INFO @b
SQLEND

   $X->sql(<<'SQLEND');
   CREATE PROCEDURE get_clientms @clientms  int          OUTPUT,
                                 @starttime datetime2(3) OUTPUT AS
      DECLARE @now datetime2(3) = sysdatetime()
      SELECT @starttime = convert(datetime2(3), context_info())
      SELECT @clientms = datediff(ms, @starttime, @now)
SQLEND

   # Set up for tracing if requested.
   setup_tracing() if $catch_query_plans;

   # Set query timeout if requested, and make sure we don't stop on timeouts.
   if (defined $query_timeout) {
      $X->{CommandTimeout} = $query_timeout;
      $X->{ErrInfo}{NeverStopOn}{'HYT00'}++;
      $X->{ErrInfo}{NeverPrint}{'HYT00'}++;
      $X->{ErrInfo}{SaveMessages} = 1;
   }

   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;

         # Get test numbers.
         @testnums = $X->sql_sp('dbo.generate_wordnos', [$listlen, $#$words + 1],
                                Win32::SqlServer::SCALAR);
         @testwords = map($$words[$_], @testnums);
         $teststr    =  join(',', @testwords);
         $testnumstr =  join(',', @testnums);

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

         foreach my $testsp (@testsps) {
            my ($method, $datatype, $optype) = split(/_/, $testsp);

            # Check íf the procedure has exceeded the maximum time. EXEC$B here
            # follows EXEC$A, since EXEC$B presumes that EXEC$A runs.
            my $proc = $testsp;
            $proc =~ s/EXEC\$B/EXEC\$A/;
            $totaltime{$proc} = 0 if not exists $totaltime{$proc};
            next if $timeexceded{$proc} or
                    $totaltime{$proc} > $maxtime * 60 * 1000 and $testrun > 2 or
                    $totaltime{$proc} > 5 * $maxtime * 60 * 1000;

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

            # Determine exactly what to send to the test procedure.
            my ($input, $testdata, $extra) =
                  determine_input($method, $datatype, $optype,
                                  \@testnums, \@testwords,
                                  $testnumstr, $teststr);

            # Skip to next if no input is generated for the test.
            next if not defined $input and not defined $extra;

            # Start trace for run 0, if requested.
            my $traceid;
            if ($catch_query_plans and $testrun == 0) {
               $X->sql_sp('dbo.setup_trace', [\$traceid]);
               # Make a summy call to get_queryplan, so that the query to
               # get the param profile does not end up in the trace.
               $X->sql_sp('dbo.get_queryplan',
                    [undef, undef, undef, undef, undef, 0]);
            }

            # Make sure that the error array is empty.
            delete $X->{ErrInfo}{Messages};

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

            # Ask for data only on first run (which is discarded in the analysis.)
            my $getdata = ($testrun == 0 and $optype ne 'COUNT'),

            # Start timer for client-side operation. (And yes we use SQL Server
            # for the timer.
            $X->sql_sp('dbo.start_client_timer');

            my $tookms;
            my $sqldata = $X->sql_sp("dbo.$testsp",
                                     [$input, $getdata, \$tookms, @$extra],
                                     Win32::SqlServer::SCALAR);

            # Get the client-side timing.
            my ($clientms, $starttime);
            $X->sql_sp('dbo.get_clientms', [\$clientms, \$starttime]);

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

            # Get the query plan if requested.
            if ($catch_query_plans and $testrun == 0) {
               $X->sql_sp('dbo.get_queryplan', [@whichtest, $traceid]);
            }

            # Did we get a query timeout? In such case, stop this joker,
            # and make sure he displays in output, even if this was run 0.
            if ($X->{ErrInfo}{Messages}[0]{SQLstate} eq 'HYT00') {
               $tookms = 9999999;
               $timeexceded{$testsp}++;
               $whichtest[4] = 1 if $testrun == 0;
               $getdata = 0;
               warn "$testsp timed out at listlen $listlen!\n"
            }

            $X->sql_sp('dbo.insert_timing', [@whichtest, $tookms, $clientms,
                                             length($input), $starttime]);

            # Verify the result if got anything back.
            verify_return($testdata, $sqldata, \@whichtest) if $getdata;

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

      # Check for procedures 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 $testsp (keys %totaltime) {
         next if $totaltime{$testsp} < 2 * $maxtime * 60 * 1000;
         $timeexceded{$testsp}++;
      }
   }

   # Get data about test.
   my @testresult = $X->sql(<<SQLEND);
      SELECT listlen, datatype, optype, method,
             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
      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;
   }
}

#----------------------------- Common subroutines -----------------------

# This sub sets up a connection to be used by the main thread, or the sub-
# threads.
sub setupconnection {
   my $X = new Win32::SqlServer;

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

   if ($password) {
      $X->setloginproperty('Username', 'sa');
      $X->setloginproperty('Password', $password);
   }

   $X->{BinaryAsStr} = 0;
   $X->connect();

   my $sqlver = (split(/\./, $X->{SQL_version}))[0];
   die "The server you connect to is not running SQL 2008 or later!\n"
        if $sqlver < 10;

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

   # Create temp tables that all connections will need.
   $X->sql(<<SQLEND);
   CREATE TABLE #Int_JOIN   (word   nvarchar(50) NULL)
   CREATE TABLE #Int_EXISTS (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_EXISTS (wordno int NULL,
                             guid   char(36) NULL)
   CREATE TABLE #Str_UNPACK (word   nvarchar(50) NULL)
SQLEND

  return $X;
}

sub get_all_testwords {
   # Read all the words from the test table and return a reference to
   # them.
   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";
   return $words;
}


# This sub determins which input string to use, and performs any necessary
# modifications depending on the method.
sub determine_input {
   my ($method, $datatype, $optype, $testnums, $testwords,
       $testnumstr, $teststr) = @_;

   my $source;
   my $listlen = scalar(@$testnums);

   # Our return values.
   my ($input, $testdata, $extra, $skiptest);

   # $extra is almost always an empty array.
   $extra = [];

   # Set which input string and which comparison data to use for this test.
   if ($datatype eq 'Str' and grep($_ eq $optype, (qw(UNPACK COUNT)))) {
      $source = $testwords;
      $testdata = $testwords;
   }
   elsif ($datatype eq 'Int' and grep($_ eq $optype, (qw(UNPACK COUNT)))) {
      $source = $testnums;
      $testdata = $testnums;
   }
   elsif ($datatype eq 'Str' and grep($_ eq $optype, (qw(JOIN EXISTS)))) {
      $source = $testwords;
      $testdata = $testnums;
   }
   elsif ($datatype eq 'Int' and grep($_ eq $optype, (qw(JOIN EXISTS)))) {
      $source = $testnums;
      $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 = join(' ', @$source) if $datatype eq 'Int';
   }

   if (grep($method eq $_, (qw(EXEC$A EXEC$B)))) {
      if ($listlen <= 10000) {
         # For EXEC we must quote all strings.
         $input = "'" . join("','", @$source) . "'" if $datatype eq "Str";
       }
       else {
          # Don't run EXEC on lists > 10000, because of internal QP errors.
          $skiptest = 1;
       }
   }

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

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

   if ($method =~ /FIX.*\$BINARY/) {
      foreach my $a (@$source) {
         $input .= reverse(pack('l', $a));
      }
   }
   elsif ($method =~ /FIX/) {
      my $len = ($datatype eq 'Str' ? 30 : 9);
      $input = join('', map($_ . ' ' x ($len - length($_)), @$source));
   }

   # For TVP method we should pass an array of arrays.
   if ($method =~ /^TVP/) {
      my @tvp_array;
      foreach my $val (@$source) {
         push(@tvp_array, [$val]);
      }
      $input = \@tvp_array;
   }

   # And for MANYPARAM, all data goes into a 2000-element array.
   if ($method =~ /^MANYPARAM/) {
      if ($listlen <= 2000) {
         if ($datatype eq 'Int') {
            push(@$extra, @$testnums);
         }
         elsif ($datatype eq 'Str') {
            push(@$extra, @$testwords);
         }
         $input = "DON'T CARE";
      }
      else {
         # Don't run longer lists.
         $skiptest = 1;
      }
   }

   if ($skiptest) {
      # If this test is not to be run, return undef for all.
      $input = $testdata = $extra = undef;
   }
   else {
      # Anything else needs a plain CSV.
      $input = join(',', @$source) if not defined $input;
   }

   return ($input, $testdata, $extra);
}



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"
       }
    }
}

# --------------------------------- Tracing facilities -----------------
# The tracing routines are used to catch the plans, but we do not always run
# them.
sub setup_tracing {
   $X->sql("IF object_id('queryplans') IS NOT NULL DROP TABLE queryplans");
   $X->sql(<<SQLEND);
   CREATE TABLE queryplans (method    varchar(20)    NOT NULL,
                           datatype  char(3)        NOT NULL
                              CHECK (datatype IN ('Str', 'Int')),
                           optype    char(6)        NOT NULL
                              CHECK (optype IN ('UNPACK', 'EXISTS', 'JOIN', 'COUNT')),
                           listlen   int            NOT NULL,
                           estrows   bigint         NOT NULL,
                           query_plan xml           NOT NULL,
                           PRIMARY KEY (method, datatype, optype, listlen)
   )
SQLEND

   $X->sql(<<'SQLEND');
   CREATE PROCEDURE setup_trace @TraceID int OUTPUT AS

   DECLARE @rc int
   DECLARE @maxfilesize bigint = 50
   DECLARE @filename nvarchar(200) = 'C:\temp\\' + convert(char(36), newid())

   SELECT @TraceID = NULL

   EXEC @rc = sp_trace_create @TraceID OUTPUT, 0, @filename, @maxfilesize, NULL
   IF @rc != 0
   BEGIN
      RAISERROR('sp_trace_create failed with rc = %d', 16, 1, @rc)
      RETURN
   END

   -- Set the events
   DECLARE @on bit
   SET @on = 1
   EXEC sp_trace_setevent @TraceID, 146, 1, @on
   EXEC sp_trace_setevent @TraceID, 146, 25, @on
   EXEC sp_trace_setevent @TraceID, 146, 2, @on
   EXEC sp_trace_setevent @TraceID, 146, 10, @on
   EXEC sp_trace_setevent @TraceID, 146, 14, @on
   EXEC sp_trace_setevent @TraceID, 146, 34, @on
   EXEC sp_trace_setevent @TraceID, 146, 11, @on
   EXEC sp_trace_setevent @TraceID, 146, 12, @on
   EXEC sp_trace_setevent @TraceID, 146, 51, @on


   -- Set the Filters
   DECLARE @intfilter int = @@spid

   EXEC sp_trace_setfilter @TraceID, 10, 0, 7, N'SQL Server Profiler - 57d2e1d0-3b87-42f3-b081-f9c16d1df5ff'
   EXEC sp_trace_setfilter @TraceID, 12, 0, 0, @intfilter

   -- Set the trace status to start
   EXEC sp_trace_setstatus @TraceID, 1
SQLEND

   $X->sql(<<'SQLEND');
   CREATE PROCEDURE get_queryplan @method    varchar(20),
                                  @datatype  char(3),
                                  @optype    varchar(6),
                                  @listlen   int,
                                  @testrun   int,  -- not used.
                                  @traceid   int AS

   DECLARE @filename sysname,
           @delcmd   varchar(2000)

   SELECT @filename = path FROM sys.traces WHERE id = @traceid
   SELECT @delcmd = 'DEL ' + @filename

   -- Trace has disappeared mysterious, or it was a dummy call.
   IF @filename IS NULL RETURN


   EXEC sp_trace_setstatus @traceid, 0
   EXEC sp_trace_setstatus @traceid, 2

   ; WITH trc (estrows, query_plan, rowno) AS (
      SELECT IntegerData, convert(xml, convert(nvarchar(MAX), TextData)),
             rowno = row_number() OVER (ORDER BY EventSequence DESC)
      FROM   sys.fn_trace_gettable(@filename, 0)
      WHERE  EventClass = 146
   )
   INSERT queryplans (method, datatype, optype, listlen, estrows, query_plan)
      SELECT @method, @datatype, @optype, @listlen, estrows, query_plan
      FROM   trc
      WHERE  rowno = CASE @optype WHEN 'COUNT' THEN 2 ELSE 3 END

   EXEC xp_cmdshell @delcmd
SQLEND
}

# -------------------------------- Report layout ------------------------
format STDOUT_TOP =
Listlen Data Optype Method            Cnt    Avg    Min    Max  Stdev  Varcoeff
------- ---- ------ ------            ---    ---    ---    ---  -----  --------
.

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