ID3v2(mp3のタグ)を読む

このツイートを見て

CPANにID3を扱うモジュールがいくつもあるので自分が使えそうなのを選びました。
MP3::Info - Manipulate / fetch info from MP3 audio files - metacpan.org

タイトルに「編集」とありますが表示だけです(^^ゞ

コードにコメントしましたがEncode::Guessの記述だけで回避してます。 MP3::InfoがmainパッケージにあるEncode::Guessで指定された文字コードに依存して自動変換しているようです。

こんな感じです。例によって日本では希少なPerl/Tkxで書いてあります。

#!/usr/bin/env perl -w

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

use Data::Dumper;
use DateTime;
use DateTime::Format::Strptime;
use Encode::Argv;
use Encode::Locale;
use Encode::Guess qw/cp932 utf8/; # MP3::Infoが変換に使う
use File::Basename;
use FindBin;
use IO::File;
use MP3::Info;
use Tkx;
use Tkx::Scrolled;

use lib $FindBin::Bin;
use TkxMenuBuild;
use TkxMsgBox;

use constant FONT_NAME => "ＭＳ ゴシック";

binmode STDIN, ":encoding(console_in)";
binmode STDOUT, ":encoding(console_out)";

$| = 1;

# リストボックス内の文字を等幅にするため一律でフォントを指定
my $font_size = 11;
my $item_font = [FONT_NAME, $font_size, 'normal', ];
Tkx::option_add("*Listbox.font", $item_font);

my $mw = Tkx::widget->new(".");
TkxMenuBuild->new($mw,
[
	[ "ファイル", "F", [
		[ "mp3を開く", "O", \&file_open, ],
		[ "終了", "X", \&wm_delete_window, ],
	], ],
]);

$mw->g_wm_title("ｍｐ３タグ編集");
$mw->g_wm_minsize(0, 0);
$mw->g_wm_protocol(WM_DELETE_WINDOW => \&wm_delete_window);
$mw->g_wm_resizable(0, 0);
$mw->new_label(
	-text => "タグ　　　　　　　　　　　内容",
	-font => $item_font,
)->g_pack(-anchor => "w");
my $mp3tag_lbx = $mw->new_tkx_Scrolled(
	"listbox",
	-selectmode => "extended",
	-scrollbars => "e",
	-width => 24 + 1 + 60,
	-height => 10,
	-activestyle => "none",
);
$mp3tag_lbx->g_pack(-anchor => "w");

my %mp3tag;

Tkx::MainLoop();

exit;

sub file_open {
	my $temp_mp3 = Tkx::tk___getOpenFile(
		-defaultextension => "*.mp3",
		-filetypes => [
			["ｍｐ３ファイル", [".mp3",]],
			["すべてのファイル", [".*",]],
		],
		-title => "ｍｐ３を選択してください",
	);
	if ($temp_mp3) {
		load_mp3($temp_mp3);
		update_lbx();
	}
}

sub update_lbx {
	my $cursor = $mp3tag_lbx->index("active");
	$mp3tag_lbx->delete(0, "end");

	$mp3tag_lbx->insert("end", line_format($_, $mp3tag{$_})) for sort keys %mp3tag;

	$mp3tag_lbx->activate($cursor) if "" ne $cursor;
}

sub line_format {
	my ($tag, $value) = @_;

	$value = $value // "-";

	return sprintf "%24s %s", $tag, $value;
}

sub load_mp3 {
	my ($mp3_file) = @_;

	my $mp3tag = get_mp3tag(Encode::encode locale_fs => $mp3_file);

	%mp3tag = ();
	for (keys %{$mp3tag}) {
		$mp3tag{$_} = $mp3tag->{$_};
	}
}

sub wm_delete_window {
	$mw->g_destroy;
}

Perl/Tkxでよく使う処理をモジュールにしてあります。

１つ目は、階層を配列にして渡すとメニューを構築するモジュールです。

package TkxMenuBuild;

use utf8;
use strict;
use warnings;

sub new {
	my $class = shift;
	my $self = {};
	bless $self, $class;

	menu_build(@_);
}

sub menu_build_sub {
	my ($parent, $tree) = @_;

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

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

	for (@$tree) {
		my $submenu = $parent->new_menu( -tearoff => 0, );
		$parent->add_cascade(
			-label => "${$_}[0](${$_}[1])",
			-underline => 1 + length ${$_}[0],
			-menu => $submenu,
		);
		for (@{${$_}[2]}) {
			menu_build_sub($submenu, $_);
		}
	}

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

1;

２つ目はメッセージボックスです。

use utf8;
use strict;
use warnings;

sub TkxMsgBox($) {
	my ($msg) = @_;

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

1;