XML::SAXで遊んだ

RSSを扱う用事があったので、普通のRSSリーダを使ってたけども、
ふと、SAXパーサを使って読み取ってみたくなったので、試した。


DOMだと全体を読み取らないとダメなので、場合によってはメモリを食べてしまう。
SAXなら上から読み取って、いくつかのタイミング(要素の始まりを読み取った、等)でメソッドを呼び出すような仕組みで、全体を読み取らないでXMLを読むことができる。
RSSの場合は、次のitemを読むのに前のitemの情報は必要ないので、
DOMみたいに全部を読み取るより、SAXで読取りつつ実行するほうが向いてるのかなーって思ったわけです。


それを利用したハンドラを書いてみたけども、
SAXは与えられた情報だけでは、今自分がどの要素(element)にいるのか、というのがわからない欠点がある。
つまり、どの要素を辿ったか、という情報を記憶しておく必要がある。
もちろん、attributeなどのその間の情報も記憶しておく必要がある。
もっとうまい方法があるのかなぁ。


XML::SAX::ElementCallbackHandler.pm

package XML::SAX::ElementCallbackHandler;
use strict;
use warnings;
use base qw(XML::SAX::Base);
use Encode;
use 5.10.1;
use constant ELEMENT_CALLBACK_KEY => 0;
use constant ELEMENT_CALLBACK_CODE => 1;

our $SOF_THRESHOLD = 255;
our $STRING_THRESHOLD = 1024*1024;

sub new{
	my $class = shift;
	my %args = @_;
	my $element_callback_array_ref = delete $args{element_callback} || [];
	my $self = $class->SUPER::new(%args);
	
	$self->{element_stack} = [];
	$self->{element_callback} = [];
	$self->{object_stack} = [];
	
	$self->_parse_element_callback_ref($element_callback_array_ref);
	
	return $self;
}

sub add_element_callback{
	my $self = shift;
	my $key = shift;
	my $val = shift;
	
	if(ref $val ne 'CODE'){
		die 'add_element_callback error. $val is not CODE reference.'
	}
	
	$key = qr/$key$/;
	
	my $index = $self->_match_element_key_index($key);
	
	if($index != -1){
		$self->{element_callback}->[$index] = $val;
	}else{
		push @{$self->{element_callback}}, [$key, $val];
	}
}

sub _parse_element_callback_ref{
	my $self = shift;
	my $array_ref = shift;
	
	if(ref $array_ref ne 'ARRAY'){
		die 'not array referense.';
	}
	
	for(my $i=0; $i<@$array_ref; $i+=2){
		$self->add_element_callback($array_ref->[$i], $array_ref->[$i+1]);
	}
}

sub _match_element_key_index{
	my $self = shift;
	my $elem = shift;
	my $pair_ref = $self->{element_callback};
	my $length = @{$pair_ref};
	for(my $i=0; $i<$length; ++$i){
		my $ref = $pair_ref->[$i];
		if($elem eq $ref->[ELEMENT_CALLBACK_KEY]){
			return $i;
		}
	}
	return -1;
}

sub _match_element_index{
	my $self = shift;
	my $elem = shift;
	my $pair_ref = $self->{element_callback};
	my $length = @{$pair_ref};
	for(my $i=0; $i<$length; ++$i){
		my $ref = $pair_ref->[$i];
		if($elem =~ $ref->[ELEMENT_CALLBACK_KEY]){
			return $i;
		}
	}
	return -1;
}

sub _get_element_callback{
	my $self = shift;
	my $elem = shift;
	my $index = $self->_match_element_index($elem);	
	return $index == -1 ? undef : $self->{element_callback}->[$index]->[ELEMENT_CALLBACK_CODE];
}

sub get_element{
	my $self = shift;
	my $arr_ref = $self->{element_stack};
	return $arr_ref->[@$arr_ref - 1];
}

sub get_element_path{
	my $self = shift;
	return '/' . join('/', @{$self->{element_stack}});
}

