LWPのリダイレクトを制御

LWP::RobotUA、LWP::Mixi、WWW::Mechanizeなど、LWP::UserAgentのサブクラスは、どんなURLでも勝手にリダイレクトしてしまうのだが、これを制御する方法。答えから言えばredirect_ok の挙動を変えればいいだけなのだが、これがなかなかに面倒くさい。



普通にサブクラスを作ると、利用するクラスを変えた場合にいちいちソースを直さなければならない。また、AUTOLOADを使ってラッパーを作った場合には、ラッパー側のredirect_ok を呼ばせつつ他のメソッドは継承ツリーを検索させなければならないので、ちょいと工夫が必要だ。



まず、サブクラスを作る方法。最初に書いた通り、楽をしたかったので、ここでは動的に作る方法をとっている。入力されたオブジェクトの属するパッケージに対し、〜::_RidirectWatcherと言うサブクラスを作成してインスタンス化している。

sub makeAdapter{

	my $class = shift;

	my ($Obj, $ref_func) = @_;
	croak "ParamException: not a LWP::UserAgent."

	                                if(! UNIVERSAL::isa($Obj, 'LWP::UserAgent'));
	croak "ParamException: not a CODE reference."

	                                if(ref($ref_func) ne 'CODE');
	#サブクラスの動的生成

	my $superclass = ref($Obj);

	my $subclass   = "${superclass}::_RidirectWatcher";
	$Obj->{RiderectWatcherFunction}   = $ref_func;

	$Obj->{RiderectWatcherSuperClass} = $superclass;
	{

		no strict 'refs';

		@{$subclass . '::ISA'} = ($superclass);

		*{$subclass . '::redirect_ok'} = sub {

			my $self   = shift;

			my $original_method = "$Obj->{RiderectWatcherSuperClass}::redirect_ok";

			return $Obj->{RiderectWatcherFunction}->(@_) 

			       && $self->$original_method(@_);

		}

	}
	bless $Obj, $subclass;

}

次に、AUTOLOAD を使う方法。これは会社のperl使いに作ってもらったもの。ラッパーのredirect_okを呼んでもらうために自身でLWP::UserAgentのプロパティを完全に持つことと、AUTOLOAD内で実際にメソッドを行使できるパッケージを検索するところがポイント。

sub makeAdapter{

	my $class = shift;

	my ($Obj, $ref_func) = @_;
	croak "ParamException: not a LWP::UserAgent."

	                                if(! UNIVERSAL::isa($Obj, 'LWP::UserAgent'));
	croak "ParamException: not a CODE reference."

	                                if(ref($ref_func) ne 'CODE');
	$Obj->{RiderectWatcherFunction}  = $ref_func;

	$Obj->{RiderectWatcherBaseClass} = ref($Obj);
	bless $Obj, $class;

}


sub redirect_ok{

	my $self   = shift;

	my $method = $self->{RiderectWatcherBaseClass} . '::redirect_ok';

	return $self->{RiderectWatcherFunction}->(@_) 

	       && $self->$method(@_);

}


sub AUTOLOAD {

	( my $method_name = $AUTOLOAD ) =~ s/.*:://;
	my $method =

		$_[0]->{RiderectWatcherBaseClass}->can($method_name)

		|| $_[0]->{RiderectWatcherBaseClass}->can('AUTOLOAD');

	

	goto $method if $method;

}

どっちにしろ、ハッカー冥利に尽きるここまでしなきゃならんのか的なコードですな。