#!/usr/bin/perl

use strict;
use Symbol;

my $vardir = $ENV{MYSQLTEST_VARDIR}
  or die "need MYSQLTEST_VARDIR";

# fixed parameters

my $par_nullpct = 10;   # pct nulls if nullable
my $par_sppct = 5;      # a few pct special values like min,max
my $par_quotepct  = 20; # pct quoted if fields_enclosed_by
my $par_randbias = 3;   # prefer smaller random values

# type info

sub gen_int;
sub gen_bigint;
sub gen_float;
sub gen_char;
sub gen_decimal;
sub gen_bit;
sub gen_year;
sub gen_date;
sub gen_time;
sub gen_datetime;
sub gen_timestamp;
sub gen_blob;

my %typeinfo = (
  tinyint => {
    gen => \&gen_int,
    min_signed => -2**7,
    max_signed => 2**7-1,
    max_unsigned => 2**8-1,
  },
  smallint => {
    gen => \&gen_int,
    min_signed => -2**15,
    max_signed => 2**15-1,
    max_unsigned => 2**16-1,
  },
  mediumint => {
    gen => \&gen_int,
    min_signed => -2**23,
    max_signed => 2**23-1,
    max_unsigned => 2**24-1,
  },
  int => {
    gen => \&gen_int,
    min_signed => -2**31,
    max_signed => 2**31-1,
    max_unsigned => 2**32-1,
  },
  bigint => {
    gen => \&gen_bigint,
    min_signed => -2**31,
    max_signed => 2**31-1,
    max_unsigned => 2**32-1,
  },
  double => {
    gen => \&gen_float,
    max_exp => 308,
  },
  float => {
    gen => \&gen_float,
    max_exp => 38
  },
  char => {
    gen => \&gen_char,
  },
  varchar => {
    gen => \&gen_char,
  },
  binary => {
    binary => 1,
    gen => \&gen_char,
  },
  varbinary => {
    binary => 1,
    gen => \&gen_char,
  },
  decimal => {
    gen => \&gen_decimal,
  },
  bit => {
    gen => \&gen_bit,
  },
  year => {
    gen => \&gen_year,
  },
  date => {
    gen => \&gen_date,
  },
  time => {
    gen => \&gen_time,
  },
  datetime => {
    gen => \&gen_datetime,
  },
  timestamp => {
    gen => \&gen_timestamp,
  },
  text => {
    gen => \&gen_blob,
  },
  blob => {
    gen => \&gen_blob,
  },
);

# init test

# CSV control strings
# note --exec uses sh so these are passed in single quotes

sub get_csvfmt1 {
  my $csvfmt = {
    fields_terminated_by => '\t',
    fields_enclosed_by => undef,
    fields_escaped_by => '\\',
    lines_terminated_by => '\n',
  };
  return $csvfmt;
}

sub get_csvfmt2 {
  my $csvfmt = {
    fields_terminated_by => ',',
    fields_enclosed_by => '"',
    fields_escaped_by => '\\',
    lines_terminated_by => '\n',
  };
  return $csvfmt;
}

# translate used CSV control string to binary
# in perl '\\' and '\'' are 1 byte and other '\x' are 2 bytes
# basic double quoted chars work as expected

sub translate_csv_control {
  my ($s) = @_;
  return "\t" if $s eq '\t';
  return "\n" if $s eq '\n';
  return $s if $s eq ',';
  return $s if $s eq '"';
  return "\\" if $s eq '\\';
  return "\\" if $s eq '\\\\';
  die "translate_csv_control: unknown $s";
}

sub init_test {
  my ($test) = @_;
  my $f = $test->{csvfmt};
  my $t = $test->{csvesc} = {};
  my @name = qw(
    fields_terminated_by
    fields_enclosed_by
    fields_escaped_by
    lines_terminated_by
  );
  for my $name (@name) {
    if (defined($f->{$name})) {
      $t->{$name} = translate_csv_control($f->{$name});
    } else {
      $t->{$name} = undef;
    }
  }
  # defaults
  $test->{statedir} = "$vardir/tmp";
  $test->{csvdir} = "$vardir/tmp";
  $test->{database} = "test";
  # does load data for verification need own csv file
  $test->{csvver} = $test->{verify} && $test->{rejectsgen};
  # resume requires bad rows
  $test->{resumeopt} && !$test->{rejectsgen}
    and die "resume test requires rejected rows";
}

sub get_tablename {
  my ($test, $table, $opts) = @_;
  my $tag = $test->{tag};
  my $ver = $opts->{ver} ? "ver" : "";
  return "$table->{name}$tag$ver";
}

sub get_csvfile {
  my ($test, $table, $opts) = @_;
  my $tag = $test->{tag};
  my $ver = $test->{csvver} && $opts->{ver} ? "ver" : "";
  return "$test->{csvdir}/$table->{name}$tag$ver.csv";
}

# create and drop

sub create_attr {
  my ($attr) = @_;
  $typeinfo{$attr->{type}}
    or die "$attr->{name}: bad type: $attr->{type}";
  my @txt = ();
  push(@txt, $attr->{name});
  push(@txt, $attr->{type});
  push(@txt, "($attr->{len})")
    if defined($attr->{len});
  push(@txt, "($attr->{prec}, $attr->{scale})")
    if defined($attr->{prec}) && defined($attr->{scale});
  push(@txt, "($attr->{prec})")
    if defined($attr->{prec}) && !defined($attr->{scale});
  push(@txt, "unsigned")
    if $attr->{unsigned};
  push(@txt, "not null")
    if $attr->{notnull};
  return "@txt";
}

sub create_attrs {
  my ($attrs) = @_;
  my @txt = ();
  my $attrno = 0;
  for my $attr (@$attrs) {
    $attr->{attrno} = $attrno++;
    $attr->{notnull} = 1 if $attr->{pk};
  }
  for my $attr (@$attrs) {
    my $s = $attr->{attrno} == 0 ? "\n" : ",\n";
    push(@txt, $s . create_attr($attr));
    $attrno++;
  }
  return "@txt";
}

sub create_table {
  my ($test, $table, $opts) = @_;
  my $tname = get_tablename($test, $table, $opts);
  my @txt = ();
  push(@txt, "create table $tname (");
  my $attrs = $table->{attrs};
  push(@txt, create_attrs($attrs));
  my @pklist = ();
  for my $attr (@$attrs) {
    push(@pklist, $attr->{name})
      if $attr->{pk};
  }
  if (@pklist) {
    my $pklist = join(", ", @pklist);
    push(@txt, ",\nprimary key ($pklist)");
  }
  push(@txt, "\n) engine $opts->{engine};\n");
  return "@txt";
}

sub create_tables {
  my ($test, $opts) = @_;
  my @txt = ();
  my $tables = $test->{tables};
  for my $table (@$tables) {
    push(@txt, create_table($test, $table, $opts));
  }
  return "@txt";
};

sub drop_table {
  my ($test, $table, $opts) = @_;
  my $tname = get_tablename($test, $table, $opts);
  my @txt = ();
  push(@txt, "drop table");
  push(@txt, "if exists")
    if $opts->{if_exists};
  push(@txt, "$tname;\n");
  return "@txt";
}

sub drop_tables {
  my ($test, $opts) = @_;
  my @txt = ();
  my $tables = $test->{tables};
  for my $table (@$tables) {
    push(@txt, drop_table($test, $table, $opts));
  }
  return "@txt";
};

# run test

sub run_import {
  my ($test, $opts) = @_;
  my $fter = $test->{csvfmt}{fields_terminated_by};
  my $fenc = $test->{csvfmt}{fields_enclosed_by};
  my @cmd = ();
  push(@cmd, "\$NDB_IMPORT");
  push(@cmd, "--state-dir='$test->{statedir}'");
  push(@cmd, "--keep-state");
  push(@cmd, "--input-type=csv");
  push(@cmd, "--input-workers=2");
  push(@cmd, "--output-type=ndb");
  push(@cmd, "--output-workers=2");
  push(@cmd, "--db-workers=2");
  push(@cmd, "--temperrors=100");
  push(@cmd, "--fields-terminated-by='$fter'");
  if (defined($fenc)) {
    push(@cmd, "--fields-optionally-enclosed-by='$fenc'");
  }
  if ($test->{rejectsopt}) {
    push(@cmd, "--rejects=$test->{rejectsopt}");
  }
  # $opts tells is this is a resume
  if ($opts->{resumeopt}) {
    push(@cmd, "--resume");
  }
  push(@cmd, "--verbose=1");
  push(@cmd, $test->{database});
  my $tables = $test->{tables};
  for my $table (@$tables) {
    my $csvfile = get_csvfile($test, $table, $opts);
    push(@cmd, $csvfile);
  }
  # runs mainly on unix/linux so stderr goes to stdout
  my $log = '>>$NDB_TOOLS_OUTPUT 2>&1';
  my @cmd1 = ("--exec", "echo", @cmd, $log);
  my @cmd2 = ("--exec", @cmd, $log);
  if (defined($opts->{error})) {
    unshift(@cmd2, "--error $opts->{error}\n");
  }
  return "@cmd1\n@cmd2\n";
}

sub select_count {
  my ($test, $table, $opts) = @_;
  my $tname = get_tablename($test, $table, $opts);
  my @txt = ();
  push(@txt, "select count(*) from $tname;\n");
  return "@txt";
}

sub select_counts {
  my ($test, $opts) = @_;
  my @txt = ();
  my $tables = $test->{tables};
  for my $table (@$tables) {
    push(@txt, select_count($test, $table, $opts));
  }
  return "@txt";
}

sub load_table {
  my ($test, $table, $opts) = @_;
  my $csvfile = get_csvfile($test, $table, $opts);
  my $tname = get_tablename($test, $table, $opts);
  my $fter = $test->{csvfmt}{fields_terminated_by};
  my $fenc = $test->{csvfmt}{fields_enclosed_by};
  my @txt = ();
  push(@txt, "load data infile '$csvfile'\n");
  push(@txt, "into table $tname\n");
  push(@txt, "fields");
  push(@txt, "terminated by '$fter'");
  if (defined($fenc)) {
    push(@txt, "optionally enclosed by '$fenc'");
  }
  push(@txt, ";\n");
  return "@txt";
}

sub load_tables {
  my ($test, $opts) = @_;
  my @txt = ();
  push @txt, "--disable_query_log\n";
  my $tables = $test->{tables};
  for my $table (@$tables) {
    push(@txt, load_table($test, $table, $opts));
  }
  push @txt, "--enable_query_log\n";
  return "@txt";
}

sub verify_table {
  my ($test, $table, $opts) = @_;
  my $tname1 = get_tablename($test, $table, { ver => 0 });
  my $tname2 = get_tablename($test, $table, { ver => 1 });
  my @txt = ();
  push(@txt, "select count(*) from $tname1 x, $tname2 y\n");
  push(@txt, "where");
  my @cls = ();
  my $attrs = $table->{attrs};
  for my $attr (@$attrs) {
    my $a1 = "x." . $attr->{name};
    my $a2 = "y." . $attr->{name};
    my $c;
    if ($attr->{notnull}) {
      $c = "$a1 = $a2";
    } else {
      $c = "($a1 = $a2 or ($a1 is null and $a2 is null))";
    }
    push(@cls, $c);
  }
  push(@txt, join(" and\n", @cls));
  push(@txt, ";\n");
  return "@txt";
}

sub verify_tables {
  my ($test, $opts) = @_;
  my @txt = ();
  my $tables = $test->{tables};
  for my $table (@$tables) {
    push(@txt, verify_table($test, $table, $opts));
  }
  return "@txt";
}

# write test

sub make_test {
  my ($test) = @_;
  init_test($test);
  my @txt = ();
  push @txt, "--echo # test $test->{tag} - $test->{desc}\n";
  push @txt, create_tables($test, { engine => "ndb" });
  if (!$test->{resumeopt}) {
    push @txt, run_import($test, {});
  } else {
    push @txt, run_import($test, { error => "1" });
    for (my $i = 1; $i <= $test->{rejectsgen}; $i++) {
      push @txt, run_import($test, { resumeopt => $i, error => "0,1" });
    }
  }
  push @txt, select_counts($test, {});
  if ($test->{verify}) {
    push @txt, create_tables($test, { engine => "ndb", ver => 1 });
    push @txt, load_tables($test, { ver => 1 });
    push @txt, select_counts($test, { ver => 1 });
    push @txt, verify_tables($test, {});
    push @txt, drop_tables($test, { ver => 1 });
  }
  push @txt, drop_tables($test, {});
  return "@txt";
}

