Perl Quizに答えてみる

Perl Quizの出題者として一つくらいは新奇な解答を出さなければと思ってがんばってみるがなかなか難しい!とりあえずoverload::constant()に相当するコードを書けば何とかなるか,と思って試すもうまくいかない。
そこで更にコードをいじり倒していると…やった,失敗した!

#!perl -w
use strict;
use Test::More 'no_plan';
sub f{
  BEGIN{
    package PerlQuiz::SpecialTrue;
    sub new{
      bless {} => shift;
    }
    sub retrieve_true{
      my $true_ref = \(1==1);
      Internals::SvREADONLY($$true_ref, 0);
      $$true_ref = 1;
      Internals::SvREADONLY($$true_ref, 1);
    }
    our $in_boolify = 0;
    sub boolify{
      my($self) = @_;
      local $in_boolify = $in_boolify + 1;
      if($in_boolify == 1){
        my $i = 1;
        while(my $subname = (caller $i++)[3]){
          if($subname =~ /\b ok \z/xms){
            retrieve_true();
            return 0;
          }
        }
      }
      return 42;
    }
    no strict 'vars', 'refs';
    $OVERLOAD{dummy}++;
    *{__PACKAGE__.'::(bool'} = \&boolify;
    *{__PACKAGE__.'::()'}    = \&overload::nil;
    ${__PACKAGE__.'::()'}    = 1; # fallback
  }
  my $true_ref = \(1==1);
  Internals::SvREADONLY($$true_ref, 0);
  $$true_ref = PerlQuiz::SpecialTrue->new();
  Internals::SvREADONLY($$true_ref, 1);
}
f();
is ref(bless({}, 'Foo')), 'Foo';

実行結果:

$ perl perlquiz.pl
not ok 1
#   Failed test at ov.pl line 51.
#          got: 'Foo'
#     expected: 'Foo'
1..1
# Looks like you failed 1 test of 1.