あなたの天然記念物
ホーム更新雑談Perl鉄ゲタランドナーコースガイド自転車Linuxリンク経歴連絡先

Tkxでリストボックス (2017.04.09)

@INCをリストボックスに表示

Perlの5.26から@INCにカレントディレクトリ「.」を含まないそうです。ウチのActivePerl(5.20)は含んでいます。という訳で@INCを表示してみましょう。コンソールに出すのはつまらないのでリストボックスに入れるとこんな感じ。
実行結果

ソース

#!/usr/bin/perl -w

use utf8;
use strict;
use warnings;
use open IO => ":utf8";

use Encode::Locale;
use File::Basename;
use Tkx;
use Tkx::Scrolled;

use menu_build;

binmode STDOUT, ":encoding(cp932)";

$| = 1;

# リストボックス内の文字を等幅にするため一律でフォントを指定
Tkx::option_add("*Listbox.font", "System");

my $mw = Tkx::widget->new(".");
menu_build($mw, [
	[ "ファイル", "F", [
		[ "終了", "X", \&wm_delete_window, ],
	], ],
]);

$mw->g_wm_title("@INCを表示");
$mw->g_wm_minsize(200, 0);
$mw->g_wm_protocol(WM_DELETE_WINDOW => \&wm_delete_window);
$mw->g_wm_resizable(0, 0);

my $dialog_width = 40;
my $inc_lbx = $mw->new_tkx_Scrolled(
	"listbox",
	-selectmode => "extended",
	-scrollbars => "e",
	-width => $dialog_width,
	-height => 10,
	-activestyle => "none",
);
$inc_lbx->g_pack(-anchor => "w");

for (@INC) {
	$inc_lbx->insert("end", $_);
}

Tkx::MainLoop();

exit;



sub wm_delete_window {
	$mw->g_destroy;
}

メニュー構築モジュール

上のスクリプトのmenu_buildは別モジュールにしてありファイル名はmenu_build.pmです。

sub menu_build {
	my ($mainwindow, $tree) = @_;
	my $top = $mainwindow->new_menu;

	for (@$tree) {
		my $second = $top->new_menu( -tearoff => 0, );
		$top->add_cascade(
			-label => "${$_}[0](${$_}[1])",
			-underline => 1 + length ${$_}[0],
			-menu => $second,
		);
		for (@{${$_}[2]}) {
			my $label = ${$_}[0];
			my $label_after = "";
			my $underline = 1 + length ${$_}[0];
			if ($label =~ /\.\.\.$/) {
				$label =~ s/\.\.\.$//;
				$label_after = "...";
				$underline -= 3;
			}
			$label .= "(${$_}[1])$label_after";
			if ("CODE" eq ref ${$_}[2]) {
				$second->add_command(
					-label => $label,
					-underline => $underline,
					-command => ${$_}[2],
 				);
			} elsif ("SCALAR" eq ref ${$_}[2]) {
				$second->add_checkbutton(
					-label => $label,
					-underline => $underline,
					-variable => ${$_}[2],
					-offvalue => 0,
					-onvalue => 1,
 				);
			}
		}
	}

	$mainwindow->configure(-menu => $top);
}

1;