sub write_tests {
  my ($tests) = @_;
  my $tag = $tests->{tag};
  my $file = "$vardir/tmp/ndb_import$tag.inc";
  my $fh = gensym();
  open($fh, ">$file")
    or die "$file: open for write failed: $!";
  my $testlist = $tests->{testlist};
  for my $test (@$testlist) {
    print $fh make_test($test);
  }
  close($fh)
    or die "$file: close after write failed: $!";
  for my $test (@$testlist) {
    # values in $opts propagate down *and* up
    my $opts = {};
    write_csvfiles($test, $opts);
  }
}

# generate values

sub myrand {
  my ($m) = @_;
  return int(rand($m));
}

sub myrand2 {
  my ($m, $k) = @_;
  my $n = myrand($m);
  while ($k > 0) {
    $n = myrand($n + 1);
    $k--;
  }
  return $n;
}

sub gen_int {
  my ($test, $attr, $opts) = @_;
  my $typeinfo = $typeinfo{$attr->{type}};
  my $lo;
  my $hi;
  if ($attr->{unsigned}) {
    $lo = 0;
    $hi = $typeinfo->{max_unsigned};
  } else {
    $lo = $typeinfo->{min_signed};
    $hi = $typeinfo->{max_signed};
  }
  my $val;
  if ($attr->{pk}) {
    $val = $opts->{rowid} % ($hi + 1);
  } else {
    my $r = int(rand(100));
    if ($r < $par_sppct) {
      $val = 0 if $r % 3 == 0;
      $val = $lo if $r % 3 == 1;
      $val = $hi if $r % 3 == 2;
    } else {
      $val = $lo + int(rand($hi - $lo + 1));
    }
  }
  return "$val";
}

sub gen_bigint {
  my ($test, $attr, $opts) = @_;
  my $val = gen_int($test, $attr, $opts);
  return $val;
};

sub gen_float {
  my ($test, $attr, $opts) = @_;
  my $typeinfo = $typeinfo{$attr->{type}};
  my $hiexp = $typeinfo->{max_exp};
  my $p = myrand2($hiexp + 1, $par_randbias);
  if (myrand(2) == 0) {
    $p = (-1) * $p;
  }
  my $v = rand() * (10 ** $p);
  if (myrand(2) == 0) {
    $v = (-1) * $v;
  }
  my $val;
  if (myrand(2) == 0) {
    $val = sprintf("%f", $v);
  } else {
    $val = sprintf("%g", $v);
  }
  return $val;
}

my $g_escape = {
  0 => '0',
  0x08 => 'b',
  0x0a => 'n',
  0x0d => 'r',
  0x09 => 't',
  0x1a => 'Z',
};

sub make_byte {
  my ($test, $opts) = @_;
  my $fter = $test->{csvesc}{fields_terminated_by};
  my $fenc = $test->{csvesc}{fields_enclosed_by};
  my $fesc = $test->{csvesc}{fields_escaped_by};
  my $lter = $test->{csvesc}{lines_terminated_by};
  my $binary = $opts->{binary};
  my $mask = $opts->{mask};
  my $val;
  while (1) {
    my $x;
    # non-binary used only to make readable files, no charsets yet
    if (!$binary) {
      $x = 32 + myrand(127 - 32);
    } else {
      $x = myrand(256);
    }
    if (defined($mask)) {
      $x &= $mask;
    }
    if ($x == 0) {
      $val = $fesc.'0';
      last;
    }
    if ($x == ord($fter)) {
      if ($opts->{quote}) {
        $val = $fter;
      } else {
        $val = $fesc.$fter;
      }
      last;
    }
    if (defined($fenc) && $x == ord($fenc)) {
      if ($opts->{quote} && myrand(2) == 0) {
        $val = $fenc.$fenc;
      } else {
        $val = $fesc.$fenc;
      }
      last;
    }
    if ($x == ord($fesc)) {
      $val = $fesc.$fesc;
      last;
    }
    if ($x == ord($lter)) {
      if ($opts->{quote}) {
        if (myrand(2) == 0) {
          $val = $lter;
          last;
        }
      }
      if ($lter eq "\n") {
        $val = "\\n";
        last;
      }
      die "make_byte: cannot handle lter='$lter'";
    }
    if (myrand(5) == 0) {
      my $v = $g_escape->{$x};
      if (defined($v)) {
        $val = $fesc.$v;
        last;
      }
    }
    $val = pack('C', $x);
    last;
  }
  return $val;
}

sub make_string {
  my ($test, $opts) = @_;
  my $hilen = $opts->{hilen};
  my $len = myrand(10) != 0 ? myrand2($hilen, $par_randbias) : $hilen;
  my $val = "";
  for (my $i = 0; $i < $len; $i++) {
    $val .= make_byte($test, $opts);
  }
  return $val;
}

sub gen_char {
  my ($test, $attr, $opts) = @_;
  my $typeinfo = $typeinfo{$attr->{type}};
  my $val;
  if ($attr->{pk}) {
    $val = sprintf("%d", $opts->{rowid});
  } else {
    $opts->{binary} = $typeinfo->{binary};
    $opts->{hilen} = $attr->{len};
    $val = make_string($test, $opts);
  }
  return $val;
}

sub gen_bit {
  my ($test, $attr, $opts) = @_;
  my $typeinfo = $typeinfo{$attr->{type}};
  my $fter = $test->{csvfmt}{fields_terminated_by};
  my $fesc = $test->{csvfmt}{fields_escaped_by};
  my $l = $attr->{len};
  my $n = int(($l + 7) / 8);    # bytes rounded up
  my $m = 8 - (8 * $n - $l);    # bits in last byte
  my $val = "";
  for (my $i = 0; $i < $n; $i++) {
    my $mask = 255;
    if ($i + 1 == $n && $m != 0) {
      $mask = (1 << $m) - 1;
    }
    $opts->{mask} = $mask;
    my $v = make_byte($test, $opts);
    $val .= $v;
  }
  return $val;
}

sub make_decimalpart {
  my ($test, $opts) = @_;
  my $n = $opts->{partlen};
  my $m = myrand($n + 1);
  my $val = "";
  for (my $k = 0; $k < $m; $k++) {
    my $d = myrand(10);
    $val .= sprintf("%d", $d);
  }
  return $val;
}

sub gen_decimal {
  my ($test, $attr, $opts) = @_;
  my $prec = $attr->{prec};
  my $scale = $attr->{scale};
  $prec >= $scale or die "invalid prec=$prec scale=$scale";
  my $val;
  while (1) {
    $opts->{partlen} = $prec - $scale;
    $val = make_decimalpart($test, $opts);
    if (myrand(2) == 0) {
      $val .= ".";
      if (myrand(2) == 0) {
        $opts->{partlen} = $scale;
        $val .= make_decimalpart($test, $opts);
      }
    }
    last if $val =~ /\d/;
  }
  if ($attr->{unsigned}) {
    if (myrand(3) == 0) {
      $val = "+$val";
    }
  } else {
    if (myrand(3) == 0) {
      $val = "-$val";
    }
  }
  return $val;
}

sub gen_year {
  my ($test, $attr, $opts) = @_;
  my $yy = 1901 + myrand(255);
  my $val = sprintf("%04d", $yy);
  return $val;
}

# Date::Manip could be used to generate better valid dates
sub make_date {
  my ($test, $opts) = @_;
  my $yystart = $opts->{yystart};
  my $yyrange = $opts->{yyrange};
  my $yy = $yystart + myrand($yyrange);
  my $mm = 1 + myrand(12);
  my $dd = 1 + myrand(28);
  my $val = sprintf("%04d-%02d-%02d", $yy, $mm, $dd);
  return $val;
}

sub gen_date {
  my ($test, $attr, $opts) = @_;
  $opts->{yystart} = 1950;
  $opts->{yyrange} = 100;
  my $val = make_date($test, $opts);
  return $val;
}

sub make_frac {
  my ($test, $opts) = @_;
  my $prec = $opts->{prec};
  my $n = myrand($prec + 1);
  my $val = "";
  for (my $i = 0; $i < $n; $i++) {
    $val .= myrand(10);
  }
  $val = ".$val" if $n != 0 || myrand(5) == 0;
  return $val;
}

sub make_time {
  my ($test, $opts) = @_;
  my $sep = $opts->{sep};
  my $ts = $opts->{ts};
  my $val;
  my $hh = myrand(24);
  if ($ts && ($hh == 2 || $hh == 3 || $hh == 4)) {
    $hh = 1;
  }
  my $mm = myrand(60);
  my $ss = myrand(60);
  if ($sep) {
    $hh = "0$hh" if $hh < 10 && myrand(2) == 0;
    $mm = "0$mm" if $mm < 10 && myrand(2) == 0;
    $ss = "0$ss" if $ss < 10 && myrand(2) == 0;
    $val = "$hh:$mm:$ss";
  } else {
    $hh = "0$hh" if $hh < 10;
    $mm = "0$mm" if $mm < 10;
    $ss = "0$ss" if $ss < 10;
    $val = "$hh$mm$ss";
  }
  $val .= make_frac($test, $opts);
  return $val;
}

sub gen_time {
  my ($test, $attr, $opts) = @_;
  $opts->{sep} = myrand(2);
  $opts->{prec} = $attr->{prec};
  $opts->{ts} = 0;
  my $val = make_time($test, $opts);
  return $val;
}

sub gen_datetime {
  my ($test, $attr, $opts) = @_;
  $opts->{yystart} = 1950;
  $opts->{yyrange} = 100;
  my $d = make_date($test, $opts);
  $opts->{sep} = 1;
  $opts->{prec} = $attr->{prec};
  $opts->{ts} = 0;
  my $t = make_time($test, $opts);
  my $p = myrand(3) ? "/" : " ";
  return "$d$p$t"
}

sub gen_timestamp {
  my ($test, $attr, $opts) = @_;
  my $prec = $attr->{prec};
  $opts->{yystart} = 1971;
  $opts->{yyrange} = 64;
  my $d = make_date($test, $opts);
  $opts->{sep} = 1;
  $opts->{prec} = $attr->{prec};
  $opts->{ts} = 1;
  my $t = make_time($test, $opts);
  my $p = myrand(3) ? "/" : " ";
  return "$d$p$t"
}

sub gen_blob {
  my ($test, $attr, $opts) = @_;
  my $typeinfo = $typeinfo{$attr->{type}};
  $opts->{binary} = $typeinfo->{binary};
  $opts->{hilen} = $attr->{len};
  my $val = make_string($test, $opts);
  return $val;
}

sub gen_csvfield {
  my ($test, $table, $attr, $opts) = @_;
  my $typeinfo = $typeinfo{$attr->{type}};
  my $fenc = $test->{csvesc}{fields_enclosed_by};
  my $fesc = $test->{csvesc}{fields_escaped_by};
  my $val;
  # if value will be enclosed by
  $opts->{quote} = defined($fenc) &&
                   rand(100) < $par_quotepct;
  if (!$attr->{notnull} &&
      int(rand(100) < $par_nullpct)) {
    $val = $fesc.'N';
  } else {
    $val = $typeinfo->{gen}($test, $attr, $opts);
    if ($opts->{rejectsflag} &&
        myrand(100) < $par_nullpct) {
      $val = $fesc.'N';
      $opts->{rejectserrs}++;
    }
  }
  if ($opts->{quote}) {
    $val = "$fenc$val$fenc";
  }
  return $val;
}

sub gen_csvline {
  my ($test, $table, $opts) = @_;
  my $attrs = $table->{attrs};
  my $fter = $test->{csvesc}{fields_terminated_by};
  my $fesc = $test->{csvesc}{fields_escaped_by};
  my $lter = $test->{csvesc}{lines_terminated_by};
  my @line = ();
  if ($opts->{rejectsflag}) {
    $opts->{rejectserrs} = 0;
  }
  for my $attr (@$attrs) {
    my $val = gen_csvfield($test, $table, $attr, $opts);
    push(@line, $val);
  }
  if ($opts->{rejectsflag}) {
    if ($opts->{rejectserrs} == 0) {
      if (myrand(2) == 0) {
        my $val = $fesc.'N';
        push(@line, $val);
      } else {
        pop(@line);
      }
      $opts->{rejectserrs}++;
    }
  }
  my $line = join($fter, @line).$lter;
  return $line;
}

# write csv files