sub _count_element_nest{
	my $self = shift;
	return scalar @{$self->{element_stack}};
}

sub _push_element{
	my $self = shift;
	if($self->_count_element_nest > $SOF_THRESHOLD){
		die "stack over flow.";
	}
	push(@{$self->{element_stack}}, shift) if @_;
}

sub _pop_element{
	my $self = shift;
	pop(@{$self->{element_stack}});
}

sub _convert_attributes{
	my $self = shift;
	my $attr_ref = shift;

	if(ref $attr_ref ne 'HASH'){
		return {};
	}
	
	my $attr_hash = {};
	for my $attr ( values %$attr_ref ){
		$attr_hash->{$attr->{Name}} = $attr->{Value}
	}
	return $attr_hash;
}

### Overrite

sub start_element {
	my ($self, $data) = @_;
	my $elem_name = $data->{Name};
	$self->_push_element($elem_name);
	if(@{$self->{object_stack}} || $self->_get_element_callback($self->get_element_path())){
		my $attr_ref = $data->{Attributes};
		my $data_ref = XML::SAX::ElementCallbackHandler::Element->new(
			name => $elem_name,
			attributes => $self->_convert_attributes($attr_ref)
		);
		push @{$self->{object_stack}}, $data_ref;
	}
}

sub end_element {
	my ($self, $data) = @_;
	my $stacksize = @{$self->{object_stack}};
		
	if($stacksize){
		my $callback = $self->_get_element_callback( $self->get_element_path() );
		if($callback){
			$callback->($self->{object_stack}->[@{$self->{object_stack}} - 1]);
		}
		my $this_element = pop @{$self->{object_stack}};
		$stacksize = @{$self->{object_stack}};
		if($stacksize){
			my $parent_element = $self->{object_stack}->[$stacksize - 1];
			$parent_element->_add_element($this_element);
		}
	}
	
	$self->_pop_element();
}

sub characters{
	my ($self, $data) = @_;
	my $stacksize = scalar @{$self->{object_stack}};
	
	if($stacksize){
		my $element = $self->{object_stack}->[$stacksize - 1];
		$element->{data} .= $data->{Data};
		if(length $element->{data} > $STRING_THRESHOLD){
			die 'too long string.';
		}
	}

}

package XML::SAX::ElementCallbackHandler::Element;

sub new{
	my $class = shift;
	my %args = @_;
		
	return bless {
		name => delete $args{name} || die(''),
		elements => [],
		data => "",
		attributes => delete $args{attributes} || {},
		_elements_accessor => {}
	}, $class;
}

sub _add_element{
	my $self = shift;
	my $element = shift;
	if(ref $element ne __PACKAGE__){
		die "can't Element Object.";
	}
	push @{$self->{elements}}, $element;

	my $name = $element->name;
	
	if(! exists $self->{_elements_accessor}->{$name}){
		$self->{_elements_accessor}->{$name} = [];
	}
	push @{$self->{_elements_accessor}->{$name}}, $element;
}

sub attribute{
	my $self = shift;
	my $attribute_name = shift;
	return $self->{attributes}->{$attribute_name};
}

sub elements{
	my $self = shift;
	my $element_name = shift;
	my $elements_arr = $element_name ? $self->{_elements_accessor}->{$element_name} : $self->{elements};
	return @{$elements_arr};
}

sub element{
	my $self = shift;
	my $element_name = shift;
	my $element_no = shift || 0;
	my $elements_arr = $self->{_elements_accessor}->{$element_name};
	return  $elements_arr->[$element_no];
}

sub name{
	my $self = shift;
	return $self->{name};
}

sub data{
	my $self = shift;
	return $self->{data};
}

1;

動かしてみる

use strict;
use warnings;
use 5.10.1;
use utf8;
use lib qw(./lib);
use XML::SAX;
use XML::SAX::ElementCallbackHandler;

