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

Perl/Tkxを使ったGUI (2017.04.01)

背景

ActivePerlでGUI付きのプログラムを作ろうとするとTkがなくてTkxが入っています。 ActivePerlの途中のバージョンでTkからTkxに変わりました。 Tkxについて記述している日本語サイトはありません(重要)
見てくださいこの惨状→perl "tkx" - Google 検索
その理由を想像してみると、最初にTkを解説しているサイトの人はTkで書いたスクリプトが多量にありTkxに行かないし、そもそもActivePerl(Windows用)を使っていないのだろうと思います。 じゃあ後からの人達は?→最初のサイトを見てるだけ。

ウィンドウ1個にメニュー付きのサンプルコード

文字コードはUTF-8ね。
#!/usr/bin/perl -w

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

use Encode::Locale;
use Tkx;

binmode STDOUT, ":encoding(console_out)";

$| = 1;

my $mw = Tkx::widget->new(".");
menu_build($mw, [
	[ "ファイル", "F", [
		[ "メニューA...", "A", \&file_menu_a, ],
		[ "メニューB", "B", \&file_menu_b, ],
		[ "終了", "X", \&wm_delete_window, ],
	], ],
	[ "編集", "E", [
		[ "メニューC", "C", \&edit_menu_c, ],
		[ "メニューD...", "D", \&edit_menu_d, ],
		[ "メニューE", "E", \&edit_menu_e, ],
	], ],
	[ "設定", "P", [
		[ "メニューF...", "F", \&preferences_menu_f, ],
		[ "メニューG", "G", \&preferences_menu_g, ],
	], ],
]);

$mw->g_wm_title("サンプル1");
$mw->g_wm_minsize(500, 200);
$mw->g_wm_protocol(WM_DELETE_WINDOW => \&wm_delete_window);
$mw->g_wm_resizable(0, 0);

$mw->new_label(-text => "サンプル1")->g_pack(-anchor => "w");

sub my_msg($$) {
	my ($msg, $parent) = @_;
	if (!defined $parent) {
		$parent = $mw;
	}

	Tkx::tk___messageBox(
		-parent => $parent,
		-title => "メッセージ",
		-type => "ok",
		-icon => "info",
		-message => "$msg",
	);
}

Tkx::MainLoop();

exit;

sub file_menu_a {
	my_msg "メニューA", $mw;
}

sub file_menu_b {
	my_msg "メニューB", $mw;
}

sub edit_menu_c {
	my_msg "メニューC", $mw;
}

sub edit_menu_d {
	my_msg "メニューD", $mw;
}

sub edit_menu_e {
	my_msg "メニューE", $mw;
}

sub preferences_menu_f {
	my_msg "メニューF", $mw;
}

sub preferences_menu_g {
	my_msg "メニューG", $mw;
}

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);
}

sub wm_delete_window {
	$mw->g_destroy;
}