Tkを使ってみる

Tkを使っていつものごとくHttpClientを作る

メインのクラス

#!C\strawberry\perl\bin\perl
#
# @autor http://d.hatena.ne.jp/panzer-jagdironscrap1/
#

use utf8;
use strict;
use PSFrame;

my $tkobj = PSFrame->new();
$tkobj->MainLoop;

呼び出されるフレームクラス

#!C\strawberry\perl\bin\perl
#
# @autor http://d.hatena.ne.jp/panzer-jagdironscrap1/
#

use utf8;
use strict;
use Tk;
use HttpClient;

package PSFrame;

our $mw;
our $txt;
our $url_ent;
our $html_txt;

sub new {

	# クラスの設定
	my $self = shift;
	$mw = MainWindow->new();
	$mw->title('パケットキャプチャー(仮)');

	# メニューバーを作る
	my $menu = $mw -> Menu( -type => "menubar" );
	$mw -> configure( -menu => $menu, -width => 300, -height => 100 );

	# [ファイル]メニューを作る

	# 日本語文字列用定数

	my $menu1 = $menu->cascade( -label => 'ファイル', -under => 0, -tearoff => 0);
	$menu1->command( -label => '開く', -under => 0);
	$menu1->command( -label => '終了', -under => 0);

	# [ツール]メニューを作る
	my $menu2 = $menu->cascade( -label => 'ツール', -under => 0, -tearoff => 0 );

	# [エンコード]項目内に文字コード変換選択をつける
	my $encode = $menu2 -> cascade(-label => 'エンコード');
	$encode -> command(-label => 'Shift_JIS', -under => 0);
	$encode -> command(-label => 'UTF-8', -under => 0);
	$encode -> command(-label => 'EUC-JP', -under => 0);

	# フレームの生成
	my $f0 = $mw->Frame();
	my $f1 = $mw->Frame();

	# フレーム $f0 にボタンを配置
	$f0->Label(
		-text => 'URL:',
		-font => [ 'Osaka', 12 ]
	)->pack( -side => 'left' );

	# URLを入れるエントリー
	$url_ent = $f0->Entry(
		-background => 'white',
		-width      => 80,
		-font       => 'Osaka 12'
	  )->pack(
		-in   => $f0,
		-fill => 'both',
		-side => 'left'
	  );

	# ボタンを押すとHttpClientが起動する
	$f0->Button(
		-text    => "GO",
		-font    => [ 'Osaka', 12 ],
		-command => \&httpclient
	)->pack( -side => 'right' );

	# フレーム $f1 にテキストコントロールを配置
	$html_txt = $f1->Text(
		-background => 'white',
		-width      => 80,
		-height     => 30,
		-wrap       => 'word',
		-font       => 'Osaka 12'
	  )->pack(
		-in   => $f1,
		-fill => 'both',
		-side => 'left',
		-expand=>'yes'
	  );

	# フレームを配置する
	$f0->pack();
	$f1->pack( -fill => 'both' );
}

sub httpclient {
	my $host_url     = $url_ent->get();
	my $httpResponse = HttpClient->new($host_url);
	$html_txt->delete( '0.0', 'end' );
	$html_txt->insert( 'end', $httpResponse );
}

1;

HTTPクライアント的な何か

#!C\strawberry\perl\bin\perl
#
# @autor http://d.hatena.ne.jp/panzer-jagdironscrap1/
#

use utf8;
use strict;
use LWP::UserAgent;

package HttpClient;

sub new {

	# コンストラクタ引数としてURLを設定する
	my ( $class, $host_url ) = @_;

	my $ua = new LWP::UserAgent;
	$ua->agent( "$0/0.1 " . $ua->agent );
	$ua->agent("Mozilla/8.0");

	# ブラウザになりすます
	my $req = new HTTP::Request 'GET' => "$host_url";
	$req->header( 'Accept' => 'text/html' );

	# リクエストを送る
	my $res = $ua->request($req);

	# 結果をチェックする
	if ( $res->is_success ) {
		return $res->content;
	}
	else {
		return "Error: " . $res->status_line . "\n";
	}
}

1;

メニューバー部分、日本語は通るけど警告が出まくってうざい