use Perl

Here's a fun bit of code that I didn't really expect to work. It flags a test as TODO only if client code indicates that it's designed for an older version of a test suite.

Background: I'm working on Test::Virtual::Filesystem, which is a collection of generic tests that exercise a filesystem with typical actions like open, read, write, stat, unlink, mkdir, etc. Users of this code will run it in a .t file to ensure that their filesystem works. But what if I change Test::Virtual::Filesystem to add a new test that breaks some filesystem published on CPAN that used to work with the old version of the test suite?

To solve this, Test::Virtual::Filesystem is written like so (trimmed heavily for readability):

use Attribute::Handlers;
use Test::More;
use base 'Test::Class';
 
sub new {
   my ($pkg, $test_dir, $compatible_version) = @_;
   my $self = $pkg->SUPER::new();
   $self->{test_dir} = $test_dir;
   $self->{compatible} = $compatible_version;
   return $self;
}
 
sub Introduced : ATTR(CODE) {
   my ($class, $symbol, $code_ref, $attr, $introduced_version) = @_;
   # Wrap the sub in a version test
   no warnings 'redefine';
   *{$symbol} = sub {
      local $TODO = $_[0]->_compatible($introduced_version);
      $code_ref->(@_);
   };
}
sub _compatible {
   my ($self, $introduced_version) = @_;
   return if !$self->{compatible};
   return if $introduced_version le $self->{compatible};
   return 'compatibility mode ' . $self->{compatible};
}
 
sub stat_dir : Test(2) : Introduced('0.02') {
   my ($self) = @_;
   ok(-e $self->{test_dir}, 'path exists');
   ok(-d $self->{test_dir}, 'path is a dir');
}

So up-to-date client code does this:

Test::Virtual::Filesystem->new('.', '0.02')->runtests;
# yields:
# ok 1 - path exists
# ok 2 - path is a dir

while old client code does this:

Test::Virtual::Filesystem->new('.', '0.01')->runtests;
# yields:
# ok 1 - path exists # TODO compatibility mode 0.01
# ok 2 - path is a dir # TODO compatibility mode 0.01