sub write_csvfile {
  my ($test, $table, $opts) = @_;
  my $file = get_csvfile($test, $table, { ver => 0 });
  my $filever = get_csvfile($test, $table, { ver => 1 });
  my $fh = gensym();
  my $fhver = gensym();
  open($fh, ">$file")
    or die "$file: open for write failed: $!";
  if ($test->{csvver}) {
    open($fhver, ">$filever")
      or die "$filever: open for write failed: $!";
  }
  my $tablename = get_tablename($test, $table, { ver => 0 });
  my $rows = $table->{rows};
  $table->{rejectsgen} = 0;
  for (my $n = 0; $n < $rows; $n++) {
    $opts->{rowid} = $n;
    $opts->{rejectsflag} = 0;
    if ($test->{rejectsgen}) {
      my $rowsleft = $rows - $n;
      my $rejectsleft = $test->{rejectsgen} - $table->{rejectsgen};
      if ($rejectsleft != 0) {
        if ($rejectsleft == $rowsleft ||
            myrand(1 + $rowsleft/$rejectsleft) == 0) {
          $opts->{rejectsflag} = 1;
          $opts->{rejectserrs} = 0;
        }
      }
    }
    my $line = gen_csvline($test, $table, $opts);
    if ($opts->{rejectsflag}) {
      $opts->{rejectserrs} or die "no rejectserrs";
      $table->{rejectsgen}++;
    }
    print $fh "$line"
      or die "$file: rowid $n: write failed: $!";
    if ($test->{csvver}) {
      if (!$opts->{rejectsflag}) {
        print $fhver "$line"
          or die "$filever: rowid $n: write failed: $!";
      }
    }
  }
  $test->{rejectsgen} == $table->{rejectsgen}
    or die "$tablename: $test->{rejectsgen} != $table->{rejectsgen}";
  close($fh)
    or die "$file: close after write failed: $!";
  if ($test->{csvver}) {
    close($fhver)
      or die "$filever: close after write failed: $!";
  }
}

sub write_csvfiles {
  my ($test, $opts) = @_;
  my $tables = $test->{tables};
  for my $table (@$tables) {
    write_csvfile($test, $table, $opts);
  }
}

1;


#!/usr/bin/perl
use strict;
use JSON;
use File::Spec::Functions qw/ canonpath /;
my $usage = "This is from WL#5257 \"first API for optimizer trace\".

Usage:
  %s [-q] <a_file> <another_file> <etc>

    -q      quiet mode: only display errors and warnings.

It will verify that all optimizer traces of files (usually a_file
is a .result or .reject file which contains
SELECT * FROM OPTIMIZER_TRACE; ) are JSON-compliant, and that
they contain no duplicates keys.
Exit code is 0 if all ok.";
my $retcode = 0;
my @ignored;
my @input = @ARGV;

# Filter out "-q" options
@input = grep {!/-q/} @input;

if (!@input)
{
  print "$usage\n";
  exit 1;
}

# If command line contains at least one "-q" option, it is quiet mode
my $quiet= scalar(@input) <= scalar(@ARGV) -1;
# On Windows, command line arguments specified using wildcards need to be evaluated.
# On Unix too if the arguments are passed with single quotes.
my $need_parse = grep(/\*/,@input);
if ($need_parse)
{
  my $platform_independent_dir;
  $platform_independent_dir= canonpath "@input";
  @input= glob "$platform_independent_dir";
}

foreach my $input_file (@input)
{
  handle_one_file($input_file);
  print "\n";
}

if ( @ignored )
{
  print STDERR "These files have been ignored:\n";
  foreach my $ig ( @ignored )
  {
    print "$ig\n";
  }
  print "\n";
}
if ( $retcode )
{
  print STDERR "There are errors\n";
}

else
{
  print "\n";
  print "ALL OK\n";
}

exit $retcode;

sub handle_one_file {

  my ( $input_file ) = @_;
  if ( $input_file =~ /^.*(ctype_.*|mysqldump)\.result/ )
  {
    push @ignored ,$input_file;
    return;
  }
  print "FILE $input_file\n";
  print "\n";
  open(DATA,"<$input_file") or die "Can't open file";
  my @lines = <DATA>;
  close(DATA);
  my $first_trace_line = 0;
  my $trace_line = 0;
  my @trace = undef;
  label_to: foreach my $i ( @lines )
  {
    $trace_line = $trace_line + 1;
    if (( grep(/^.*(\t)?{\n/,$i) ) and ( $first_trace_line == 0 ))
    {
      @trace = undef;
      $first_trace_line = $trace_line;
      push @trace, "{\n";
      next label_to;
    }
    if (( $i =~ /^}/ ) and ( $first_trace_line != 0))
    {
      push @trace, "}";
      check($first_trace_line,@trace);
      $first_trace_line = 0;
    }
    if ( $first_trace_line != 0 )
    {
      # Eliminate /* */ from end_marker=on (not valid JSON)
      $i =~ s/\/\*.*\*\// /g;
      push @trace, $i;
    }

  }
}

sub check {

  my ( $first_trace_line, @trace ) = @_;
  my $string = join("", @trace);
  my $parsed;
  eval { $parsed = decode_json($string); };
  unless ( $parsed )
  {
    print "Parse error at line: $first_trace_line\n";
    my $error = $@;
    print "Error: $@\n";
    # If there is a character position specified, put a mark ('&') in front of this character
    if ($error =~ /invalid character.*at character offset (\d+)/)
    {
      substr($string,$1,0) = "&";
      print "$string\n";
    }
    else
    {
      print "$string\n";
    }
    $retcode = 1;
    print "\n";
    return;
  }
  # Detect non-unique keys in one object, by counting
  # number of quote symbols ("): the json module outputs only
  # one of the non-unique keys, making the number of "
  # smaller compared to the input string.

  my $before = $string =~ tr/'"'//;
  my $re_json;
  $re_json= to_json($parsed);
  my $after = $re_json =~ tr/'"'//;
  if ( $before != $after )
  {
    print "Non-unique keys at line $first_trace_line ( $before vs $after )\n";
    print "$string\n";
    $retcode = 1;
    print "\n";
    return;
  }
  if ( !$quiet )
  {
    print "OK at line $first_trace_line\n";
  }
}


#!/usr/bin/perl

# Copyright (c) 2010, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

use File::Basename;
use File::Copy qw(copy);
use File::Spec qw(catdir);
use File::Path;
use IO::File;
use strict;

# Constants
my $case_header= "###############################################################################\n"
 . "# Note! The test case updated for running under blackhole slave configuration #\n"
 . "###############################################################################\n\n";
my $before_replace= "# *** BHS ***\n";
my $after_replace= "# *** /BHS ***\n";
my %copy_dirs= (
    "include"	=> "include",
    "extra"	=> "extra"
);

# Variables
my %test_dirs;
my @update_test_cases;
my %rules;
my $opt_trans_test_list;

print "Creating suite rpl_bhs\n";

# *** Set platform-independent pathes ***

# Set extension directory
my $ext_dir= dirname(File::Spec->rel2abs($0));
# Set bhs directory
my $bhs_dir= File::Spec->catdir($ext_dir, "bhs");
# Set mysql-test directory
my $mysql_test_dir= $ext_dir;
$mysql_test_dir =~ s/(\/|\\)suite(\/|\\)rpl(\/|\\)extension$//;
# Set path to mtr
my $mtr_script = File::Spec->catdir($mysql_test_dir, "mysql-test-run.pl");
# Set directory of rpl suite
my $suite_rpl_dir = File::Spec->catdir($mysql_test_dir, "suite", "rpl");
# Set directory of rpl_bhs suite
my $suite_rpl_bhs_dir = File::Spec->catdir($mysql_test_dir, "suite", "rpl_bhs");
# Set test cases mask with path
my $suite_rpl_bhs_cases_dir = File::Spec->catdir($suite_rpl_bhs_dir, "t");

# Check first argument
if ($ARGV[0] =~ m/\-\-trans\-test\-list=(.+)/i)
{
    $opt_trans_test_list= File::Spec->catdir($suite_rpl_bhs_dir, $1);
    shift @ARGV;
    $mtr_script= "perl " . $mtr_script . " " . join(" ", @ARGV);
}
else
{
    die("First argument of bhs.pl must be --trans-test-list with path to test case list");
}

# *** Copy files ***

# Copy rpl suite into rpl_bhs
print "copying:\n  $suite_rpl_dir\n  --> $suite_rpl_bhs_dir\n";
dircopy($suite_rpl_dir, $suite_rpl_bhs_dir);

# Copy additional dirs outside of rpl suite
foreach my $cur_dir (keys %copy_dirs)
{
    my $from_dir= File::Spec->catdir($mysql_test_dir, $cur_dir);
    my $to_dir= File::Spec->catdir($suite_rpl_bhs_dir, $copy_dirs{$cur_dir});
    print "  $from_dir\n  --> $to_dir\n";
    dircopy($from_dir, $to_dir);
}

# Copy server config files
print "  configuration files\n";
copy(File::Spec->catdir($ext_dir, "bhs", "my.cnf"), $suite_rpl_bhs_dir);
copy(File::Spec->catdir($ext_dir, "bhs", "rpl_1slave_base.cnf"), $suite_rpl_bhs_dir);

# Add BHS disabled.def
print "updating disabled.def\n";
my $fh = new IO::File File::Spec->catdir($bhs_dir, "disabled.def"), "r";
if (defined $fh) {
    my @disabled = <$fh>;
    undef $fh;
    my $fh = new IO::File File::Spec->catdir($suite_rpl_bhs_dir, "t", "disabled.def"), O_WRONLY|O_APPEND;
    if (defined $fh) {
	print $fh join ("", @disabled);
	undef $fh;
    }
}

# *** Update test cases

# Read update_rules
my $fh = new IO::File File::Spec->catdir($bhs_dir, "update_test_cases"), "r";
if (defined $fh) {
    @update_test_cases = <$fh>;
    undef $fh;
}

foreach my $update (@update_test_cases)
{
    $update =~ s/\s//g;
    my ($tmpl, $file)= split(/\:/, $update);
    $file= File::Spec->catdir($bhs_dir, $file);
    $fh = new IO::File $file, "r";
    if (defined $fh)
    {
	my @lines= <$fh>;
	undef $fh;
	my $found= "";
	my $replace= "";
	my $line_num= 0;
	foreach my $line (@lines)
	{
	    if ($line =~ m/^\s*\[(.+)\]\s*$/ && $found eq "")
	    {
		$found= $1;
	    }
	    elsif ($line =~ m/^\s*\[(.+)\]\s*$/ && $found ne "")
	    {
		$rules{$tmpl}{$found} = $replace;
		chomp $rules{$tmpl}{$found};
		$found= $1;
		$replace= "";
		$line_num= 0;
	    }
	    elsif ($line !~ m/^\s*$/)
	    {
		$replace .= $line;
		$line_num++;
	    }
	}
	if ($found ne "")
	{
	    $rules{$tmpl}{$found}= $replace;
	}
    }
}