my $xml = <<'__XML__';
<?xml version="1.0" encoding="utf-8"?>
<root>
	<aaa>
		wwwwwwwwwwwwwwwwwwwwwwwwwwwwww
		<bbb>
			<aaa attr="attr_aaa">
				<bbb attr="attr_bbb">HOGE</bbb>
			</aaa>
		</bbb>
		
		<ccc attr="attr_ccc">
			<bbb>FUGA</bbb>
		</ccc>
		
		<bbb>aaa</bbb>
		<bbb>bbb</bbb>
		<bbb>ccc</bbb>
	</aaa>
</root>
__XML__

use Data::Dumper;
my $parser;
$parser = XML::SAX::ParserFactory->parser(Handler => new XML::SAX::ElementCallbackHandler(
	element_callback => [
		# <aaa>要素
		'root/aaa' => sub{
			my ($elem) = @_;
			my $bbb = $elem->elements('bbb');
			# bbb要素だけ取り出す
			for my $bbb ($elem->elements('bbb')){
				if($bbb->elements){
					say("pass"); # 子要素を持つ要素なのでpass
				}else{
					say($bbb->data);
				}
			}
			# 3番目(添え字:2)のbbb要素を取り出す
			say($elem->element('bbb', 2)->data);
		}
	]
));
$parser->parse_string($xml);
say "-----------------------------------------";


$parser = XML::SAX::ParserFactory->parser(Handler => new XML::SAX::ElementCallbackHandler(
	element_callback => [
		# <aaa>配下の<bbb>要素
		'aaa/bbb' => sub {
				my ($elem) = @_;
			if($elem->elements){
				my $aaa = $elem->element('aaa');
				say($aaa->attribute('attr'));
				my $aaa_bbb = $aaa->element('bbb');
				say($aaa_bbb->attribute('attr'));
				say($aaa_bbb->data);
			}else{
				say($elem->data);
			}
		},
	]
));
$parser->parse_string($xml);
say "-----------------------------------------";

$parser = XML::SAX::ParserFactory->parser(Handler => new XML::SAX::ElementCallbackHandler(
	element_callback => [
		# <aaa>配下にあるいくつかの要素の配下にある<bbb>要素(<aaa><bbb>は含まれない。<aaa><XXX><YYY><bbb>などが含まれる)
		'aaa/.+/bbb' => sub{
			my ($elem) = @_;
			say($elem->data);
		}
	]
));
$parser->parse_string($xml);
say "-----------------------------------------";

pass
aaa
bbb
ccc
bbb

                                                                                • -

HOGE
attr_aaa
attr_bbb
HOGE
aaa
bbb
ccc

                                                                                • -

HOGE
FUGA

                                                                                • -

まず、要素を読み取ったときのcallback関数を登録します。
callbackは要素とサブルーチンのペアで登録する必要があります。


その要素の定義はパス区切りで定義できます。
"aaa/bbb"であれば、出てきた.........要素が取り出せます。


要素の定義が被った場合、先に定義された要素のサブルーチンが使われます。
"aaa/bbb"と"bbb"の順で定義すると、"bbb"も呼ばれる可能性はありますが、
"bbb"と"aaa/bbb"の順で定義すると、"aaa/bbb"は呼ばれることはありません。("bbb"で一致してしまうので。)
なので、定義は可能な限り長く記述しましょう。


ある要素に複数同じ要素が存在した場合、その順序は保証されます。
12...9
とあれば、itemの値を順番に取得すると、1, 2, ... , 9となります。


また、要素名には正規表現が使えます。しかし、要素を取り出すときは実際の名前になります。
たとえば、...とあれば、
"item\d"でマッチングしますが、コールバックにわたってくる要素名は、
item1, item2, ... item9というようになります。


このハンドラーを使う意味がない例として、上の例でいえば"root"の要素を取ることです。
この例の場合、終端まで読み取る必要が出てくるので、SAXを使う意味がなくなります。


要素の配下にいくつかの要素といくつかの文字列(改行含む)が存在した場合、文字列のみを記録するため、見た目がおかしな状態になります。





DOMパーサを使ったほうが圧倒的にラク。(テストもされてるしね・・・)
使う日は来るのだろうか。