PerlでZIP viewer

一日かけて、Perl/Tk使って、ZIPを読み込むビューワーを作っていましたよ、と。
GDでWindows BitMapを作成する。 - 永字八法はこれのための伏線でした。

特徴は、

• 今更だけれどもPerl/Tkであること。
• Image::Magick不使用
• 二枚並べてで見開き対応
• 先読み機能一応あり

こんなところかしら。

スクリプト

use strict;
use warnings;
use utf8;
use Archive::Zip;
use GD;
use Tk;
use Jcode;

my $j = Jcode->new();

# 設定
my $long_length = 800;

-e 'temp' or mkdir 'temp';

# ランダムファイルを作成する。
my @letters = ('a'..'z');
my %random_list = ();
sub random_file {
	my $file = 'temp/';
	map { $file .= $letters[int(rand()*(scalar @letters))]; } (1..12);
	-e $file and return &random_file();
	$random_list{$file} = 1;
	return $file;
}
# 作ったランダムファイルは消しておく。
sub my_exit {
	while ( my ( $k, $v ) = each %random_list ) {
		unlink $k;
		unlink $k.'.bmp';
	}
	exit;
}

sub GD::Image::bmp {
	my $self = shift;
	my ( $w, $h ) = $self->getBounds();

	my $linelen = $w * 3;
	while ( 0 < $linelen % 4 ) { ++ $linelen; }
	my $bit = 14 + 40 + $linelen * $h;

	# BITMAPFILEHEADER
	my $res = pack("a2VvvV", "BM", $bit, 0, 0, 14 + 40);
	
	# BITMAPINFOHEADER
	$res .= pack("VVVvvVVVVVV", 40, $w, $h, 1, 24, 0, 0, 0, 0, 0, 0);

	foreach my $y ( reverse( (0..($h-1)) ) ) {
		my $line = "";
		foreach my $x ( 0..($w-1) ) {
			$line .= pack(
				"CCC", (
					reverse (
						($self->rgb(
							$self->getPixel($x, $y)
						))[0..2]
					)
				)
			);
		}
		$line .= pack("C", 0) while ( $linelen > length $line );
		$res .= $line;
	}
	return $res;
}

# ウィンドウの作成
my $top = MainWindow->new();
$top->protocol('WM_DELETE_WINDOW', \&my_exit); # 終了時の動作を規定

my $arc = $top->getOpenFile(
	-title=>'zipを指定してください。',
	-initialdir=>"L:\\[0]My eBooks"
);

# アーカイブの作成
my $zip = Archive::Zip->new($j->set($arc=>'utf8')->sjis());

# リストの取得
my %page = map {
	$_->fileName(), $_
} grep {
	!($_->fileName() =~ /\.db$/)
} $zip->members();
my @page = grep { $page{$_} } map { $_->fileName() } $zip->members();

# ボタンの作成と配置

my $zipfile = $top->Entry(
	-textvariable=>\$arc
);
$zipfile->grid(
	-row=>0,
	-column=>0,
	-columnspan=>2,
	-sticky=>'news'
);

# スクロールリスト

my $sc = $top->Listbox(
	-selectmode=>'extended'
);
sub sc2image {
	&page_change($sc->curselection()->[0]);
}

map { $sc->insert('end', $_) } @page;
$sc->bind(
	'<ButtonRelease-1>', \&sc2image
);
$sc->grid(
	-row=>0,
	-column=>2,
	-rowspan=>3,
	-sticky=>'news'
);

# スクロールバー
my $bar = $top->Scrollbar(
	-orient=>'v',
	-command=>['yview', $sc]
);
$sc->configure(-yscrollcommand=>['set', $bar]);
$bar->grid(
	-row=>0,
	-column=>3,
	-rowspan=>3,
	-sticky=>'news'
);

# 右ページの番号
my $rnum = 0;
my $rp = $top->Entry(
	-textvariable=>\$rnum
);
$rp->grid(
	-row=>1,
	-column=>1,
	-sticky=>'news'
);

# 左ページの番号
my $lnum = 1;
my $lp = $top->Entry(
	-textvariable=>\$lnum
);
$lp->grid(
	-row=>1,
	-column=>0,
	-sticky=>'news'
);

