InPerl:WebAccess

InPerlでWebにアクセスしてあれこれやるときの便利関数群。
Webサイト/Webアプリのテストを作る/実行する時とかに便利、かも。

use YAML; # Dumpが便利。
use LWP;
use HTTP::Cookies;
use HTML::Form;
use HTML::FormatText;
use HTML::TreeBuilder;

use threads;         #以下の3つはサーバ実装のために必要。
use threads::shared;
use IO::Socket;

sub RES{
    return $res;
}

# TEXT : HTML::FormatTextを使ってページを表示。
sub TEXT{
    my $formatter = HTML::FormatText->new();
    $formatter->format(HTML::TreeBuilder->new_from_content($res->content));
}

# DISP : 適当なブラウザを使ってページを表示。
# ブラウザへの指示(``内)は適当に変更すること。
sub DISP{
    _DISP_WRITE();
    `galeon -n /tmp/DISP_temp.html`;
}

sub _DISP_WRITE{
    open(OUT,'> /tmp/DISP_temp.html');
    print OUT $res->content;
    close(OUT);
}

sub GO{
    $history = 0;
    $req = shift;
    $res = $ua->request($req);
    while($res->header('location')){
	my $req = new HTTP::Request( GET=> $res->header('location') );
	$res = $ua->request($req);
    }
    unshift(@history,$res);
    @form = HTML::Form->parse($res);
    $form = $form[0];
    SERVER_START();
}

sub HISTORY{
    my $i = 0;
    my $num = shift;
    if($num eq 'DEL'){
	undef(@history);
	unshift(@history,$res);
	return;
    }
    if(defined $num){
	$res = $history[$num];
	$req = $res->request;
	@form = HTML::Form->parse($res);
	$form = $form[0];
	$history = $num;
	return;
	SERVER_START();
    }
    foreach $res (@history){
	printf(" %1s%s: %s\n"
	       ,($i == $history)?"*":'',$i++,$res->request->uri);
    }
}

# LINK : リンクの操作
# GO と組み合わせて使う。
#  ex: GO LINK 2
#
# LINK => リンク一覧の表示
# LINK 2 => 指定された番号のリンクに対応したHTTP::Requestオブジェクトを返す。
#           マイナスを指定すれば逆順に数える。
# LINK uri => 直接uriを指定(相対/絶対)
sub LINK{
    my $uri = shift;
    unless( defined $uri ){
	my $content = $res->content;
	print " ".$res->base."\n";
	my $i = 0;
	while($content =~ /<a.*?href=([\"\'])?(.*?)\1.*?>(.*?)<\/a>/mg){
	    printf("  %s: %s [%s]\n",$i++,$2,$3);
	}
	return;
    }
    if($uri =~ /^\-?\d+$/){
	my $i = 0;
	my(@list);
	my $content = $res->content;
	while($content =~ /<a.*?href=([\"\'])?(.*?)\1.*?>(.*?)<\/a>/mg){
	    push(@list,$2);
	}
	$uri = @list[$uri];
    }
    if($uri){
	$uri = URI->new( $uri );
	$uri = $uri->abs($res->request->uri);
	return new HTTP::Request( GET=> $uri );
    }else{
	return 'no target';
    }
}

sub DISP_FORM{
    my $i = -1;
    my(@submits);
    foreach $input ($form->inputs){
	$i++;
	next if($input->type eq 'hidden');
	DISP_INPUT($input,$i);
    }
}

sub DISP_INPUT{
    my $input = shift;
    my $i     = shift;
    my($value,$note);
    if($input->type eq 'hidden'){
	$note = '(hidden) ';
    }
    if($input->possible_values){
	$value = sprintf("( %s )",
			 join (' ',
			       map { ($_ eq $input->value)? "{$_}" : $_; }
			       $input->possible_values));
    }elsif($input->type eq 'submit'){
	printf("%d   [[ %s ]]\n",$i,$input->value);
	return;
    }else{
	$value = $input->value;
    }
    printf("%d %s%s=%s\n",$i,$note,$input->name,$value);
}

# FORM : フォームの操作
# GO と組み合わせて使う。
#  ex: GO FORM 2,1
#
# FORM => 入力可能パラメータ一覧の表示。
# FORM 2 => 指定された番号のパラメータを表示
# FORM 2, 'value' => 指定された番号のパラメータを'value'に設定
#                    マイナスを指定すれば逆順に数える。
#                    但し、指定された番号のパラメータがsubmitだった場合は
#                    HTTP::Requestオブジェクトを返す。
sub FORM{
    my $n = shift;
    unless ( defined $n ){
	return DISP_FORM;
    }
    if($n >= scalar($form->inputs)){
	return 'no exist input $n';
    }

    $input = ($form->inputs)[$n];
    my $val = shift;
    unless(defined $val){
	DISP_INPUT($input,$n);
	return '';
    }
    if($input->type eq 'submit'){
	return $input->click($form);
    }
    return $input->value($val);
}

my $req : shared;
my $res : shared;

# サーバ実装：
# threadのサポートが必要。
#
# http://localhost:10080/ にアクセスすると、
# GO / HISTORY で進んだ「今見ている」ページを見ることができる。

# ものすごくRFCを無視したどうかと思うWebサーバ本体
sub SERVER{
    my $listener = IO::Socket::INET->new(Listen    => SOMAXCONN,
					 LocalPort => 10080,
					 LocalAddr => "127.0.0.1",
					 PeerAddr  => "0.0.0.0",
					 Proto     => 'tcp',
					  Reuse     => 1
                                         ) or die "create listener";
    while(1){
	$listener->listen or die;
	my $sock = $listener->accept();
	unless($sock){
	    sleep 1;
	    next;
	}
	while($line = $sock->getline()){
	    if($line =~ /X-WebAccess-InPerl-Quit:/){
		close($listener);
		close($sock);
		$end = 1;
	    }
	    last if($line =~ /^\r\n$/);
	}
	last if($end);
	my $res = RES();
	my $content = $res->content;
	my $buf = sprintf("HTTP/1.1 200 OK\r\nContent-Type: %s\r\nConnection: close\r\nContent-Length: %s\r\n\r\n%s"
			  ,($res->header('content-type'))[0]
			  ,length($content)
			  ,$content);
	$sock->syswrite($buf,length($buf));
	$sock->close;
    }
}

# ページが切り替わる度に呼ばれる。
# いちいちサーバーを落としてから立て直すのが格好悪い
sub SERVER_START{
    if($SERVER_THREAD){
	my $sock = IO::Socket::INET->new(PeerAddr => '127.0.0.1',
					 PeerPort => 10080,
					 Proto => 'tcp');
	$sock->syswrite("X-WebAccess-InPerl-Quit:\r\n");
	$sock->close;
	$SERVER_THREAD->join();

    }
    $SERVER_THREAD = threads->new(\&SERVER);
}

# コマンドラインであれこれやるためのUserAgentを作る。
$ua = new LWP::UserAgent;
$cookie_jar = HTTP::Cookies->new;
$ua->cookie_jar($cookie_jar);