PerlでXMLのフィルタリング

質問

いつもお世話になっております。Perl初心者です。

以下のサイトを参考に、XML::Parser::PerlSAX を使用して、XMLファイルをフィルタリングするプログラムを作成しようと考えています。

http://mkweb.bcgsc.ca/intranet/perlbook/pxml/ch05_01.htm

ここで、ある要素のある属性の、異なる属性値ごとに、文字データイベントを処理する方法を変えたいのですが、どのようにすればよいでしょうか。

各種SAXイベントハンドラも、XML::Handler::Subs も考えましたが、何を使えばよいか検討がつきません。よろしくお願いします。

回答No.1

_--_1l1_1_

適当。表示がくずれるので空白2文字を全角空白にしていることに注意。

use strict;
use warnings;
use feature 'say';
use XML::SAX;

my $xml = << "END";
<?xml version="1.0" encoding="utf-8" ?>
<pets>
　<pet>
　　<type>dog</type>
　　<name pos="1">Yamada</name>
　　<name pos="2">Taro</name>
　　<age>3.5</age>
　</pet>
　<pet>
　　<type>cat</type>
　　<name pos="1">Yamada</name>
　　<name pos="2">tama</name>
　　<age>1</age>
　</pet>
</pets>
END

my @target_hierarchy = qw(pets pet name);
my @work_hierarchy　 = ();
my $call_back　　　　= undef;
my $parser = XML::SAX::ParserFactory->parser( Handler => MySAXHandler->new );
$parser->parse_string($xml);

{
　　package MySAXHandler;
　　use base qw(XML::SAX::Base);

　　sub start_element {
　　　　my ( $self, $el ) = @_;
　　　　push @work_hierarchy, $el->{LocalName};
　　　　$call_back = undef;
　　　　if ( _check_hierarchy() ) {
　　　　　　if (　　exists( $el->{Attributes} )
　　　　　　　　and exists( $el->{Attributes}->{'{}pos'} )
　　　　　　　　and $el->{Attributes}->{'{}pos'}->{Value} )
　　　　　　{
　　　　　　　　my $posision = $el->{Attributes}->{'{}pos'}->{Value};
　　　　　　　　if ($posision eq '1') {
　　　　　　　　　　$call_back = \&_say_first;
　　　　　　　　}
　　　　　　　　elsif ($posision eq '2') {
　　　　　　　　　　$call_back = \&_say_second;
　　　　　　　　}
　　　　　　　　else {
　　　　　　　　　　warn 'Unknown ', $posision;
　　　　　　　　}
　　　　　 }
　　　　}
　　}

　　sub end_element {
　　　　my ( $self, $el ) = @_;
　　　　$call_back = undef;
　　　　pop @work_hierarchy;
　　}

　　sub characters {
　　　　my ($self, $data) = @_;
　　　　if ( defined $call_back ) {
　　　　　　$call_back->( $data->{Data} );
　　　　}
　　}

　　sub _check_hierarchy {
　　　　if ( $#target_hierarchy != $#work_hierarchy ) {
　　　　　　return 0;
　　　　}
　　　　else {
　　　　　　for ( my $i = 0; $i <= $#target_hierarchy; $i++ ) {
　　　　　　　　return 0 if ( $target_hierarchy[$i] ne $work_hierarchy[$i] );
　　　　　 }
　　　　　　return 1;
　　　　}
　　}

　　sub _say_first {
　　　　my $name = shift;
　　　　say "1: $name";
　　}

　　sub _say_second {
　　　　my $name = shift;
　　　　say "2: $name";
　　　　say '---';
　　}

　　1;
}

------
$ perl -w foo.pl
1: Yamada
2: Taro
---
1: Yamada
2: tama
---

お礼

ご回答ありがとうございました。
スクリプト全体をご提供いただきありがとうございます。
早期にご回答いただいたにも関わらず、メールの連絡がされず、気がついていませんでした。
自分でも無事、自己解決しました。
いただいたスクリプトも今後、研究させていただきます。