+m4_divert_push([PREPARE_TESTS])
+[data_in_prng () {
+ cat > my-rand.pl <<'EOF'
+# This random number generator and the test for it below are drawn
+# from Park and Miller, "Random Number Generators: Good Ones are Hard
+# to Come By", Communications of the ACM 31:10 (October 1988). It is
+# documented to function properly on systems with a 46-bit or longer
+# real significand, which includes systems that have 64-bit IEEE reals
+# (with 53-bit significand). The test should catch any systems for
+# which this is not true, in any case.
+
+our ($seed) = 1;
+sub my_rand {
+ my ($modulo) = @_;
+ my ($a) = 16807;
+ my ($m) = 2147483647;
+ my ($tmp) = $a * $seed;
+ $seed = $tmp - $m * int ($tmp / $m);
+ return $seed % $modulo;
+}
+EOF
+ cat > test-my-rand.pl <<'EOF'
+#! /usr/bin/perl
+use strict;
+use warnings;
+do 'my-rand.pl';
+my_rand (1) foreach 1...10000;
+our $seed;
+die $seed if $seed != 1043618065;
+EOF
+}
+date_in () {
+ data_in_prng
+ cat > date-in.pl << 'EOF'
+#! /usr/bin/perl
+
+use strict;
+use warnings;
+
+do 'my-rand.pl';
+
+my ($fmt_name, @templates) = @ARGV;
+
+my @dates = (#yyyy mm dd jjj HH MM SS
+ [1648, 6, 10, 162, 0, 0, 0],
+ [1680, 6, 30, 182, 4, 50, 38],
+ [1716, 7, 24, 206, 12, 31, 35],
+ [1768, 6, 19, 171, 12, 47, 53],
+ [1819, 8, 2, 214, 1, 26, 0],
+ [1839, 3, 27, 86, 20, 58, 11],
+ [1903, 4, 19, 109, 7, 36, 5],
+ [1929, 8, 25, 237, 15, 43, 49],
+ [1941, 9, 29, 272, 4, 25, 9],
+ [1943, 4, 19, 109, 6, 49, 27],
+ [1943, 10, 7, 280, 2, 57, 52],
+ [1992, 3, 17, 77, 16, 45, 44],
+ [1996, 2, 25, 56, 21, 30, 57],
+ [1941, 9, 29, 272, 4, 25, 9],
+ [1943, 4, 19, 109, 6, 49, 27],
+ [1943, 10, 7, 280, 2, 57, 52],
+ [1992, 3, 17, 77, 16, 45, 44],
+ [1996, 2, 25, 56, 21, 30, 57],
+ [2038, 11, 10, 314, 22, 30, 4],
+ [2094, 7, 18, 199, 1, 56, 51]);
+
+open (SYNTAX, '>', "$fmt_name.sps") or die "$fmt_name.sps: create: $!\n";
+print SYNTAX "SET EPOCH 1930.\n";
+print SYNTAX "DATA LIST NOTABLE FILE='$fmt_name.in'/$fmt_name 1-40 ($fmt_name).\n";
+print SYNTAX "PRINT OUTFILE='$fmt_name.out'/$fmt_name (F16.2).\n";
+print SYNTAX "EXECUTE.\n";
+close (SYNTAX);
+
+my ($fn) = "$fmt_name.in";
+open (DATA, '>', $fn) or die "$fn: create: $!\n";
+select DATA;
+for my $template (@templates) {
+ for my $date (@dates) {
+ print_date_with_template ($date, $template) for 1...10;
+ }
+}
+close (DATA);
+
+sub print_date_with_template {
+ my ($date, $template) = @_;
+ my ($year, $month, $day, $julian, $hour, $minute, $second) = @$date;
+ my ($quarter) = int (($month - 1) / 3) + 1;
+ my ($week) = int (($julian - 1) / 7) + 1;
+ my (@year_types) = ('full');
+ push (@year_types, '2digit') if $year >= 1930 && $year < 2030;
+ for my $c (split ('', $template)) {
+ if ($c eq 'd') {
+ printf (+pick ('%d', '%02d'), $day);
+ } elsif ($c eq 'm') {
+ my ($type) = pick ('arabic', 'roman', 'abbrev', 'full');
+ if ($type eq 'arabic') {
+ printf (+pick ('%d', '%02d'), $month);
+ } elsif ($type eq 'roman') {
+ my ($mmm) = ('i', 'ii', 'iii',
+ 'iv', 'v', 'vi',
+ 'vii', 'viii', 'ix',
+ 'x', 'xi', 'xii')[$month - 1];
+ print_rand_case ($mmm);
+ } elsif ($type eq 'abbrev') {
+ my ($mmm) = qw (jan feb mar apr may jun
+ jul aug sep oct nov dec)[$month - 1];
+ print_rand_case ($mmm);
+ } elsif ($type eq 'full') {
+ my ($mmm) = qw (january february march
+ april may june
+ july august september
+ october november december)[$month - 1];
+ print_rand_case ($mmm);
+ } else {
+ die;
+ }
+ } elsif ($c eq 'y') {
+ my ($type) = pick (@year_types);
+ if ($type eq '2digit') {
+ printf (+pick ('%d', '%02d'), $year % 100);
+ } elsif ($type eq 'full') {
+ print $year;
+ } else {
+ die;
+ }
+ } elsif ($c eq 'j') {
+ my ($type) = pick (@year_types);
+ if ($type eq '2digit') {
+ printf ("%02d%03d", $year % 100, $julian);
+ } elsif ($type eq 'full') {
+ printf ("%04d%03d", $year, $julian);
+ } else {
+ die;
+ }
+ } elsif ($c eq 'q') {
+ print $quarter;
+ } elsif ($c eq 'w') {
+ print $week;
+ } elsif ($c eq 'H') {
+ printf (+pick ('%d', '%02d'), $hour);
+ } elsif ($c eq 'M') {
+ printf (+pick ('%d', '%02d'), $minute);
+ } elsif ($c eq 'S') {
+ printf (+pick ('%d', '%02d'), $second);
+ } elsif ($c eq '-') {
+ print +pick (' ', '-', '.', ',', '/');
+ } elsif ($c eq ':') {
+ print +pick (' ', ':');
+ } elsif ($c eq ' ') {
+ print ' ';
+ } elsif ($c eq 'Q') {
+ maybe_print_space ();
+ print_rand_case ('q');
+ maybe_print_space ();
+ } elsif ($c eq 'W') {
+ maybe_print_space ();
+ print_rand_case ('wk');
+ maybe_print_space ();
+ } elsif ($c eq '+') {
+ print +pick ('', '-', '+');
+ } else {
+ die;
+ }
+ }
+ print "\n";
+}
+
+sub print_rand_case {
+ my ($s) = @_;
+ my ($case) = pick (qw (uc lc tc));
+ if ($case eq 'uc') {
+ print uc ($s);
+ } elsif ($case eq 'lc') {
+ print lc ($s);
+ } elsif ($case eq 'tc') {
+ print ucfirst ($s);
+ } else {
+ die;
+ }
+}
+
+sub maybe_print_space {
+ print +pick ('', ' ');
+}
+
+sub pick {
+ return $_[int (my_rand ($#_
+ + 1))];
+}
+EOF
+}
+time_in () {
+ data_in_prng
+ cat > time-in.pl << 'EOF'
+#! /usr/bin/perl
+
+use strict;
+use warnings;
+
+do 'my-rand.pl';
+
+my ($skip, $fmt_name, @templates) = @ARGV;
+
+my_rand (1) foreach 1...$skip;
+
+my @times = (# D HH MM SS
+ [ 0, 0, 0, 0.00],
+ [ 1, 4, 50, 38.68],
+ [ 5, 12, 31, 35.82],
+ [ 0, 12, 47, 53.41],
+ [ 3, 1, 26, 0.69],
+ [ 1, 20, 58, 11.19],
+ [ 12, 7, 36, 5.98],
+ [ 52, 15, 43, 49.27],
+ [ 7, 4, 25, 9.24],
+ [ 0, 6, 49, 27.89],
+ [ 20, 2, 57, 52.56],
+ [555, 16, 45, 44.12],
+ [120, 21, 30, 57.27],
+ [ 0, 4, 25, 9.98],
+ [ 3, 6, 49, 27.24],
+ [ 5, 2, 57, 52.13],
+ [ 0, 16, 45, 44.35],
+ [ 1, 21, 30, 57.32],
+ [ 10, 22, 30, 4.27],
+ [ 22, 1, 56, 51.18]);
+
+open (SYNTAX, '>', "$fmt_name.sps") or die "$fmt_name.sps: create: $!\n";
+print SYNTAX "DATA LIST NOTABLE FILE='$fmt_name.data'/$fmt_name 1-40 ($fmt_name).\n";
+print SYNTAX "PRINT OUTFILE='$fmt_name.out'/$fmt_name (F16.2).\n";
+print SYNTAX "EXECUTE.\n";
+close (SYNTAX);
+
+my ($fn) = "$fmt_name.data";
+open (DATA, '>', $fn) or die "$fn: create: $!\n";
+select DATA;
+for my $template (@templates) {
+ for my $time (@times) {
+ print_time_with_template ($time, $template) for 1...10;
+ }
+}
+close (DATA);
+
+sub print_time_with_template {
+ my ($time, $template) = @_;
+ my ($day, $hour, $minute, $second) = @$time;
+ for my $c (split ('', $template)) {
+ if ($c eq '+') {
+ print +pick ('', '-', '+');
+ } elsif ($c eq 'D') {
+ printf (+pick ('%d', '%02d'), $day);
+ $day = 0;
+ } elsif ($c eq 'H') {
+ printf (+pick ('%d', '%02d'), $hour + 24 * $day);
+ } elsif ($c eq 'M') {
+ printf (+pick ('%d', '%02d'), $minute);
+ } elsif ($c eq 'S') {
+ printf (+pick ('%.0f', '%02.0f', '%.1f', '%.2f'), $second);
+ } elsif ($c eq ':') {
+ print +pick (' ', ':');
+ } elsif ($c eq ' ') {
+ print ' ';
+ } else {
+ die;
+ }
+ }
+ print "\n";
+}
+
+sub pick {
+ return $_[int (my_rand ($#_
+ + 1)) ];
+}
+EOF
+}]
+m4_divert_pop([PREPARE_TESTS])
+
+AT_SETUP([numeric input formats])
+AT_KEYWORDS([data-in])
+data_in_prng
+AT_CHECK([$PERL test-my-rand.pl])
+AT_DATA([num-in.pl],
+[[#! /usr/bin/perl
+
+use POSIX;
+use strict;
+use warnings;
+
+do 'my-rand.pl';
+
+for my $number (0, 1, .5, .015625, 123) {
+ my ($base_exp) = floor ($number ? log10 ($number) : 0);
+ for my $offset (-3...3) {
+ my ($exponent) = $base_exp + $offset;
+ my ($fraction) = $number / 10**$offset;
+
+ permute_zeros ($fraction, $exponent);
+ }
+}
+
+sub permute_zeros {
+ my ($fraction, $exponent) = @_;
+
+ my ($frac_rep) = sprintf ("%f", $fraction);
+ my ($leading_zeros) = length (($frac_rep =~ /^(0*)/)[0]);
+ my ($trailing_zeros) = length (($frac_rep =~ /(\.?0*)$/)[0]);
+ for my $i (0...$leading_zeros) {
+ for my $j (0...$trailing_zeros) {
+ my ($trimmed) = substr ($frac_rep, $i,
+ length ($frac_rep) - $i - $j);
+ next if $trimmed eq '.' || $trimmed eq '';
+
+ permute_commas ($trimmed, $exponent);
+ }
+ }
+}
+
+sub permute_commas {
+ my ($frac_rep, $exponent) = @_;
+ permute_dot_comma ($frac_rep, $exponent);
+ my ($pos) = int (my_rand (length ($frac_rep) + 1));
+ $frac_rep = substr ($frac_rep, 0, $pos) . "," . substr ($frac_rep, $pos);
+ permute_dot_comma ($frac_rep, $exponent);
+}
+
+sub permute_dot_comma {
+ my ($frac_rep, $exponent) = @_;
+ permute_exponent_syntax ($frac_rep, $exponent);
+ if ($frac_rep =~ /[,.]/) {
+ $frac_rep =~ tr/.,/,./;
+ permute_exponent_syntax ($frac_rep, $exponent);
+ }
+}
+
+sub permute_exponent_syntax {
+ my ($frac_rep, $exponent) = @_;
+ my (@exp_reps);
+ if ($exponent == 0) {
+ @exp_reps = pick ('', 'e0', 'e-0', 'e+0', '-0', '+0');
+ } elsif ($exponent > 0) {
+ @exp_reps = pick ("e$exponent", "e+$exponent", "+$exponent");
+ } else {
+ my ($abs_exp) = -$exponent;
+ @exp_reps = pick ("e-$abs_exp", , "e-$abs_exp", "-$abs_exp");
+ }
+ permute_sign_and_affix ($frac_rep, $_) foreach @exp_reps;
+}
+
+sub permute_sign_and_affix {
+ my ($frac_rep, $exp_rep) = @_;
+ for my $prefix (pick ('', '$'),
+ pick ('-', '-$', '$-', '$-$'),
+ pick ('+', '+$', '$+', '$+$')) {
+ for my $suffix ('', '%') {
+ permute_spaces ("$prefix$frac_rep$exp_rep$suffix");
+ }
+ }
+}
+
+sub permute_spaces {
+ my ($s) = @_;
+ $s =~ s/([-+\$e%])/ $1 /g;
+ my (@fields) = split (' ', $s);
+ print join ('', @fields), "\n";
+
+ if ($#fields > 0) {
+ my ($pos) = int (my_rand ($#fields)) + 1;
+ print join ('', @fields[0...$pos - 1]);
+ print " ";
+ print join ('', @fields[$pos...$#fields]);
+ print "\n";
+ }
+}
+
+sub pick {
+ return $_[int (my_rand ($#_ + 1))];
+}
+]])
+AT_CHECK([$PERL num-in.pl > num-in.data])
+AT_DATA([num-in.sps], [dnl
+SET ERRORS=NONE.
+SET MXERRS=10000000.
+SET MXWARNS=10000000.
+DATA LIST FILE='num-in.data' NOTABLE/
+ f 1-40 (f)
+ comma 1-40 (comma)
+ dot 1-40 (dot)
+ dollar 1-40 (dollar)
+ pct 1-40 (pct)
+ e 1-40 (e).
+PRINT OUTFILE='num-in.out'/all (6f10.4).
+EXECUTE.
+])
+AT_CHECK([pspp -O format=csv num-in.sps])
+AT_CHECK([gzip -cd < $top_srcdir/tests/data/num-in.expected.gz > expout])
+AT_CHECK([cat num-in.out], [0], [expout])
+AT_CLEANUP
+