for (my $i = 0; $i < scalar(@update_test_cases); $i++)
{
    if ($update_test_cases[$i] =~ m/(.+)\:.+/)
    {
	$update_test_cases[$i]= $1;
	my @cur_path= split(/\//, $update_test_cases[$i]);
	$update_test_cases[$i]= File::Spec->catdir(@cur_path);
	# Collect directories with test cases
	pop(@cur_path);
	$test_dirs{File::Spec->catdir(@cur_path)}= 1;
    }
}

# Updating test cases
my $case_num= 0;
foreach my $test_dir (keys %test_dirs)
{
    # Read list of test cases
    my $cur_path= File::Spec->catdir($suite_rpl_bhs_dir, $test_dir);
    opendir(my $dh, $cur_path) or exit(1);
    my @cases = grep(/\.(test|inc)$/,readdir($dh));
    closedir($dh);
    foreach my $case (sort @cases)
    {
	my $case2= File::Spec->catdir($test_dir, $case);
	foreach my $update_case (@update_test_cases)
	{
	    my @paths= split(/\//, $update_case);
	    my $update_case2= File::Spec->catdir(@paths);
	    if (compare_names($case2, $update_case2) == 1)
	    {
		$fh = new IO::File File::Spec->catdir($cur_path, $case), "r";
		my @lines;
		if (defined $fh)
		{
		    @lines = <$fh>;
		    undef $fh;
		}
		my $content= "";
		foreach my $line (@lines)
		{
		    foreach my $cmd (keys %{$rules{$update_case}})
		    {
			if ($line =~ m/$cmd/i)
			{
			    my $orig_line= "# Replaced command: " . $line;
			    $line =~ s/$cmd/$rules{$update_case}{$cmd}/;
			    $line =~ s/\n\n$/\n/;
			    $line = $before_replace . $orig_line . $line . $after_replace;
			    last;
			}
		    }
		    $content .= $line;
		}
		$fh = new IO::File File::Spec->catdir($cur_path, $case), "w";
		if (defined $fh)
		{
		    print $fh $case_header . $content;
		    undef $fh;
		}
		$case_num++;
		last;
	    }
	}
    }
}

print "updated $case_num files\n";

print "Run $mtr_script\n";

system( $mtr_script );

sub compare_names
{
    my ($test, $rule)= @_;
    my $res= 0;
    $res= 1 if ($test eq $rule);
    if ($rule =~ m/\*/)
    {
	$rule =~ s/(\\|\/)+/\ /g;
	$rule =~ s/\*/\.\*/g;
	$test =~ s/(\\|\/)+/\ /g;
	$res= 1 if ($test =~ m/^$rule$/i)
    }
    return $res;
}

sub dircopy
{
    my ($from_dir, $to_dir)= @_;
    mkdir $to_dir if (! -e $to_dir);
    opendir my($dh), $from_dir or die "Could not open dir '$from_dir': $!";
    for my $entry (readdir $dh)
    {
	next if $entry =~ /^(\.|\.\.)$/;
        my $source = File::Spec->catdir($from_dir, $entry);
        my $destination = File::Spec->catdir($to_dir, $entry);
        if (-d $source)
        {
    	    mkdir $destination or die "mkdir '$destination' failed: $!" if not -e $destination;
            dircopy($source, $destination);
        }
        else
        {
    	    copy($source, $destination) or die "copy '$source' to '$destination' failed: $!";
        }
    }
    closedir $dh;
    return;
}


#!/usr/bin/perl

# Copyright (c) 2010, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

use File::Basename;
use File::Copy qw(copy);
use File::Spec qw(catdir);
use File::Path;
use IO::File;
use strict;

# Constants and variables with default values
my $suites;
my $suffix = "_checksum";
my $percent_random_test = 10;
my $mtr_script;
my @mtr_argv;
my @mtr_suites;

# Check some arguments
foreach my $arg ( @ARGV )
{
    if ($arg =~ m/\-\-suite\=(.+)/i)
    {
        $suites = $1;
    }
    elsif ($arg =~ m/\-\-percent\=(\d{1,2})/i)
    {
	$percent_random_test= $1;
    }
    else
    {
	push(@mtr_argv, $arg);
    }

}
if (! defined( $suites ) )
{
    die("The script requires --suite argument");
}

print "#################################################################\n";
print "# Binlog checksum testing\n";
print "# Run randomly $percent_random_test\% of tests from following suites: $suites\n";
print "#################################################################\n";

# Set extension directory
my $ext_dir= dirname(File::Spec->rel2abs($0));
# Set mysql-test directory
my $mysql_test_dir= $ext_dir;
$mysql_test_dir =~ s/(\/|\\)suite(\/|\\)rpl(\/|\\)extension$//;

# Main loop
foreach my $src_suite (split(",", $suites))
{
    $src_suite=~ s/ //g;
    my $dest_suite= $src_suite . $suffix;
    push( @mtr_suites, $dest_suite);
    print "Creating suite $dest_suite\n";
    # *** Set platform-independent pathes ***
    # Set source directory of suite
    my $src_suite_dir = File::Spec->catdir($mysql_test_dir, "suite", $src_suite);
    # Set destination directory of suite
    my $dest_suite_dir = File::Spec->catdir($mysql_test_dir, "suite", $dest_suite);
    print "Copying files\n\tfrom '$src_suite_dir'\n\tto '$dest_suite_dir'\n";
    dircopy($src_suite_dir, $dest_suite_dir);
    my $test_case_dir= File::Spec->catdir($dest_suite_dir, "t");
    # Read disabled.def
    my %disabled = ();
    print "Read disabled.def\n";
    my $fh = new IO::File File::Spec->catdir($test_case_dir, "disabled.def"), "r";
    if ( defined $fh )
    {
	my @lines = <$fh>;
	undef $fh;
	foreach my $line ( @lines )
	{
	    if ($line =~ m/^([a-zA-Z0-9_]+).+\:.+/i)
	    {
		$disabled{$1}= 1;
	    }
	}
    }
    # Read test case list
    my %tests = ();
    print "Generate test case list\n";
    opendir my ($dh), $test_case_dir or die "Could not open dir '$test_case_dir': $!";
    for my $entry (readdir $dh)
    {
	if ( $entry =~ m/^([a-zA-Z0-9_]+)\.test$/i )
	{
	    my $test= $1;
	    if ( ! defined( $disabled{$test}) )
	    {
		$tests{$test}= 1;
	    }
	}
    }
    closedir($dh);
    #
    my @excluded = ();
    my $excluded_test= int((((100 - $percent_random_test)/100) * scalar( keys %tests )));
    while  ( $excluded_test > 0 )
    {
	my @cases = keys %tests;
	my $test = $cases[int(rand(scalar(@cases)))];
	push ( @excluded, $test . "\t\t: Excluded for $dest_suite\n" );
	delete $tests{$test};
	$excluded_test--;
    }
    my $fh = new IO::File File::Spec->catdir($test_case_dir, "disabled.def"), O_WRONLY|O_APPEND;
    if (defined $fh) {
	print $fh join ("", sort @excluded);
	undef $fh;
    }
    print "\t" . join("\n\t", sort keys %tests) . "\n";

}

# Set path to mtr with arguments
my $mtr_script = "perl " . File::Spec->catdir($mysql_test_dir, "mysql-test-run.pl") .
    " --suite=" . join(",", @mtr_suites) . " " .
    " --mysqld=--binlog-checksum=CRC32 " .
    join (" ", @mtr_argv);

print "Run $mtr_script\n";
system( $mtr_script );

sub dircopy
{
    my ($from_dir, $to_dir)= @_;
    mkdir $to_dir if (! -e $to_dir);
    opendir my($dh), $from_dir or die "Could not open dir '$from_dir': $!";
    for my $entry (readdir $dh)
    {
	next if $entry =~ /^(\.|\.\.)$/;
        my $source = File::Spec->catdir($from_dir, $entry);
        my $destination = File::Spec->catdir($to_dir, $entry);
        if (-d $source)
        {
    	    mkdir $destination or die "mkdir '$destination' failed: $!" if not -e $destination;
            dircopy($source, $destination);
        }
        else
        {
    	    copy($source, $destination) or die "copy '$source' to '$destination' failed: $!";
        }
    }
    closedir $dh;
    return;
}


#! /usr/bin/perl
#
use warnings;
use strict;

use IO::Socket::INET;

use FindBin;

@ARGV == 1 or @ARGV == 2
    or die "Usage: $FindBin::Script HOST:PORT [COUNT]\n";

# Note that it's better to run the test over the wire, because for
# localhost the task may become CPU bound.
my $addr = $ARGV[0];
my $count = $ARGV[1] || 10_000;

my $sock = IO::Socket::INET->new(PeerAddr => $addr,
                                 Timeout  => 3);
die "$!\n" unless $sock;

# By running 'noreply' test first we also ensure there are no reply
# packets left in the network.
foreach my $noreply (1, 0) {
    use Time::HiRes qw(gettimeofday tv_interval);

    print "'noreply' is ", $noreply ? "enabled" : "disabled", ":\n";
    my $param = $noreply ? 'noreply' : '';
    my $start = [gettimeofday];
    foreach (1 .. $count) {
        print $sock "add foo 0 0 1 $param\r\n1\r\n";
        scalar<$sock> unless $noreply;
        print $sock "set foo 0 0 1 $param\r\n1\r\n";
        scalar<$sock> unless $noreply;
        print $sock "replace foo 0 0 1 $param\r\n1\r\n";
        scalar<$sock> unless $noreply;
        print $sock "append foo 0 0 1 $param\r\n1\r\n";
        scalar<$sock> unless $noreply;
        print $sock "prepend foo 0 0 1 $param\r\n1\r\n";
        scalar<$sock> unless $noreply;
        print $sock "incr foo 1 $param\r\n";
        scalar<$sock> unless $noreply;
        print $sock "decr foo 1 $param\r\n";
        scalar<$sock> unless $noreply;
        print $sock "delete foo $param\r\n";
        scalar<$sock> unless $noreply;
    }
    my $end = [gettimeofday];
    printf("update commands: %.2f secs\n\n", tv_interval($start, $end));
}


#!/usr/bin/perl
use strict;
use FindBin qw($Bin);
chdir "$Bin/.." or die;
my @files = (glob("*.h"), glob("*.c"), glob("*.ac"), glob("./win32/*.c"), glob("./win32/*.h"), glob("./m4/*.m4"));

foreach my $f (@files) {
    open(my $fh, $f) or die;
    my $before = do { local $/; <$fh>; };
    close ($fh);
    my $after = $before;
    $after =~ s/\t/    /g;
    $after =~ s/ +$//mg;
    $after .= "\n" unless $after =~ /\n$/;
    next if $after eq $before;
    open(my $fh, ">$f") or die;
    print $fh $after;
    close($fh);
}


#!/usr/bin/perl

use strict;
use FindBin qw($Bin);

my %branch = (
              '1.2.x' => "http://code.sixapart.com/svn/memcached/trunk/server",
              '1.1.x' => "http://code.sixapart.com/svn/memcached/branches/memcached-1.1.x",
              );

foreach my $b (keys %branch) {
    chdir $Bin or die;
    my $url = $branch{$b};
    my $out = `svn info $b`;
    unless ($out =~ /^URL: (.+)/m && $1 eq $url) {
        system("rm -rf $b");
        system("svn", "co", $url, $b)
            and die "Failed to checkout $url\n";
    } else {
        chdir "$Bin/$b" or die;
        system("svn up") and die "Failed to svn up";
    }

    chdir "$Bin/$b" or die;
    $out = `svn info .`;

    my ($maxrev) = $out =~ /^Last Changed Rev: (\d+)/m
        or die "No max rev?";

    print "$b = $maxrev\n";
    my $distfile = "memcached-$b-svn$maxrev.tar.gz";
    next if -f $distfile && -s _;

    open(my $fh, "configure.ac") or die "no configure.ac in $b?";
    my $ac = do { local $/; <$fh>; };
    close($fh);
    $ac =~ s!AC_INIT\(memcached,.+?\)!AC_INIT(memcached, $b-svn$maxrev, brad\@danga.com)!
        or die "Failed to replace";
    open (my $fh, ">configure.ac") or die "failed to write configure.ac writeable: $!";
    print $fh $ac;
    close ($fh);

    system("./autogen.sh") and die "Autogen failed.  Missing autotools?";
    system("./configure") and die "configure failed";
    system("make dist") and die "make dist failed";
    die "Failed to make dist $distfile." unless -s $distfile;
}


#!/usr/bin/perl
#

use strict;
use lib '../../api/perl/lib';
use Cache::Memcached;
use Time::HiRes qw(time);

unless (@ARGV == 2) {
    die "Usage: stress-memcached.pl ip:port threads\n";
}

my $host = shift;
my $threads = shift;

my $memc = new Cache::Memcached;
$memc->set_servers([$host]);

unless ($memc->set("foo", "bar") &&
        $memc->get("foo") eq "bar") {
    die "memcached not running at $host ?\n";
}
$memc->disconnect_all();

my $running = 0;
while (1) {
    if ($running < $threads) {
        my $cpid = fork();
        if ($cpid) {
            $running++;
            #print "Launched $cpid.  Running $running threads.\n";
        } else {
            stress();
            exit 0;
        }
    } else {
        wait();
        $running--;
    }
}

sub stress {
    undef $memc;
    $memc = new Cache::Memcached;
    $memc->set_servers([$host]);

    my ($t1, $t2);
    my $start = sub { $t1 = time(); };
    my $stop = sub {
        my $op = shift;
        $t2 = time();
        my $td = sprintf("%0.3f", $t2 - $t1);
        if ($td > 0.25) { print "Took $td seconds for: $op\n"; }
    };

    my $max = rand(50);
    my $sets = 0;

    for (my $i = 0; $i < $max; $i++) {
        my $key = key($i);
        my $set = $memc->set($key, $key);
        $sets++ if $set;
    }

    for (1..int(rand(500))) {
        my $rand = int(rand($max));
        my $key = key($rand);
        my $meth = int(rand(3));
        my $exp = int(rand(3));
        undef $exp unless $exp;
        $start->();
        if ($meth == 0) {
            $memc->add($key, $key, $exp);
            $stop->("add");
        } elsif ($meth == 1) {
            $memc->delete($key);
            $stop->("delete");
        } else {
            $memc->set($key, $key, $exp);
            $stop->("set");
        }
        $rand = int(rand($max));
        $key = key($rand);
        $start->();
        my $v = $memc->get($key);
        $stop->("get");
        if ($v && $v ne $key) { die "Bogus: $v for key $rand\n"; }
    }

    $start->();
    my $multi = $memc->get_multi(map { key(int(rand($max))) } (1..$max));
    $stop->("get_multi");
}

sub key {
    my $n = shift;
    $_ = sprintf("%04d", $n);
    if ($n % 2) { $_ .= "a"x20; }
    $_;
}


#! /usr/bin/perl
#
# Copyright (c) 2017, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# 51 Franklin Street, Suite 500, Boston, MA 02110-1335 USA
#

#
# Take the given GCC command line and run it with all absolute paths
# changed to relative paths. This makes sure that no part of the build
# path leaks into the .o files, which it normally would through the
# contents of __FILE__. (Debug information is also affected, but that
# is already fixed through -fdebug-prefix-map=.)
#
# A more elegant solution would be -ffile-prefix-map=, but this is
# not currently supported in GCC; see
# https://gcc.gnu.org/bugzilla/show_bug.cgi?id=70268.
#

use strict;
use warnings;
use Cwd;

my $cwd = getcwd();

my @newarg = ();
for my $i (0..$#ARGV) {
	my $arg = $ARGV[$i];
	if ($arg =~ /-I(.+)$/) {
		$arg = '-I' . relativize($1, $cwd);
	} elsif ($arg =~ /^\//) {
		$arg = relativize($arg, $cwd);
	}
	push @newarg, $arg;
}

exec(@newarg);

# /a/b/c/foo from /a/b/d = ../c/foo
sub relativize {
	my ($dir1, $dir2) = @_;

	if ($dir1 !~ /^\//) {
		# Not an absolute path.
		return $dir1;
	}

	if (! -e $dir1) {
		print STDERR "Unknown file/directory $dir1.\n";
		return $dir1;
	}
	# Resolve symlinks and such, because getcwd() does.
	$dir1 = Cwd::abs_path($dir1);

	if ($dir1 =~ /^\/(lib|tmp|usr)/) {
		# Not related to our source code.
		return $dir1;
	}

	if ($dir1 eq $dir2) {
		return ".";
	}

	my (@dir1_components) = split /\//, $dir1;
	my (@dir2_components) = split /\//, $dir2;

	# Remove common leading components.
	while (scalar @dir1_components > 0 && scalar @dir2_components > 0 &&
	       $dir1_components[0] eq $dir2_components[0]) {
		shift @dir1_components;
		shift @dir2_components;
	}

	my $ret = "";
	for my $i (0..$#dir2_components) {
		$ret .= '../';
	}
	$ret .= join('/', @dir1_components);

	# print STDERR "[$dir1] from [$dir2] => [$ret]\n";

	return $ret;
}


#! /usr/bin/perl
#
# Copyright (c) 2017, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# 51 Franklin Street, Suite 500, Boston, MA 02110-1335 USA
#

#
# Randomize each .text and .data name (unless it is already randomized),
# so that we get a different order of all the symbols in the final binary
# (assuming -ffunction-sections -fdata-sections and -Wl,--sort-section=name).
# This makes it possible to see if a performance change is due to
# semirandom address positioning effects or a genuine change that will be
# robust to other, unrelated changes.
#
# Usage: randomize-order.pl SEED [OBJFILES...]

use strict;
use warnings;
use Digest::SHA;

my $seed = shift @ARGV;

for my $objfile (@ARGV) {
	my @objcopy_args = ();

	# Read in the list of sections, and find all that start with .text or .data.
	open my $objdumpfh, "-|", "objdump", "-h", $objfile
		or die "objdump: $!";
	while (<$objdumpfh>) {
		chomp;
		if (/^\s*\d+\s*(\.text|\.data)\.(\S+)\s*/) {
			my ($section_type, $section_name) = ($1, $2);

			# Leave already reordered sections alone.
			next if ($section_name =~ /\.__random_order$/);

			my $new_name = Digest::SHA::sha256_hex($seed . $section_name) . ".__random_order";
			push @objcopy_args, "--rename=$section_type.$section_name=$section_type.$new_name";
		}
	}
	close $objdumpfh;

	while (scalar @objcopy_args > 0) {
		# Some targets are too big for one objcopy run in debug mode
		# (the command line gets too long); split into smaller chunks.
		my @args;
		if (scalar @objcopy_args >= 4096) {
			@args = @objcopy_args[0..4095];
			@objcopy_args = @objcopy_args[4096..$#objcopy_args];
		} else {
			@args = @objcopy_args;
			@objcopy_args = ();
		}

		system("objcopy", @args, $objfile, "$objfile.tmp") == 0
			or die "objcopy: $?";
		rename("$objfile.tmp", $objfile)
			or die "rename($objfile): $!";
	}
}


#!/usr/bin/perl

# Copyright (c) 2003, 2005 MySQL AB
# Use is subject to license terms
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA

# compares out-files (as created by Ereport.pl) from dir1/*.out and dir2/*.out
# for each effectiveness column computes the probability of the hypothesis
# "Both files have the same effectiveness"

# sign test is used to verify that test results are statistically
# significant to support the hypothesis. Function is computed on the fly.

# basic formula is \sum_{r=0}^R C_N^r 2^{-N}
# As N can be big, we'll work with logarithms
$log2=log(2);
sub probab {
  my $N=shift, $R=shift;

  my $r, $sum=0;

  for $r (0..$R) {
    $sum+=exp(logfac($N)-logfac($r)-logfac($N-$r)-$N*$log2);
  }
  return $sum;
}

# log(N!)
# for N<20 exact value from the table (below) is taken
# otherwise, Stirling approximation for N! is used
sub logfac {
  my $n=shift; die "n=$n<0" if $n<0;
  return $logfactab[$n] if $n<=$#logfactab;
  return $n*log($n)-$n+log(2*3.14159265358*$n)/2;
}
@logfactab=(
0,    0,         0.693147180559945, 1.79175946922805, 3.17805383034795,
4.78749174278205, 6.57925121201010, 8.52516136106541, 10.6046029027453,
12.8018274800815, 15.1044125730755, 17.5023078458739, 19.9872144956619,
22.5521638531234, 25.1912211827387, 27.8992713838409, 30.6718601060807,
33.5050734501369, 36.3954452080331, 39.3398841871995, 42.3356164607535,
);

############################# main () ###############################
#$p=shift; $m=shift; $p-=$m;
#if($p>$m) {
#  print "1 > 2 [+$p-$m]: ", probab($p+$m, $m), "\n";
#} elsif($p<$m) {
#  print "1 < 2 [+$p-$m]: ", probab($p+$m, $p), "\n";
#} else {
#  print "1 = 2 [+$p-$m]: ", probab($p+$m, $m), "\n";
#}
#exit;

die "Use: $0 dir1 dir2\n" unless @ARGV==2 &&
                             -d ($dir1=shift) && -d ($dir2=shift);
$_=`cd $dir1; echo *.out`;
s/\.out\b//g;
$total="";

for $file (split) {
  open(OUT1,$out1="$dir1/$file.out") || die "Cannot open $out1: $!";
  open(OUT2,$out2="$dir2/$file.out") || die "Cannot open $out2: $!";

  @p=@m=();
  while(!eof(OUT1) || !eof(OUT2)) {
    $_=<OUT1>; @l1=split; shift @l1;
    $_=<OUT2>; @l2=split; shift @l2;

    die "Number of columns differ in line $.\n" unless $#l1 == $#l2;

    for (0..$#l1) {
      $p[$_]+= $l1[$_] > $l2[$_];
      $m[$_]+= $l1[$_] < $l2[$_];
    }
  }

  for (0..$#l1) {
    $pp[$_]+=$p[$_]; $mm[$_]+=$m[$_];
    $total[$_].=rep($file, ($#l1 ? $_ : undef), $p[$_], $m[$_]);
  }
  close OUT1;
  close OUT2;
}

for (0..$#l1) {
  rep($total[$_], ($#l1 ? $_ : undef), $pp[$_], $mm[$_]);
}

sub rep {
  my ($test, $n, $p, $m, $c, $r)=@_;

  if   ($p>$m) { $c=">"; $r="+"; }
  elsif($p<$m) { $c="<"; $r="-"; }
  else         { $c="="; $r="="; }
  $n=" $n: " if defined $n;
  printf "%-8s $n $dir1 $c $dir2 [+%03d-%03d]: %16.15f\n",
          $test, $p, $m, probab($p+$m, ($p>=$m ? $m : $p));
  $r;
}


#!/usr/bin/perl

# Copyright (c) 2003, 2005 MySQL AB
# Use is subject to license terms
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA

$test=shift || die "Usage $0 testname [option]";
$option=shift;

open(D, "<data/$test.d") || die "Cannot open(<data/$test.d): $!";
open(Q, "<data/$test.q") || die "Cannot open(<data/$test.q): $!";

$N=0;

print <<__HEADER__;
DROP TABLE IF EXISTS $test;
CREATE TABLE $test (
  id int(10) unsigned NOT NULL,
  text text NOT NULL,
  FULLTEXT KEY text (text)
) TYPE=MyISAM CHARSET=latin1;

ALTER TABLE $test DISABLE KEYS;
__HEADER__

while (<D>) { chomp;
  s/'/\\'/g; ++$N;
  print "INSERT $test VALUES ($N, '$_');\n";
}

print <<__PREP__;
ALTER TABLE $test ENABLE KEYS;
SELECT $N;
__PREP__

$N=0;

while (<Q>) { chomp;
  s/'/\\'/g; ++$N;
  $_="MATCH text AGAINST ('$_' $option)";
  print "SELECT $N, id, $_ FROM $test WHERE $_;\n";
}

print <<__FOOTER__;
DROP TABLE $test;
__FOOTER__


#!/usr/bin/perl

# Copyright (c) 2003, 2005 MySQL AB
# Use is subject to license terms
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA

die "Use: $0 eval_output qrels_file\n" unless @ARGV==2;

open(EOUT,$eout=shift) || die "Cannot open $eout: $!";
open(RELJ,$relj=shift) || die "Cannot open $relj: $!";

$_=<EOUT>;
die "$eout must start with a number!\n "unless /^[1-9][0-9]*\n/;
$ndocs=$_+0;

$qid=0;
$relj_str=<RELJ>;
$eout_str=<EOUT>;

while(!eof(RELJ) || !eof(EOUT)) {
  ++$qid;
  %dq=();
  $A=$B=$AB=0;
  $Ravg=$Pavg=0;

  while($relj_str =~ /^0*$qid\s+(\d+)/) {
    ++$A;
    $dq{$1+0}=1;
    last unless $relj_str=<RELJ>;
  }
  # Favg measure = 1/(a/Pavg+(1-a)/Ravg)
sub Favg { my $a=shift; $Pavg*$Ravg ? 1/($a/$Pavg+(1-$a)/$Ravg) : 0; }
  # F0    : a=0                 -- ignore precision
  # F5    : a=0.5
  # F1    : a=1                 -- ignore recall
  while($eout_str =~ /^$qid\s+(\d+)\s+(\d+(?:\.\d+)?)/) {
    $B++;
    $AB++ if $dq{$1+0};
    $Ravg+=$AB;
    $Pavg+=$AB/$B;
    last unless $eout_str=<EOUT>;
  }
  next unless $A;

  $Ravg/=$B*$A if $B;
  $Pavg/=$B    if $B;

  printf "%5d %1.12f %1.12f %1.12f\n", $qid, Favg(0),Favg(0.5),Favg(1);
}

exit 0;


# Copyright (C) 2003, 2005 MySQL AB
# Use is subject to license terms
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301  USA

#
#  Written by Lars Thalmann, lars@mysql.com, 2003.
#

use strict;
umask 000;

# -----------------------------------------------------------------------------
#   Settings
# -----------------------------------------------------------------------------

$ENV{LD_LIBRARY_PATH} = "/usr/local/lib:/opt/as/local/lib";
$ENV{LD_LIBRARY_PATH} = $ENV{LD_LIBRARY_PATH} . ":/opt/as/forte6/SUNWspro/lib";
$ENV{PATH} = $ENV{PATH} . ":/usr/local/bin:/opt/as/local/bin";
$ENV{PATH} = $ENV{PATH} . ":/opt/as/local/teTeX/bin/sparc-sun-solaris2.8";

my $destdir = @ARGV[0];
my $title = ""; # $ARGV[1];

my $release;
if (defined $ENV{'NDB_RELEASE'}) {
    $release = $ENV{'NDB_RELEASE'};
    print "----------------------------------------------------------------\n";
    print "Relase = " . $release . "\n";
    print "----------------------------------------------------------------\n";
} else {
    print "----------------------------------------------------------------\n";
    print "NDB Documentation is being modified to statndard format\n";
    print "(If you want this automatic, use env variable NDB_RELEASE.)\n";
    print "Enter release (Examples: \"1.43.0 (alpha)\" or \"2.1.0 (gamma)\"): ";
    $release = <stdin>;
    print "----------------------------------------------------------------\n";
}

# -----------------------------------------------------------------------------
#  Change a little in refman.tex
# -----------------------------------------------------------------------------

open (INFILE, "< ${destdir}/refman.tex")
    or die "Error opening ${destdir}/refman.tex.\n";
open (OUTFILE, "> ${destdir}/refman.tex.new")
    or die "Error opening ${destdir}/refman.tex.new.\n";

while (<INFILE>)
{
    if (/(.*)(RELEASE)(.*)$/) {
	print OUTFILE $1 . $release . $3;
    } elsif (/(.*)(DATE)(.*)$/) {
	print OUTFILE $1 . localtime() . $3;
    } elsif (/\\chapter\{File Index\}/) {
	# Erase
    } elsif (/\\input\{files\}/) {
	# Erase
    } elsif (/\\chapter\{Hierarchical Index\}/) {
	# Erase
    } elsif (/\\input\{hierarchy\}/) {
	# Erase
    } elsif (/\\chapter\{Page Index\}/) {
	# Erase
    } elsif (/\\input\{pages\}/) {
	# Erase
    } else {
	print OUTFILE;
    }
}

close INFILE;
close OUTFILE;

system("mv ${destdir}/refman.tex.new ${destdir}/refman.tex");

# -----------------------------------------------------------------------------
#  Change a little in doxygen.sty
# -----------------------------------------------------------------------------

open (INFILE, "< ${destdir}/doxygen.sty")
    or die "Error opening INFILE.\n";
open (OUTFILE, "> ${destdir}/doxygen.sty.new")
    or die "Error opening OUTFILE.\n";

while (<INFILE>)
{
    if (/\\rfoot/) {
	print OUTFILE "\\rfoot[\\fancyplain{}{\\bfseries\\small \\copyright~Copyright 2003-2008 MySQL AB, 2008 Sun Microsystems, Inc.\\hfill support-cluster\@mysql.com}]{}\n";
    } elsif (/\\lfoot/) {
	print OUTFILE "\\lfoot[]{\\fancyplain{}{\\bfseries\\small support-cluster\@mysql.com\\hfill \\copyright~Copyright 2003-2008 MySQL AB, 2008 Sun Microsystems, Inc.}}\n";
    } else {
	print OUTFILE;
    }
}

close INFILE;
close OUTFILE;

system("mv ${destdir}/doxygen.sty.new ${destdir}/doxygen.sty");


# Copyright (C) 2003, 2005 MySQL AB, 2010 Sun Microsystems, Inc.
#  All rights reserved. Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301  USA

#
#  Written by Lars Thalmann, lars@mysql.com, 2003.
#

use strict;
umask 000;

# -----------------------------------------------------------------------------
#  Fix HTML Footer
# -----------------------------------------------------------------------------

open (OUTFILE, "> footer.html");

print OUTFILE<<EOT;

<address>

EOT
print OUTFILE "Documentation generated " . localtime() .
    " from mysql source files.";
print OUTFILE<<EOT;

© 2003, 2005 MySQL AB, 2010 Sun Microsystems, Inc.

</address>

EOT

print "Preformat finished\n\n";


#! /usr/bin/env perl

# -*- cperl -*-

# Copyright (c) 2013, 2015, Oracle and/or its affiliates.
# All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301  USA

################ TODO ################################
###  * Library improvements here should be ported back to mtr;
###    CMake should automatically copy in My/Memcache.pm as part of build
###  * Library should support explicit binary k/q commands with pipelining
###  * Implement TOUCH & GAT commands in library & utility (and server?)
###  * Support UDP
###  * Standardize library APIs to take (key, value, hashref-of-options)

use strict;
use Term::ReadLine;
use Getopt::Std;
use Term::ANSIColor qw(:constants);
use Text::Balanced qw(extract_quotelike);

our $VERSION = "1.0";
my $mc;      # Memcache connection

sub HELP_MESSAGE {
  my $fh = shift;
  print $fh "\n".
            "memclient [-a|-b] [host] [port] \n" .
            " -a: use ASCII protocol (default) \n" .
            " -b: use binary protocol \n" .
            "  host defaults to localhost; port defaults to 11211 \n\n";
}

$Getopt::Std::STANDARD_HELP_VERSION = 1;
our ($opt_a, $opt_b);
if(! getopts('ab')) { HELP_MESSAGE(\*STDOUT) ; exit 1 }
my $proto = $opt_b ? "binary" : "ASCII";
my $host = shift || "localhost";
my $port = shift || 11211;

### RUNTIME HELP
my %help = (
  "get"       => "<key> [ <key> ... ]",
  "delete"    => "<key>",
  "set"       => "<key> <value> [flags: <N> | expires: <N> ]",
  "add"       => "<key> <value> [flags: <N> | expires: <N> ]",
  "replace"   => "<key> <value> [flags: <N> | expires: <N> | cas: <N> ]",
  "flush_all" => "",
  "append"    => "<key> <text>",
  "prepend"   => "<key> <text>",
  "incr"      => "<key> <delta>",
  "decr"      => "<key> <delta>",
  "stats"     => "[stat-key]",
  "flags:"    => "<value>    -- Set default flags for storage operations",
  "expires:"  => "<value>    -- Set default expire time for storage operations",
  "quit"      => "quit memclient",
  "reconnect" => "reconnect to server"
);

if($opt_b)
{ # Binary Protocol only
}
else
{ # ASCII Protocol only
  $help{"gets"} = "<key> [ <key> ... ]   -- ASCII GET with CAS";
}

sub help {
  my $response = "Commands:\n";
  $response .= sprintf("%s %-10s %s %s\n",BOLD, $_, RESET, $help{$_})
    for sort keys(%help);
  return $response;
}

### Set up readline
my $term = new Term::ReadLine 'memclient';
my $prompt = "memcache > ";

my $attribs = $term->Attribs;
$attribs->{completion_function} = sub {
  my ($text, $line, $start) = @_;
  return grep(/^$text/, qw(get gets delete set add replace flush_all stats
                           incr decr append prepend expires: flags: cas: ));
};

my $OUT = $term->OUT || \*STDOUT;
print $OUT "Memclient $VERSION using " .  $term->ReadLine . "\n";

# Connect
$mc = $opt_b ? $mc = My::Memcache::Binary->new() : My::Memcache->new();
print "Attempting $proto connection to $host:$port ...\n";
my $r = $mc->connect($host, $port);
print ($r ? "Connected.\n" : "Connection failed.\n");
exit(1) unless($r);

### Main command loop
while ( defined ($_ = $term->readline($prompt)) ) {
  my $res = run_cmd($_);
  print $OUT $res, "\n" if($res);
  $term->addhistory($_) if /\S/;
}

### Run "get" and display result
sub run_get_cmd {
  return args_err("get") unless length($_[0]);
  my @keys = ($_[0]);
  push @keys, split(" ", $_[1]);
  my $value = $mc->get(@keys);
  my $with_cas = ( $proto eq "binary" || $mc->{has_cas} );
  return $mc->{error} if $mc->{error} ne "OK";

  ### Header line
  my $response = UNDERSCORE . "       KEY        | FLAGS |";
  $response .= $with_cas ? "       CAS      |VALUE\n" : "Value\n";
  $response .= RESET;

  ### Result lines
  while(my $r = $mc->next_result())
  {
    if($with_cas)
    {
      $response .= sprintf("%-18s| %-5u |%-16s|%s\n",
                           $$r{key}, $$r{flags}, $$r{cas}, $$r{value});
    }
    else
    {
      $response .= sprintf("%-18s| %-5u |%s\n", $$r{key}, $$r{flags}, $$r{value});
    }
  }
  return $response;
}

sub stats {
  my $arg = shift;
  my %stats = $mc->stats($arg);
  my $response = "";
  $response .= sprintf("%-35s %-35s\n", $_, $stats{$_}) for keys(%stats);
  return $response;
}

sub args_err {
  my $cmd = shift;
  return sprintf("USAGE: %s %s %s %s\n",BOLD, $cmd, RESET, $help{$cmd});
}

### Run a storage command (potentially with options)
sub run_storage_cmd {
  my ($cmd, $key, $argsX) = @_;
  my ($quoted, $value, $extra, $flags, $exp_time, $cas_chk);
  ($quoted, $extra, $value) = (extract_quotelike($argsX))[0,1,5];
  if($quoted) {  # unescape any escaped quote marks
    $value =~ s/\\\"/\"/g;   #"#
    $value =~ s/\\\'/\'/g;
  }
  else {  # no quotes
    ($value, $extra) = split(" ", $argsX, 2);
  }
  return args_err($cmd) unless length($value);
  while($extra =~ m/\G\W*(\w+:)\W+(\d+)/gc) {
    $flags = $2    if $1 eq "flags:";
    $exp_time = $2 if $1 eq "expires:";
    $cas_chk = $2  if($cmd eq "replace" && $1 eq "cas:");
  }
  $mc->store($cmd, $key, $value, $flags, $exp_time, $cas_chk);
  return $mc->{error};
}

sub run_math_cmd {
  my ($cmd, $key, $delta) = @_;
  return args_err($cmd) unless length($delta) && length($key);
  return $mc->$cmd($key, $delta);
}

sub run_quit_cmd {
  exit;
}

sub run_reconnect_cmd {
  my $r = $mc->connect($host, $port);
  return ($r ? "Connected.\n" : "Connection failed.\n");
}

sub run_cmd {
  my %storage_cmds = ("set"=>1,"add"=>1,"replace"=>1,"append"=>1,"prepend"=>1);
  my %math_cmds  = ("incr"=>1,"decr"=>1);

  my ($cmd,$arg1,$argsX) = split(" ",$_,3);
   SWITCH : for(lc($cmd)) {
    $mc->{get_with_cas} = 1                      if $_ eq "gets";
    return run_get_cmd($arg1, $argsX)            if m/gets?/;
    return run_storage_cmd($_, $arg1, $argsX)    if exists $storage_cmds{$_};
    return run_math_cmd($_, $arg1, $argsX)       if exists $math_cmds{$_};
    $mc->delete($arg1), return $mc->{error}      if $_ eq "delete";
    $mc->flush(), return $mc->{error}            if $_ eq "flush_all";
    return $mc->set_flags($arg1)                 if $_ eq "flags:";
    return $mc->set_expires($arg1)               if $_ eq "expires:";
    return stats($arg1)                          if $_ eq "stats";
    return run_quit_cmd()                        if $_ eq "quit";
    return run_reconnect_cmd()                   if $_ eq "reconnect";
    return help();
  }
}


use strict;
use lib "../../../../mysql-test/lib/";
use My::Memcache;
use Getopt::Long;

my $do_flush = '';
my $do_test = '';
my $bin = '';
my $do_all = '';

GetOptions("flush"  => \$do_flush,
           "all" => \$do_all,
           "test=s" => \$do_test,
           "bin" => \$bin
          );
if($do_test == '') { $do_all = 1; }

my $mc;
if($bin) {
  $mc = My::Memcache::Binary->new();
}
else {
  $mc = My::Memcache->new();
}
my $port = 11211;

my $r = $mc->connect("localhost",$port);

if($r == 0) {
  print STDERR "DID NOT CONNECT TO MEMCACHE AT PORT $port \n";
}

# Here are some values
my $val_50 = "ABCDEFGHIJKLMNOPQRSTabcdefghijklmnopqrst123456789_";
my $val_40 = "Riga,Stockholm,Helsinki,Oslo,Copenhagen_";
my $val_100k = $val_50 x 2000;
my $val_60k  = $val_40 x 1500;
my $val_13949 = "." x 13949;

# Flush all
if($do_flush || $do_all) {
  $mc->flush();
}

# Do two inserts using ADD.  The first should succeed, the second should fail.
if($do_test=='1' || $do_all) {
  $mc->add("b:long_val_1", $val_100k)  ||  Carp::confess("Failed insert: t1");
  $mc->add("b:long_val_1", $val_100k)  &&  Carp::confess("Insert should fail: t1");
}

# Do two DELETES.  The first should succeed, the second should fail.
if($do_test=='2' || $do_all) {
  $mc->delete("b:long_val_1")  || Carp::confess("Failed delete: t2");
  $mc->delete("b:long_val_1")  && Carp::confess("Delete should fail: t2");
}

# Do an insert, then a read, then a delete, then a read
if($do_test=='3' || $do_all) {
  $mc->add("b:long_val_2", $val_100k)     || Carp::confess("Failed insert: t3");
  ($mc->get("b:long_val_2") == $val_100k) || Carp::confess("GET results unexpected: t3");
  $mc->delete("b:long_val_2")             || Carp::confess("Failed delete: t3");
  $mc->get("b:long_val_2")                && Carp::confess("GET should fail: t3");
}

# Insert using SET.  Then read.  Then attempt an ADD, which should fail.
if($do_test=='4' || $do_all) {
  # Short values
  $mc->set("b:test_short_set", "Mikrokosmos");
  ($mc->get("b:test_short_set") == "Mikrokosmos" ) || Carp::confess("GET fail");
  $mc->add("b:test_short_set", "!!") && Carp::confess("ADD should fail");

  # Long values
  $mc->set("b:test_set", $val_60k)     || Carp::confess("Failed SET as insert: t4");
  ($mc->get("b:test_set") == $val_60k) || Carp::confess("GET results unexpected: t4");
  $mc->add("b:test_set", $val_100k)    && Carp::confess("ADD should fail");
}

# UPDATE via SET
if($do_test=='5' || $do_all) {
  $mc->set("b:test_set", $val_100k)     || Carp::confess("Failed SET as update:t5");
  ($mc->get("b:test_set") == $val_100k) || Carp::confess("GET results unexpected:t5");
}

# UPDATE via SET from a long value to a short value
if($do_test=='6' || $do_all) {
  $mc->set("b:test_set", $val_40)     || Carp::confess("Failed SET as update:t6");
  ($mc->get("b:test_set") == $val_40) || Carp::confess("GET results unexpected:t6");

  # UPDATE via REPLACE
  $mc->replace("b:test_set", $val_13949) || Carp::confess("failed REPLACE");
  ($mc->get("b:test_set") == $val_13949) || Carp::confess("results unexpected");

  # REPLACE of non-existing value should fail
  $mc->replace("b:test_626", $val_60k) && Carp::confess("REPLACE should fail");
}

# UPDATE via SET from a short value to a long value
if($do_test=='7' || $do_all) {
  $mc->add("b:test7", $val_40)        || Carp::confess("Failed insert: t7");
  ($mc->get("b:test7") == $val_40)    || Carp::confess("GET results unexpected: t7");
  $mc->set("b:test7", $val_100k)      || Carp::confess("Failed update: t7");
  ($mc->get("b:test7") == $val_100k)  || Carp::confess("GET results unexpected: t7");
}

# APPEND and PREPEND tests

if($do_test=='8a' || $do_test=='8' || $do_all) {
  # Inline values
  $mc->set("test8", $val_50);
  $mc->prepend("test8", $val_40);
  $mc->append("test8", $val_40);
  my $r = $mc->get("test8");
  ($r == $val_40 . $val_50 . $val_40)  || Carp::confess("results unexpected");
  # APPEND/PREPEND to empty value should fail
  $mc->append("b:empty", $val_40)  && Carp::confess("append should fail");
  $mc->append("b:empty", $val_60k)  && Carp::confess("append should fail");
  $mc->prepend("b:empty", $val_40)  && Carp::confess("prepend should fail");
  $mc->prepend("b:empty", $val_60k)  && Carp::confess("prepend should fail");
}

if($do_test=='8b' || $do_test=='8' || $do_all) {
  # APPEND/PREPEND to empty value should fail
  $mc->append("b:empty", $val_40)  && Carp::confess("append should fail");
  $mc->prepend("b:empty", $val_40)  && Carp::confess("prepend should fail");

  # Externalizable (but short) values
  $mc->set("b:test8", $val_50);
  $mc->prepend("b:test8", $val_40);
  $mc->append("b:test8", $val_40);
  my $r1 = $mc->get("b:test8");
  ($r1 == $val_40 . $val_50 . $val_40)  || Carp::confess("results unexpected");

  # Now make it long
  $mc->append("b:test8", $val_60k) || Carp::confess("append failed");
  my $r2 = $mc->get("b:test8");
  ($r2 == $1 . $val_60k) || Carp::confess("results unexpected");

  # Prepend to a long value
  my $saying = "Elephants have trunks. ";
  $mc->prepend("b:test8", $saying) || Carp::confess("prepend failed");
  my $r3 = $mc->get("b:test8");
  ($r3 == $saying . $r2) || Carp::confess("results unexpected");

  # Now append a very large value to it
  $mc->append("b:test8", $val_100k) || Carp::confess("append failed");
  my $r4 = $mc->get("b:test8");
  ($r4 == $r3 . $val_100k) || Carp::confess("results unexpected");
}

if($do_test=='8c' || $do_test=='8' || $do_all) {
  # Take a value 1 less than a complete part, and append one character to it
  # This tests the "update-only" optimization in append
  $mc->set("b:test8c", $val_13949) || Carp::confess("set failed");
  $mc->append("b:test8c", "!");
  my $r1 = $mc->get("b:test8c");
  ($r1 == $val_13949 . "!")    ||  Carp::confess("results unexpected");
}

if($do_test=='8d' || $do_test=='8' || $do_all) {
  # Now append one more character.  This tests the "insert-only" optimization.
  $mc->append("b:test8c", "?");
  my $r2 = $mc->get("b:test8c");
  ($r2 == $val_13949 . "!?")    ||  Carp::confess("results unexpected");
}

if($do_test=='9' || $do_all) {
  # APPEND stress test
  $mc->add("b:t9", $val_50);
  for my $i (2 .. 300) {
    $mc->append("b:t9", $val_50);
    my $r = $mc->get("b:t9");
    ($r == $val_50 x $i) || Carp::confess("results unexpected");
  }
}

if($do_test=='10' || $do_all) {
  # PREPEND stress test
  $mc->add("b:t10", $val_50);
  for my $i (2 .. 300) {
    $mc->prepend("b:t10", $val_50);
    my $r = $mc->get("b:t10");
    ($r == $val_50 x $i) || Carp::confess("results unexpected");
  }
}

if($do_test=='11' || $do_all) {
  $mc->set("b:test11", $val_100k);
  $mc->replace("b:test11", "__.__");
  $mc->replace("b:test11", $val_60k);

  my $val_too_big = "x" x ((1024 * 1024) + 1);
  $mc->set("b:testtoobig", $val_too_big);
  $mc->{error} =~ "VALUE_TOO_LARGE" || Carp::confess "Expected TOO_LARGE";
}

if($do_test=='12' || $do_all) {
  # Test SET with flags
  $mc->set_flags(0);
  $mc->set("b:test12", "Mikrokosmos");
}


#!/usr/bin/perl

use strict;
use lib "../../../../mysql-test/lib/";
use My::Memcache;
use Getopt::Long;
use Carp;
use DBI;

my $do_flush = '';
my $do_test = '';
my $do_all = '';
my $create = '';
my $drop = '';
my $reconf = '';

GetOptions("flush"  => \$do_flush,
"all" => \$do_all,
"test=s" => \$do_test,
"create" => \$create,  "drop" => \$drop,  "reconf" => \$reconf
);

if($create || $drop || $reconf) {
  my $dsn = "DBI:mysql:database=ndbmemcache;host=localhost;port=3306";
  my $dbh = DBI->connect($dsn, "root", "");

  if($drop) {
    $dbh->do("DROP TABLE test_sequence");
    $dbh->do("DELETE FROM containers where db_table = 'test_sequence'");
    $dbh->do("DELETE FROM key_prefixes where key_prefix = 'seq:'");
  }

  if($create) {
    $dbh->do("CREATE TABLE test_sequence ( " .
      "      name varchar(12) PRIMARY KEY NOT NULL, " .
      "      value bigint unsigned ) ENGINE=ndbcluster");

    $dbh->do("INSERT INTO containers SET " .
      "        name = 'seq_tab', db_schema = 'ndbmemcache', " .
      "        db_table = 'test_sequence', ".
      "        key_columns = 'name', increment_column = 'value' " );

    $dbh->do("INSERT INTO key_prefixes " .
      "       VALUES(0, 'seq:', 0, 'ndb-test', 'seq_tab') ");
  }

  if($reconf) {
    $dbh->do("UPDATE memcache_server_roles " .
      "       SET update_timestamp = now() where role_id = 0");
  }
}

if ($do_all || $do_test || $do_flush) {

  my $mc = My::Memcache::Binary->new();
  my $port = 11211;

  my $r = $mc->connect("localhost",$port);

  if($r == 0) {
    print STDERR "DID NOT CONNECT TO MEMCACHE AT PORT $port \n";
  }

  # Flush all
  if($do_flush) {
    $mc->flush();
  }

  ###### TEST 1: INCR + CREATE
  if($do_all || $do_test == '1') {
    my $a = $mc->incr("seq:a", 1, 0);
    defined($a) || Carp::croak("no return from incr");
    print "$a \n";
  }

  ###### TEST 2: GET
  if($do_all || $do_test == '2') {
    my $a = $mc->get("seq:a") . "\n";
    print "$a \n";
  }

  ###### TEST 3: INCR + CREATE
  if($do_all || $do_test == '3') {
    my $a = $mc->incr("seq:b", 1, 0);
    defined($a) || Carp::croak("no return from incr");
    print "$a \n";
  }

  ###### TEST 4: INCR without create -- should be undefined
  if($do_all || $do_test == '4') {
    my $a = $mc->incr("seq:c", 1);
    defined($a) && Carp::croak("should be undefined!");
  }
}


#!/usr/bin/perl

use strict;
use lib "../../../../mysql-test/lib/";
use My::Memcache;
use Getopt::Long;
use Carp;
use DBI;

my $do_flush = '';
my $do_test = '';
my $bin = '';
my $do_all = '';
my $create = '';
my $drop = '';
my $reconf = '';

GetOptions("flush"  => \$do_flush,
           "all" => \$do_all,
           "test=s" => \$do_test,
           "bin" => \$bin,
           "create" => \$create,  "drop" => \$drop,  "reconf" => \$reconf
          );

####### CREATE TABLE for test 3.
if($create || $drop || $reconf) {
  my $dsn = "DBI:mysql:database=ndbmemcache;host=localhost;port=3306";
  my $dbh = DBI->connect($dsn, "root", "");

  if($drop) {
    $dbh->do("DROP TABLE test_long_ttl");
    $dbh->do("DELETE FROM containers where db_table = 'test_long_ttl'");
    $dbh->do("DELETE FROM key_prefixes where key_prefix like 'ttl%'");
  }

  if($create) {
    $dbh->do("CREATE TABLE test_long_ttl ( " .
      "      mkey varchar(40) PRIMARY KEY NOT NULL, " .
      "      value varchar(200),  " .
      "      expires timestamp NULL, " .
      "      flags int unsigned NULL, " .
      "      ext_id int unsigned NULL, " .
      "      ext_size int unsigned NULL ) ENGINE=ndbcluster");

    $dbh->do("INSERT INTO containers SET " .
      "        name = 'ttl1', db_schema = 'ndbmemcache', " .
      "        db_table = 'test_long_ttl', ".
      "        key_columns = 'mkey', value_columns = 'value', " .
      "        flags = 'flags', expire_time_column = 'expires', " .
      "        large_values_table = 'ndbmemcache.external_values'");

    $dbh->do("INSERT INTO containers SET " .
      "       name = 'ttl2', db_schema = 'ndbmemcache', " .
      "       db_table = 'test_long_ttl', ".
      "       key_columns = 'mkey', value_columns = 'value', " .
      "       large_values_table = 'ndbmemcache.external_values', " .
      "       flags = '1280'");

    $dbh->do("INSERT INTO key_prefixes " .
      "       VALUES(0, 'ttl:', 0, 'ndb-test', 'ttl1'), " .
      "             (0, 'ttls:', 0, 'ndb-test', 'ttl2')");
  }

  if($reconf) {
    $dbh->do("UPDATE memcache_server_roles " .
     "        SET update_timestamp = now() where role_id = 0");
  }

  exit;
}

my $mc;
if($bin) {
  $mc = My::Memcache::Binary->new();
}
else {
  $mc = My::Memcache->new();
}
my $port = 11211;

my $r = $mc->connect("localhost",$port);

if($r == 0) {
  print STDERR "DID NOT CONNECT TO MEMCACHE AT PORT $port \n";
}

# Some values
my $val_short = "Melville Tolstoy Austen Balzac ";
my $val_long  = ($val_short . " ... ") x 1500;

# Flush all
if($do_flush || $do_all) {
  $mc->flush();
}

if($do_all || $do_test == '1') {
  $mc->set("t:test", "Yello");   print $mc->{error} . "\n";
}

###### TEST 2:  Expire times with inline (SHORT) values, demo_table_tabs
if($do_all || $do_test == '2') {
  $mc->set_expires(0);    $mc->set("t:1", "Groen");  ## Will not expire
  $mc->set_expires(5);    $mc->set("t:2", "Yello");  ## Expire in 5 seconds

  sleep(2);
  ($mc->get("t:1") == "Groen")  || Carp::confess "Expected result";
  ($mc->get("t:2") == "Yello")  || Carp::confess "Expected result";

  sleep(4);
  ($mc->get("t:1") == "Groen")  || Carp::confess "Expected result";
  $mc->get("t:2")               && Carp::confess "Item should have expired";
  ($mc->{error} == "NOT_FOUND") || Carp::confess "Expected NOT_FOUND";
}

###### TEST 3: Expire times with SHORT & LONG values in a long-val table
if($do_all || $do_test == '3') {
  # Set large and small values with no expiration
  $mc->set_expires(0);
  $mc->set("ttl:one",  $val_short);
  $mc->set("ttl:two",  $val_long);

  # Set large and small values with 5 second expiration
  $mc->set_expires(5);
  $mc->set("ttl:three",  $val_short);
  $mc->set("ttl:four",   $val_long);

  sleep(2);
  my $r1 = $mc->get("ttl:one");   ($r1 == $val_short)  || Carp::confess();
  my $r2 = $mc->get("ttl:two");   ($r2 == $val_long)  || Carp::confess();
  my $r3 = $mc->get("ttl:three");   ($r3 == $val_short)  || Carp::confess();
  my $r4 = $mc->get("ttl:four");   ($r4 == $val_long)  || Carp::confess();

  sleep(4);
  my $r1 = $mc->get("ttl:one");   ($r1 == $val_short)  || Carp::confess();
  my $r2 = $mc->get("ttl:two");   ($r2 == $val_long)  || Carp::confess();
  my $r3 = $mc->get("ttl:three");   ($r3 == $val_short)  || Carp::confess();
  my $r4 = $mc->get("ttl:four");   ($r4 == $val_long)  || Carp::confess();
}

##### TEST 4:  Set flags
if($do_all || $do_test == '4') {
  $mc->set_expires(0);

  # FLAGS STORED IN DATABASE
  $mc->set_flags(100);
  $mc->set("ttl:five", $val_short);
  $mc->get("ttl:five");
  ($mc->{flags} == 100)  || Carp::confess("Expected flags = 100");

  # STATIC FLAGS
  $mc->set("ttls:six", $val_short) || Carp::confess("SET failed: " . $mc->{error});
  $mc->get("ttls:six");
  ($mc->{flags} == 1280)  || Carp::confess("Expected flags = 1280");

  $mc->delete("ttl:five");
  $mc->delete("ttls:six");

  # FLAGS STORED IN DATABASE
  $mc->set_flags(100);
  $mc->set("ttl:five", $val_long);
  $mc->get("ttl:five");
  ($mc->{flags} == 100)  || Carp::confess("Expected flags = 100");

  # STATIC FLAGS
  $mc->set("ttls:six", $val_long)  || Carp::confess("SET failed");
  $mc->get("ttls:six");
  ($mc->{flags} == 1280)  || Carp::confess("Expected flags = 1280");

}

##### TEST 5.  FLAGS in demo_table_tabs
if($do_all || $do_test == '5') {
  $mc->set_flags(100);
  $mc->set("t:12", "Con\tBrio");
  $mc->set_flags(200);
  $mc->set("t:13", "Sul ponticello");

  $mc->set_flags(0);

  $mc->get("t:12");
  ($mc->{flags} == 100)  || Carp::confess("Expected flags = 100");

  $mc->get("t:13");
  ($mc->{flags} == 200)  || Carp::confess("Expected flags = 200");
}


#!/usr/bin/perl
# -*- cperl -*-

# Copyright 2009 Sun Microsystems, Inc.
#  All rights reserved. Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

use strict;
use warnings;
use IO::File;
use File::Basename;
use File::Copy;
use File::Path;
use Cwd;

my $currentdir = getcwd();
die("You should call this script from the mysql-test/ directory")
  unless basename($currentdir) eq "mysql-test";

create_suite_from_file("../storage/ndb/test/run-test/daily-basic-tests.txt");
create_suite_from_file("../storage/ndb/test/run-test/daily-devel-tests.txt");

sub create_suite_from_file {
  my ($test_file) = @_;

  my $name = basename($test_file, ".txt");
  my $suite = "suite/$name";

  print "Reading tests from: '$test_file'...\n";
  my $F= IO::File->new($test_file)
    or die "Could not open '$test_file' for reading: $!";

  my @tests;
  my $test= {};
  while ( my $line= <$F> )
  {
    chomp($line);

    next if ( $line =~ /^#/);

    if ( $line =~ /(.*): (.*)/ )
    {
      $test->{$1} = $2;
      next;
    }

    if ( $line eq "")
    {
      create_test_name($test);
      push(@tests, $test);
      $test = {};
    }
  }
  $F = undef; # Close input file
  print "ok!\n";

  print "Creating suite '$suite' ...\n";
  if (-d $suite)
  {
    rmtree($suite)
      or die ("Could not remove old dir: '$suite', error: $!");
  }
  mkdir $suite
    or die "Could not create directory: $suite, error: $!";
  print "ok!\n";

  print "Copying my.cnf ...\n";
  my $mycnf =  dirname($test_file)."/mtr.cnf";
  print " from '$mycnf'\n";
  copy($mycnf, "$suite/my.cnf")
    or die ("Could not copy '$mycnf' to '$suite/my.cnf', error: $!");
  print "ok!\n";

  print "Generating .test files ...\n";
  foreach my $test ( @tests)
  {
    my $name = $test->{name};
    my $cmd = $test->{cmd};
    my $path = "../storage/ndb/test/ndbapi/$cmd";
    if (!-x $path)
    {
      print "Could not find: '$path', skipping it \n";
      next;
    }

    my $args = $test->{args} || "";
    my $file = "$suite/$name.test";

    my $out= IO::File->new($file, "w")
      or die "Could not open '$file' for writing: $!";

    print $out "result_format 2;\n\n";

    # DbAsyncGenerator need files created by DbCreate
    if ($cmd eq "DbAsyncGenerator")
    {
      print $out "## DbCreate\n";
      print $out "--exec ../storage/ndb/test/ndbapi/DbCreate 2>&1\n";
    }

    print $out "## $cmd $args\n";
    print $out "--exec $path $args 2>&1\n";
    print $out "exit;\n";
  }

  print "ok!\n";
}

sub create_test_name {
  my ($test) = @_;
  my $cmd = $test->{cmd} or die;
  my $args = $test->{args} || "";
  my $name= "$cmd";
  $name .= $args if $args;
  # Remove -[option]'s
  # TODO could probably remove some more junk and still get a unique name
  $name=~ s/-.//g;
  # Replace all spaces with underscore
  $name=~ s/[[:space:]]/_/g;

  $test->{name} = $name;
}


#!/usr/bin/perl -w

# Copyright (c) 2006, 2015, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301  USA

use strict;
use Getopt::Long;

sub usage
{
    print STDERR "Usage:\n";
    print STDERR "\tndb_error_reporter config.ini [username] [--fs] [--connection-timeout=#] [--skip-nodegroup=#] [--dry-scp] [--help]\n\n";
    print STDERR "\tusername is a user that you can use to ssh into\n";
    print STDERR "\t  all of your nodes with.\n\n";
    print STDERR "\t--fs means include the filesystems in the report\n";
    print STDERR "\t WARNING: This may require a lot of disk space.\n";
    print STDERR "\t          Only use this option when asked to.\n\n";
    print STDERR "\t--connection-timeout is the timeout in seconds\n";
    print STDERR "\t  to connect to a node\n\n";
    print STDERR "\t--skip-nodegroup allows you to skip all the nodes\n";
    print STDERR "\t  belonging to a specific nodegroup\n\n";
    print STDERR "\t--dry-scp allows running the script for testing without\n";
    print STDERR "\t  scp from the remote hosts\n\n";
    print STDERR "\t--help prints this message and exits\n\n";
    exit(1);
}

my $config_get_fs= 0;
my $config_connect_timeout;
my @config_skip_nodegroups;
my $config_dry_scp= 0;
my $config_help= 0;

my %options= (
    "--fs"                      => \$config_get_fs,
    "--connection-timeout=i"    => \$config_connect_timeout,
    "--skip-nodegroup=i@"       => \@config_skip_nodegroups,
    "--dry-scp"                 => \$config_dry_scp,
    "--help|usage|?"            => \$config_help,
);

GetOptions(%options) or usage();

# If --help provided, print usage and exit
if($config_help)
{
  print STDERR "This program creates an archive from data node and management node files.\n\n";
  usage();
}

# At least one positional argument must be given
# but never more than 2
if(@ARGV < 1 || @ARGV > 2)
{
  usage();
}

# First positional argument is name of the config file
my $config_file= $ARGV[0];
if(!stat($config_file))
{
    print STDERR "Cannot open configuration file.\n\n";
    usage();
}

# Second positional argument may contain scp username
my $config_scp_user= '';
if(defined($ARGV[1]))
{
  $config_scp_user.= $ARGV[1].'@';
}

use File::Basename;
my $dirname= dirname(__FILE__);
my $ndb_config= "$dirname/ndb_config";
my @nodes= split ' ',`$ndb_config --config-file=$config_file --nodes --query=nodeid --type=ndbd`;
push @nodes, split ' ',`$ndb_config --config-file=$config_file --nodes --query=nodeid --type=ndb_mgmd`;

sub config {
    my $nodeid= shift;
    my $query= shift;
    my $res= `$ndb_config --config-file=$config_file --nodeid=$nodeid --query=$query`;
    chomp $res;
    $res;
}

my @t= localtime();
my $reportdir= sprintf('ndb_error_report_%u%02u%02u%02u%02u%02u',
		       ($t[5]+1900),($t[4]+1),$t[3],$t[2],$t[1],$t[0]);

if(stat($reportdir) || stat($reportdir.'tar.bz2'))
{
    print STDERR "It looks like another ndb_error_report process is running.\n";
    print STDERR "If that is not the case, remove the ndb_error_report directory";
    print STDERR " and run ndb_error_report again.\n\n";
    exit(1);
}

mkdir($reportdir);

sub scp
{
  my ($host, $from_dir, $to_dir, $recurse) = @_;

  my $scp_options = '';
  $scp_options .= ' -p '; # Preserve times from original
  if (defined($config_connect_timeout))
  {
    $scp_options .=  " -o ConnectTimeout=$config_connect_timeout ";
  }
  if ($recurse)
  {
    $scp_options .= ' -r ';
  }

  my $cmd = "scp $scp_options $config_scp_user$host:$from_dir $to_dir";
  if ($config_dry_scp)
  {
    # --dry-scp just prints the scp command
    print $cmd, "\n";
    return;
  }
  system($cmd);
}

sub skip_nodegroup
{
  my $nodegroup= shift;
  foreach my $skip_nodegroup(@config_skip_nodegroups)
  {
    if($nodegroup eq $skip_nodegroup)
    {
      return 1;
    }
  }
  return 0;
}

foreach my $node (@nodes)
{
    my $nodegroup= config($node, 'nodegroup');
    if(skip_nodegroup($nodegroup))
    {
      print("\n\n Node $node belongs to nodegroup $nodegroup: skipping.");
      next;
    }
    print "\n\n Copying data from node $node".
	(($config_get_fs)?" with filesystem":"").
	"\n\n";

    my $from_path = "ndb_$node*"; # Copy everything starting with ndb_<nodeid>
    my $datadir = config($node,'datadir');
    if ($datadir)
    {
      # Prepend datadir
      $from_path = "$datadir/$from_path";
    }
    scp(config($node,'host'), $from_path,
	"$reportdir/", $config_get_fs);

    # Extract cluster log name from LogDestination(if any)
    foreach my $file_handler (grep(s/^FILE://i, split(/;/, config($node, 'LogDestination'))))
    {
      foreach my $file_name (grep(s/^filename=//i, split(/,/, $file_handler)))
      {
        # Check whether the file has an absolute path - otherwise the file
        # will be located in $datadir
        if (substr($file_name, 0, 1) ne '/')
        {
          $file_name = $datadir.'/'.$file_name;
        }
        print "  Copying cluster log from '$file_name' on node $node...\n";
	scp(config($node,'host'),
            "$file_name*",
	    "$reportdir/", 0);
      }
    }
}

print "\n\n Copying configuration file...\n\n\t$config_file\n\n";
system "cp -p $config_file $reportdir/";

my $r = system 'bzip2 2>&1 > /dev/null  < /dev/null';
my $outfile;
if($r==0)
{
    $outfile= "$reportdir.tar.bz2";
    system "tar cf - $reportdir|bzip2 > $outfile";
}
else
{
    $outfile= "$reportdir.tar.gz";
    system "tar cf - $reportdir|gzip > $outfile";
}

system "rm -rf $reportdir";

print "\n\nPlease attach $outfile to your error report\n\n";