Re: [QUIZ] Perl 'Easy' Quiz #2005-2

Daniel Martin <martin-+m399P62/[email protected]> Fri, 04 Feb 2005 08:40:45 -0500

Newsgroups	gmane.comp.lang.perl.qotw.discuss
Message-ID	<[email protected]>

Rod Adams <[email protected]> writes:

> I came up with the following block to put at the head of a single
> script file to make life a little easier.

Oooh.  Nice.  I was working toward something like that, but got
distracted.

However, the attached program based on that technique might be
interesting; it's based on my check for the 'medium' quiz given a
litte ways back.

Simply run the attached program passing as arguments a filename and
(optionally) several test strings.  If you don't pass any test
strings, it'll make up 100 random test strings for you.

The tough part here was coming up with a way to check the answer that
was not a spoiler of the problem.  I /think/ I succeeded, but this was
certainly more difficult than a few attacks on the problem.

However, I'm sure someone will prove me wrong and pull out of the test
another way to solve the puzzle.

checkit.pl (text/x-perl, 1.6 KB)

#!/usr/bin/perl

use Symbol;
use strict;

sub testanswer($$) {
  my ($input, $output) = @_;
  return 0 if $output =~ /\..*\./;
  if ($input =~ /(\.[^.]*)$/)
  {
    return 0 unless $output =~ /$1$/;
  }
  $input =~ s/\.//g;
  $output =~ s/\.//g;
  return ($input eq $output);
}

my @testbits = ( ("") x 10, (".") x 30, 'a'..'z', '0'..'9', 'A'..'Z');

sub randomtests {
  my @retval = ("");
  while ($#retval < 100) {
    my $bit = $testbits[rand($#testbits)];
    if (length($bit)) {$retval[0] .= $bit;}
    else              {unshift @retval, $bit;}
  }
  shift @retval;
  return @retval;
}

sub docheck ($@) {
  my ($filename, @testpoints) = @_;
  if (! @testpoints) {@testpoints = randomtests();}
  my ($shortfilename) = $filename;
  $shortfilename =~ s/\W//;
  my ($packagename) = sprintf('Qotw::Test::File%s::p%04X',
                              $shortfilename, rand (1 << 31));
  $!=$@='';
  eval "{ package $packagename; no strict; do '$filename'; die(\$\@) if (\$\@); } ";
  if ($!) {
    print STDERR "Couldn't read $filename: $!\n";
    return 0;
  }
  if ($@) {
    print STDERR "Couldn't compile $filename: $@\n";
    return 0;
  }
  my (@keys) = eval "sort keys \%${packagename}::";
  for my $name (@keys) {
    next if $name =~ /^_/;
    my $ref = qualify_to_ref($name, $packagename);
    next unless *{$ref}{CODE};
    my $failed = 0;
    for my $input (@testpoints) {
      my $output = *{$ref}{CODE}->($input);
      if (!testanswer($input,$output)) {
        print "$name failed on $input; gave $output\n";
	$failed=1;
      }
    }
    print "$name passed all tests\n" unless $failed;
  }
}

my $file = shift;
docheck $file, @ARGV;