Keith C. Ivey wrote:
> I'm not unhappy, but it seems an unnecessary restriction. An
> alternative would be to change GolfScore() to something like
>
> sub GolfScore {
> my $script = shift;
> open(FF, $script) or die "error: open '$script'";
> local($/, $_);
> $_ = <FF>;
> close(FF);
> s/^#!.*?perl(.*)\n/$1/; # remove shebang except parameters
> s/\n$//; # delete final newline in file
> return length;
> }
Yes, I think that function is better than mine and I suggest
that it be used in the next (Easter?) Apocalypse to be run
by Eugene the Arbiter;-).
A quality test program is vital to a successful game.
Ideally, you would like to just say: "If it passes the test
program, it is OK". I could even envisage a 100% automated
system where you would not need a human arbiter at all.
I think it is also crucial to have a level-playing field for
all competitors. Part of that is to change as little as
possible after announcing the game; that is why I have
not rushed any changes to tsanta.pl, just tried to clarify
the semantics with workarounds. Anyway, I have just plugged
a couple of the more glaring holes in tstanta.pl (without
changing the semantics of the game).
1) I said all along that you cannot write to stderr.
The only reason it was not enforced is that I could not
figure out how to test for that under Windows 98.
I have just changed:
my $cmd = "perl $scr $intmp";
to:
# Remove ' 2>err.tmp' in next line for Windows 95/98.
my $cmd = "perl $scr $intmp 2>err.tmp";
then added:
-s 'err.tmp' and die "oops, you wrote to stderr (see err.tmp)\n";
in CheckOne().
2. I have added some code to enforce that source code is on
a single line.
sub CheckSingleLine {
my $script = shift;
local $/ = undef;
open(FF, $script) or die "error: open '$script'";
my $x = <FF>;
close(FF);
my $nlines = $x =~ tr/\n//;
--$nlines if $x =~ /^#!.*?perl/;
$nlines > 1 and die "$script: source on single line please\n";
}
plus a new and improved PrintGolfScore() function:
sub PrintGolfScore {
my @scr = @_;
my $tot = 0;
for my $s (@scr) {
CheckSingleLine($s);
my $g = GolfScore($s);
print "$s: $g\n";
$tot += $g;
}
print "You shot a round of $tot strokes.\n";
}
Apart from enforcing the single line rule, this conveniently
prints your score on each hole.
The new tsanta.pl is embedded below.
Santa.
# tsanta.pl. Santa Claus golf game test program.
use strict;
sub GolfScore {
my $script = shift;
open(FF, $script) or die "error: open '$script'";
my $golf = 0;
while (<FF>) {
chomp; next unless length;
s/^#!.*?perl// if $. == 1;
$golf += length;
}
close(FF);
return $golf;
}
sub CheckSingleLine {
my $script = shift;
local $/ = undef;
open(FF, $script) or die "error: open '$script'";
my $x = <FF>;
close(FF);
my $nlines = $x =~ tr/\n//;
--$nlines if $x =~ /^#!.*?perl/;
$nlines > 1 and die "$script: source on single line please\n";
}
sub PrintGolfScore {
my @scr = @_;
my $tot = 0;
for my $s (@scr) {
CheckSingleLine($s);
my $g = GolfScore($s);
print "$s: $g\n";
$tot += $g;
}
print "You shot a round of $tot strokes.\n";
}
sub BuildFile {
my ($fname, $data) = @_;
open(FF, '>'.$fname) or die "error: open '$fname'";
print FF $data;
close(FF);
}
sub CheckOne {
my ($scr, $label, $data, $exp) = @_;
my $intmp = 'in.tmp';
BuildFile($intmp, $data);
# Remove ' 2>err.tmp' in next line for Windows 95/98.
my $cmd = "perl $scr $intmp 2>err.tmp";
print "$label: running: '$cmd'...";
my $out = `$cmd`; my $rc = $? >> 8;
print "done (rc=$rc).\n";
-s 'err.tmp' and die "oops, you wrote to stderr (see err.tmp)\n";
if ($out ne $exp) {
warn "Expected:\n"; print STDERR $exp;
warn "Got:\n"; print STDERR $out;
die "Oops, you failed.\n";
}
}
# -----------------------------------------------------
my $file1 = <<'GROK';
1st line
GROK
my $file2 = <<'GROK';
1st line
2nd line
GROK
my $file3 = <<'GROK';
1st line
2nd line
3rd line
GROK
my $file4 = <<'GROK';
1st line
2nd line
3rd line
4th line
GROK
my $file12 = <<'GROK';
1st line
2nd line
3rd line
4th line
5th line
6th line
7th line
8th line
9th line
10th line
11th line
12th line
GROK
my $file21 = <<'GROK';
1st line
2nd line
3rd line
4th line
5th line
6th line
7th line
8th line
9th line
10th line
11th line
12th line
GROK
# -----------------------------------------------------
sub CheckHead {
my ($scr) = @_;
my @tt = (
[ 'file1', $file1, "1st line\n" ],
[ 'file2', $file2, "1st line\n2nd line\n" ],
[ 'file3', $file3, "1st line\n2nd line\n3rd line\n" ],
[ 'file12', $file12,
"1st line\n2nd line\n3rd line\n4th line\n5th line\n".
"6th line\n7th line\n8th line\n9th line\n10th line\n" ],
);
for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}
sub CheckTail {
my ($scr) = @_;
my @tt = (
[ 'file1', $file1, "1st line\n" ],
[ 'file2', $file2, "1st line\n2nd line\n" ],
[ 'file3', $file3, "1st line\n2nd line\n3rd line\n" ],
[ 'file12', $file12,
"3rd line\n4th line\n5th line\n6th line\n7th line\n".
"8th line\n9th line\n10th line\n11th line\n12th line\n" ],
[ 'file21', $file21, "12th line\n\n\n\n\n\n\n\n\n\n" ],
);
for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}
sub CheckRev {
my ($scr) = @_;
my @tt = (
[ 'file1', $file1, "1st line\n" ],
[ 'file2', $file2, "2nd line\n1st line\n" ],
[ 'file3', $file3, "3rd line\n2nd line\n1st line\n" ],
[ 'file21', $file21,
"\n\n\n\n\n\n\n\n\n12th line\n11th line\n10th line\n".
"9th line\n8th line\n7th line\n6th line\n5th line\n".
"4th line\n3rd line\n2nd line\n1st line\n" ],
);
for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}
sub CheckMid {
my ($scr) = @_;
my @tt = (
[ 'file1', $file1, "1st line\n" ],
[ 'file2', $file2, "1st line\n2nd line\n" ],
[ 'file3', $file3, "2nd line\n" ],
[ 'file4', $file4, "2nd line\n3rd line\n" ],
[ 'file12', $file12, "6th line\n7th line\n" ],
[ 'file21', $file21, "11th line\n" ],
);
for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}
sub CheckWc {
my ($scr) = @_;
my @tt = (
[ 'file1', $file1, "0000000001\n" ],
[ 'file2', $file2, "0000000002\n" ],
[ 'file3', $file3, "0000000003\n" ],
[ 'file4', $file4, "0000000004\n" ],
[ 'file12', $file12, "0000000012\n" ],
[ 'file21', $file21, "0000000021\n" ],
);
for my $r (@tt) { CheckOne($scr, $r->[0], $r->[1], $r->[2]) }
}
# -----------------------------------------------------
my $head = 'head.pl';
my $tail = 'tail.pl';
my $rev = 'rev.pl';
my $mid = 'mid.pl';
my $wc = 'wc.pl';
select(STDERR);$|=1;select(STDOUT);$|=1; # auto-flush
-f $head or die "error: file '$head' not found.\n";
-f $tail or die "error: file '$tail' not found.\n";
-f $rev or die "error: file '$rev' not found.\n";
-f $mid or die "error: file '$mid' not found.\n";
-f $wc or die "error: file '$wc' not found.\n";
PrintGolfScore($head, $tail, $rev, $mid, $wc);
CheckHead($head);
CheckTail($tail);
CheckRev($rev);
CheckMid($mid);
CheckWc($wc);
PrintGolfScore($head, $tail, $rev, $mid, $wc);
print "Hooray, you passed.\n";
