Acme::Don't 2.0!

Acme::Don'tというモジュールがある。これが提供するdon't{}は，Perl組み込みのdo{}とは逆に，ブロックの中身を実行しない。たとえば以下のコードのように使う*1。

use Acme::Don't;
don't{
  print "Hello, world!\n"; # => 実行されない
};

これは問題ない。まさにその通りで，予想通りの振る舞いといえる。しかし，don't{}を入れ子にすると話が変わってくる。

use Acme::Don't;
don't{
  don't{
    print "Hello, world!\n"; # => ???
  };
};

現状では何も実行されないが，これは予想通りの振る舞いといえるか。2重否定は肯定になってしかるべき，つまり"Hello, world!\n"を印字してしかるべきではないか。
そこで，ブロックが与えられたとき通常は実行されず，二重否定ブロックが現れたときには実行されるようなdon't{}を考えてみた。

package Acme::Don::t;
use 5.008_001; # maybe
use warnings;
use strict;
our $VERSION = '2.0';
use B ();

our $cur_pad;
sub _get_gvref{
	my($o) = @_;
	my $gv;
	if(ref($o) eq 'B::SVOP'){ # without threads
		$gv = $o->gv;
	}
	else{                     # with threads
		$gv = ($cur_pad->ARRAY)[$o->padix];
	}
	return $gv->object_2svref;
}
sub _get_cvref{
	my($o) = @_;
	my $cv = ($cur_pad->ARRAY)[$o->targ];

	return $cv->object_2svref;
}
sub B::OP::_dont{ }
sub B::UNOP::_dont{
	my($o) = @_;
	if($o->name eq 'refgen'){
		my $op_gv = $o->sibling->first;
		if(_get_gvref($op_gv) == \*don::t){
			my $op_anoncode = $o->first->first->next;
			_get_cvref($op_anoncode)->();
		}
	}
}
sub don::t(&){
	my $cv = B::svref_2object(@_);
	local $cur_pad = ($cv->PADLIST->ARRAY)[-1];
	B::walkoptree($cv->ROOT, '_dont');
	return;
}
1;
__END__

これで以下のコードが予測した通り動く。

use Acme::Don't 2.0;
don't{
  die 'not executed';
  don't{
    print "executed (1)\n";
  };
  die 'not executed';
  don't{
    print "executed (2)\n";
  };
  die 'not executed';
};

すばらしい！

*1:なお，この「'」はPerl4時代のパッケージデリミタで，「::」と同じ意味である。はてなはパッケージデリミタの「'」を認識しないらしく色分けが乱れている。