sub save_image {
	my $num = shift;
	my $ob = &load_image($num);
	
	my @t = reverse((localtime())[0..5]);
	$t[0] += 1900;
	++ $t[1];
	my $out = sprintf "%04d%02d%02d%02d%02d%02d", @t;
	$out .= '.png';
	my $im = GD::Image->new($ob->[3]);
	open ( OUT, '>'.$out );
	binmode( OUT );
	print OUT $im->png();
	close ( OUT );
}

sub save_image2 {
	my $num = shift;
	my $ob = &load_image($num);

	print $ob->[0]->redither();
}

my $num = 0;
my $rpage;
my $lpage;

sub make_image {
	my ( $r, $l ) = @_;

	$rpage = $top->Label(
		-image=>$r->[0],
		-width=>$r->[1],
		-height=>$r->[2]
	);
	$rpage->bind(
		'<ButtonRelease-1>',
		sub { &page_change($num-2); }
	);
	$rpage->bind(
		'<ButtonRelease-3>',
		sub { &save_image($num); }
	);
	$rpage->bind(
		'<Double-3>',
		sub { &save_image2($num); }
	);
	$rpage->grid(
		-row=>2,
		-column=>1,
		-sticky=>'nw'
	);

	$lpage = $top->Label(
		-image=>$l->[0],
		-width=>$l->[1],
		-height=>$l->[2]
	);
	$lpage->bind(
		'<ButtonRelease-1>',
		sub { &page_change($num+2); }
	);
	$lpage->bind(
		'<ButtonRelease-3>',
		sub { &save_image($num+1); }
	);
	$lpage->bind(
		'<Double-3>',
		sub { &save_image2($num+1); }
	);
	$lpage->grid(
		-row=>2,
		-column=>0,
		-sticky=>'ne'
	);
}

# ページ変更
sub page_change {
	$num = 0 + shift;
	$num < 0 and $num = 0;
	$num < -1 + scalar @page or $num = -2 + scalar @page;
	
	# ページ表示変更
	$rnum = $sc->get($num);
	$lnum = $sc->get($num+1);
	$sc->see($num);
	$sc->see($num+1);
	$sc->selectionClear(0, 'end');
	$sc->selectionSet($num, $num+1);
	
	# ページ削除
	$rpage and $rpage->destroy();
	$lpage and $lpage->destroy();
	
	# 実ページ変更
	my $t1 = load_image($num);
	my $t2 = load_image($num+1);
	
	# 表示
	&make_image($t1, $t2);
	$top->update();

	&look_ahead();
}

# 画像を読み込んで、ファイル名にして返す。
# 引数にページ番号を与える。
sub extract {
	my $num = shift;
	my $out = &random_file();
	# アーカイブを解凍
	$zip->extractMemberWithoutPaths($page[$num], $out);
	my $im = GD::Image->new($out); # 読み込み
	
	# サイズ取得
	my ( $ow, $oh ) = $im->getBounds();
	
	my $new;
	# 変換後サイズ決定
	my ( $cw, $ch ) = ( $ow, $oh );
	if ( $ow > 800 or $oh > 800 ) {
		if ( $ow > $oh ) {
			$cw = 800;
			$ch = int($oh * 800 / $ow);
		} else {
			$ch = 800;
			$cw = int($ow * 800 / $oh);
		}
		# 変換後画像作成
		$new = GD::Image->new($cw, $ch, 1);
		# サイズ変換コピー
		$new->copyResampled($im, 0, 0, 0, 0, $cw, $ch, $ow, $oh);
		# コピーを保存。
	} else {
		$new = $im;
	}
	my $orig = $out;
	$out .= '.bmp';
	open ( OUT, '>'.$out );
	binmode ( OUT );
	print OUT $new->bmp();
	close ( OUT );
	return ($top->Photo(-file=>$out), $cw, $ch, $orig);
}

my @loaded = ();
sub load_image {
	my $num = shift;
	$loaded[$num] ||= [extract($num)];
	return $loaded[$num];
}

page_change(0);

my $timer = $top->repeat(3000, \&look_ahead);

sub look_ahead {
	my $cursor = $num+1;
	while ( $cursor != $num ) {
		$page[$cursor] or $cursor = 0;
		if ( $loaded[$cursor] ) {
			++ $cursor;
		} else {
			&load_image($cursor);
			return;
		}
	}
	$timer->cancel();
}


MainLoop();