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_valerrpct = 2 ; # pct value errors 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 # note using --csvopt now to avoid quoting (windows) sub get_csvfmt1 { my $csvfmt = { fields_terminated_by => '\t', fields_enclosed_by => undef, fields_escaped_by => '\\', lines_terminated_by => '\n', csvopt => 'n', # must match above }; return $csvfmt; } sub get_csvfmt2 { my $csvfmt = { fields_terminated_by => ',', fields_enclosed_by => '"', fields_escaped_by => '\\', lines_terminated_by => '\n', csvopt => 'cqn', # must match above }; 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->{name} = "test->$test->{tag}"; $test->{statedir} = "$vardir/tmp"; $test->{csvdir} = "$vardir/tmp"; $test->{database} = "test"; if (defined($test->{verify})) { $test->{verify} =~ /^(all|pk)$/ or die "$test->{name}: bad verify option '$test->{verify}'"; } # 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 "$test->{name}: resume 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 @pkattrs = (); for my $attr (@$attrs) { push(@pkattrs, $attr) if $attr->{pk}; } if (@pkattrs) { my $pklist = join(", ", map($_->{name}, @pkattrs)); push(@txt, ",\nprimary key ($pklist)"); } $table->{pkattrs} = [ @pkattrs ]; 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, "--stats"); push(@cmd, "--input-type=csv"); push(@cmd, "--output-type=ndb"); push(@cmd, "--temperrors=100"); # using line terminator "\n" push(@cmd, "--csvopt=n"); if (defined($test->{csvfmt}{csvopt})) { push(@cmd, "--csvopt=$test->{csvfmt}{csvopt}"); } else { 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 if this is a resume if ($opts->{resumeopt}) { push(@cmd, "--resume"); } push(@cmd, "--log-level=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"); if ($test->{dumpdata}) { my $file = "$vardir/tmp/$tname.dump"; push @txt, "--disable_query_log\n"; push(@txt, "select * from $tname order by 1\ninto outfile '$file';\n"); push @txt, "--enable_query_log\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"); # we generate 8-bit ascii so use some charset accepting it push(@txt, "character set latin1\n"); push(@txt, "fields"); push(@txt, "terminated by '$fter'"); if (defined($fenc)) { push(@txt, "optionally enclosed by '$fenc'"); } push(@txt, "lines terminated by '\\n'"); 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) { if ($test->{verify} eq 'pk' && !$attr->{pk}) { next; } 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, ">:raw", $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 = myrand(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 + myrand($hi - $lo + 1); } } if ($attr->{type} eq 'smallint' && $opts->{rejectsflag} && myrand(100) < $par_valerrpct) { if ($attr->{unsigned}) { $val = $typeinfo->{max_unsigned} + 1; } elsif (myrand(2) == 0) { $val = $typeinfo->{max_signed} + 1; } else { $val = $typeinfo->{min_signed} - 1; } $opts->{rejectserrs} .= ":value"; } 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; } # floating rand 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); } if ($attr->{type} eq 'float' && $opts->{rejectsflag} && myrand(100) < $par_valerrpct) { $val = sprintf("1e%d", $hiexp + 10); $opts->{rejectserrs} .= ":value"; } 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 = 0x61 + myrand(26); } else { $x = myrand(256); } if (defined($mask)) { $x &= $mask; } if ($x == 0) { $val = $fesc.'0'; last; } if (0 && $x == 032) { # now using _O_BINARY on windows $val = $fesc.'Z'; 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; if ($len == 0 && $opts->{minlen}) { $len = $opts->{minlen}; } 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}; $opts->{minlen} = $attr->{minlen}; $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) && myrand(100) < $par_quotepct; if (!$attr->{notnull} && myrand(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} .= ":null"; } } if ($opts->{quote}) { $val = "$fenc$val$fenc"; } return $val; } sub get_pkvals { my ($table, $line) = @_; my $pkattrs = $table->{pkattrs}; my @pkvals = (); for my $attr (@$pkattrs) { my $n = $attr->{attrno}; push(@pkvals, $line->[$n]); } return [ @pkvals ]; } sub set_pkvals { my ($table, $line, $pkvals) = @_; my $pkattrs = $table->{pkattrs}; my $k = 0; for my $attr (@$pkattrs) { my $n = $attr->{attrno}; $line->[$n] = $pkvals->[$k]; $k++; } } sub gen_csvline { my ($test, $table, $opts) = @_; my $tname = get_tablename($test, $table, { ver => 0 }); my $attrs = $table->{attrs}; my $rowid = $opts->{rowid}; my $fter = $test->{csvesc}{fields_terminated_by}; my $fesc = $test->{csvesc}{fields_escaped_by}; my $lter = $test->{csvesc}{lines_terminated_by}; my @line = (); # per line $opts->{rejectserrs} = ""; for my $attr (@$attrs) { my $val = gen_csvfield($test, $table, $attr, $opts); push(@line, $val); } # if no errors from fields, create error on the row if ($opts->{rejectsflag}) { while ($opts->{rejectserrs} eq "") { if (myrand(2) == 0 && $rowid > 0) { # duplicate pk (one will be accepted, could be this one) my $oldrowid = myrand($rowid); my $oldpkvals = $opts->{pkvals}{$oldrowid}; if (defined($oldpkvals)) { set_pkvals($table, \@line, $oldpkvals); $opts->{rejectserrs} .= ":dubpk-$oldrowid"; last; } } if (myrand(2) == 0) { # too many fields my $val = $fesc.'N'; push(@line, $val); $opts->{rejectserrs} .= ":fields+1"; last; } if (myrand(2) == 0) { # too few fields pop(@line); $opts->{rejectserrs} .= ":fields-1"; last; } } } # save generated rejects ($opts->{rejectsflag} == ($opts->{rejectserrs} ne "")) or die "rejects flag=$opts->{rejectsflag} errs=$opts->{rejectserrs}"; if ($opts->{rejectsflag}) { $opts->{rejectslines}{$rowid} = [ @line, $opts->{rejectserrs} ]; } # save pk values if line not rejected if (!$opts->{rejectsflag}) { my $pkvals = get_pkvals($table, \@line); $opts->{pkvals}{$rowid} = $pkvals; } 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, ">:raw", $file) or die "$file: open for write failed: $!"; if ($test->{csvver}) { open($fhver, ">:raw", $filever) or die "$filever: open for write failed: $!"; } my $tname = get_tablename($test, $table, { ver => 0 }); my $rows = $table->{rows}; # per file $opts->{pkvals} = {}; $opts->{rejectscnt} = 0; $opts->{rejectslines} = {}; for (my $n = 0; $n < $rows; $n++) { $opts->{rowid} = $n; $opts->{rejectsflag} = 0; if ($test->{rejectsgen}) { my $rowsleft = $rows - $n; my $rejectsleft = $test->{rejectsgen} - $opts->{rejectscnt}; 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"; $opts->{rejectscnt}++; } 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: $!"; } } } if ($test->{rejectsgen}) { write_rejects($test, $table, $opts); } $test->{rejectsgen} == $opts->{rejectscnt} or die "$tname: $test->{rejectsgen} != $opts->{rejectscnt}"; close($fh) or die "$file: close after write failed: $!"; if ($test->{csvver}) { close($fhver) or die "$filever: close after write failed: $!"; } } # debug sub write_rejects { my ($test, $table, $opts) = @_; my $tname = get_tablename($test, $table, { ver => 0 }); my $file = "$vardir/tmp/$tname.genrej"; my $fh = gensym(); open($fh, ">:raw", $file) or die "$file: open for write failed: $!"; my $lines = $opts->{rejectslines}; my @rowid = sort { $a <=> $b } keys %$lines; for my $rowid (@rowid) { my $line = $lines->{$rowid}; my @out = join("\t", $rowid, @$line); print $fh @out, "\n"; } close($fh) or die "$file: close after write failed: $!"; } sub write_csvfiles { my ($test, $opts) = @_; my $tables = $test->{tables}; for my $table (@$tables) { write_csvfile($test, $table, $opts); } } 1;