[SPOILER] Solution to Perl 'Easy' Quiz #2005-2

As a number of you did, I included my own test harness. I only made two 
changes since the answers started rolling in, both on the test harness 
(stole Rod Adams' nifty code for finding subs, and added a few test 
cases I hadn't thought of).

Nonstandard modules used: IO::Scalar (t_ioscalar), Inline (t_inline_c), 
and Inline::Python (t_inline_py)

I had a lot of fun writing the Inline::C version. It's been ages since 
I've done anything in C. There's also an Inline::Python version.

Here are the benchmarks on my subs:
   ioscalar    6682/s
   regex3     87764/s
   chop1      88407/s
   inline_py  92773/s
   split1    113121/s
   regex2    116378/s
   regex1    243900/s
   rindex1   318317/s
   inline_c  784720/s

Cheers,

-b

#!perl -w
use strict;
no strict 'refs';
use Benchmark;

my %test = ('this.is.a.file.txt' => 'thisisafile.txt',
             'thisisafiletxt' => 'thisisafiletxt',
             'thisisafile.txt' => 'thisisafile.txt',
             '.thisisafile.txt' => 'thisisafile.txt',
             '.thisisafiletxt' => '.thisisafiletxt',
             'thisisafile.txt.' => 'thisisafiletxt.',
             'thisisafiletxt.' => 'thisisafiletxt.',
             'thisisafiletxt..' => 'thisisafiletxt.',
             '...this..is.a.file..txt' => 'thisisafile.txt',
             '' => '',
             '.' => '.',
             '..' => '.',
             );

# run tests on all subs starting with 't_'
my $failed = 0;
foreach my $str (keys %test) {
     my $orig_str = $str;
     for my $name (sort keys %::) {
         next unless *{$name}{CODE} && substr($name,0,2) eq 't_';
         my $result = *{$name}{CODE}->($str);
         if ($result ne $test{$str}) {
             print "$name failed:\n";
             print "  test string: [$str]\n";
             print "  expected:    [$test{$str}]\n";
             print "  result:      [$result]\n";
             $failed++;
         }
         if ($str ne $orig_str) {
             print "$name failed: input string modified\n";
             print "  original string: [$orig_str]\n";
             print "  modified to:     [$str]\n";
             $failed++;
         }
     }
}
print "Tests failed...not running benchmarks\n" && exit if $failed;

# run benchmarks
my $str = 'this.is.a.file.txt';
Benchmark::cmpthese(-5, {
     'regex1' => "t_regex1('$str')",
     'regex2' => "t_regex2('$str')",
     'regex3' => "t_regex3('$str')",
     'rindex1' => "t_rindex1('$str')",
     'split1' => "t_split1('$str')",
     'chop1' => "t_chop1('$str')",
     'ioscalar' => "t_ioscalar('$str')",
     'inline_c' => "t_inline_c('$str')",
     'inline_py' => "t_inline_py('$str')",
});

sub t_regex1 {
     $_ = $_[0];
     s/\.(?=.*?\..*)//g;
     return $_;
}

sub t_regex2 {
     $_ = $_[0];
     my $str = '';
     $str .= $1 while m/(.*?)\./gc;
     return $_ if !defined(pos);
     return m/\G(.*)/gcs ? "$str.$1" : $str;
}

sub t_regex3 {
     $_ = $_[0];
     my @parts = ();
     push @parts, $1 while m/(.*?)\./gc;
     return $_ if !defined(pos);
     return m/\G(.*)/gcs ? join('',@parts,".$1") : join('',@parts);
}

sub t_rindex1 {
     my $prefix = substr $_[0], 0, rindex $_[0], '.';
     $prefix =~ s/\.//g;
     return $prefix . substr $_[0], rindex $_[0], '.';
}

sub t_split1 {
     # major kludge to handle trailing dots
     my $trailing_dot = $_[0] =~ m/(\.+)$/;
     my @parts = split /\./, $_[0];
     if ($trailing_dot) {
         return join('',@parts,'.');
     }

     return @parts > 1 ? join('',@parts[0..$#parts-1],".$parts[-1]") : 
join('',@parts);
}

sub t_chop1 {
     $_ = shift;
     my $str = '';
     my $c;
     $str .= $c while ($c = chop) && $c ne '.';
     $str .= $c if $c;
     while ($c = chop) {
         next if $c eq '.';
         $str .= $c;
     }

     return scalar reverse $str;
}

sub t_ioscalar {
     my ($str,$lastline) = ('','');
     use IO::Scalar;
     $/ = '.';
     my $in_fh = new IO::Scalar \$_[0];
     my $out_fh = tie *OUT, 'IO::Scalar', \$str;
     my $trailing_dot = 0;
     while (<$in_fh>) {
         $trailing_dot = chomp;
         print OUT $lastline;
         $lastline = $_;
     }
     print OUT '.' if length($lastline) < length($_[0]) && !$trailing_dot;
     print OUT $lastline;
     print OUT '.' if $trailing_dot;

     return $str;
}

sub t_inline_c {
     use Inline C => <<'[END]';

     char* rmdots_c(char* str) {
         char* newstr = malloc(strlen(str));

         /* find rightmost dot in string */
         int i = 0;
         int j = 0;
         int rdot = -1;
         int numdots = 0;
         while (str[i]) {
             if (str[i] == '.') {
                 rdot = i;
                 numdots++;
             }
             else {
                 newstr[j++] = str[i];
             }
             i++;
         }
         if (!numdots) { return str; } /* no dots, so we're done */

         /* copy string from rightmost dot on */
         strcpy(newstr + rdot - (numdots - 1), str + rdot);

         return newstr;

         /* or we could play nice and do this, which is slower:
         return realloc(newstr, j);
         */
     }
[END]

     return rmdots_c($_[0]);
}

sub t_inline_py {
     use Inline Python => <<'[END]';
def rmdots_py(str):
     rdot = str.rfind('.')
     if rdot == -1: return str  # no dots #
     return str[:rdot].replace('.','') + str[rdot:]
[END]

     return rmdots_py($_[0]);
}