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

Daniel Martin <martin-+m399P62/[email protected]> Sat, 05 Feb 2005 10:42:43 -0500

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

Daniel Martin <martin-+m399P62/[email protected]> writes:

> 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.

And now I've got a variation on that that might be nice for people who
want to check the speed of their routines, and especially compare them
against others'.  (Though if the other programs have their own
time-testing code within the file itself, you'll need to strip that
out)

Anyway, run the attached program passing it a bunch of filenames, as
in:

  perl cmpit.pl fish.pl duhl.pl martin.pl

And it will then churn for a while (minimum 5 seconds per routine),
and then spit out a list of the routines sorted by speed.  The times
listed are the times to run 500 test cases.

If you give only one filename, or if you give the '-s' option, the
routines will just be labeled by the method name.  If you give more
than one filename, or the -f option, the routines will be labeled by
filename and method name, for example: "fish-look_ahead".

If you give the -c option, a comparison chart with percentage speed
differences will be printed using Benchmark::cmpthese().

cmpit.pl (text/x-perl, 2.3 KB)

#!/usr/bin/perl

use Symbol;
use Benchmark qw(timethese cmpthese);
use Getopt::Std;
use strict;
use vars qw($opt_f $opt_s $opt_c);

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

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

sub docheck {
  my (@filenames) = @_;
  my (%filehash) = ();
  my %cmphash = ();
  my @testpoints = randomtests();
  foreach my $filename (@filenames) {
    $filename =~ s/:(.*)//;
    my $subregexp = ($1 || '.*');
    $filehash{$filename} = 1;
    my ($shortfilename) = $filename;
    $shortfilename =~ s/\..*$//;
    $shortfilename =~ s/\W//;
    my $packagename = sprintf('Qotw::Test::File%s::p%04X',
                              $shortfilename, rand (1 << 31));
    $!=0; $@='';
    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 !~ /^${subregexp}$/;
      my $ref = qualify_to_ref($name, $packagename);
      next unless *{$ref}{CODE};
      my $refn = qualify($name, $packagename);
      $cmphash{"$shortfilename-$name"} =
        eval sprintf('sub { %s($_) for @testpoints; }', $refn);
    }
  }
  if ($opt_s or ( ! $opt_f and scalar(keys(%filehash)) < 2 )) {
    # shorten keynames
    my %tmpcmphash = %cmphash;
    %cmphash = ();
    for (keys %tmpcmphash) {
      /^[^-]*-(.*)/;
      $cmphash{$1} = $tmpcmphash{$_};
    }
  }
  my $timeresults = timethese(-5, \%cmphash, 'none');
  if (! $opt_c)
  {
    my $cmpresults = cmpthese($timeresults, 'none');
    my $maxlen1 = 0;
    $maxlen1 = length($_->[0])>$maxlen1 ? length($_->[0]) : $maxlen1
      for (@$cmpresults);
    my $maxlen2 = 0;
    $maxlen2 = length($_->[1])>$maxlen2 ? length($_->[1]) : $maxlen2
      for (@$cmpresults);
    printf('%*s %*s%s', -$maxlen1, $_->[0], $maxlen2, $_->[1], "\n")
      for (@$cmpresults);
  }
  else
  {
    cmpthese($timeresults);
  }
}

getopts('sfc');
docheck @ARGV;