XML::Atom::Entryにカテゴリーを追加する

はてなブログAtomPub - Hatena Developer Center

サンプルコードにカテゴリーをセットする方法が書いてなかったので。

単純に、XML::Atom::Category を作って XML::Atom::Entry->category で足します。

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use XML::Atom::Entry;

my $entry = XML::Atom::Entry->new;
$entry->title('title');
$entry->content('content');

my @categories = map { my $c = XML::Atom::Category->new; $c->term($_); $c } qw(aaa bbb ccc);
$entry->category(@categories);

print $entry->as_xml;
<?xml version="1.0" encoding="UTF-8"?>
<entry xmlns="http://purl.org/atom/ns#">
  <title>title</title>
  <content mode="xml">
    <div xmlns="http://www.w3.org/1999/xhtml">content</div>
  </content>
  <category term="aaa"/>
  <category term="bbb"/>
  <category term="ccc"/>
</entry>

コードのXML::Atom::Categoryを作るところ、もっと簡単に

map { XML::Atom::Category->new(term => $_) } qw(aaa bbb ccc);

とか

map { XML::Atom::Category->new->term($_) } qw(aaa bbb ccc);

とか書きたかったんだけど、newで引数を指定してもattributeの設定は無視されるし、termメソッドは$selfを返さないし、一発で簡単に書くのはムリっぽい。面倒くさいなあ。

あと、XML::Atom::Entryのpodみても全然categoryに関する説明が書いてないし、ソースコードは抽象化されすぎてて何やってるか全然分からんし難儀したのでメモしておく。

まず、XML::Atom::EntryはXML::Atom::Thingのサブクラス、XML::Atom::ThingはXML::Atom::Baseのサブクラスです。

で、XML::Atom::Thingの中でmk_object_list_accessorを使ってcategoryメソッドを作成しているようです。

XML::Atom::Thing:

# common multiple elements
__PACKAGE__->mk_object_list_accessor('link' => 'XML::Atom::Link', 'links');
__PACKAGE__->mk_object_list_accessor('category' => 'XML::Atom::Category', 'categories');
__PACKAGE__->mk_object_list_accessor('author' => 'XML::Atom::Person', 'authors');
__PACKAGE__->mk_object_list_accessor('contributor' => 'XML::Atom::Person', 'contributors');

XML::Atom::Base:

sub mk_object_list_accessor {
    my $class = shift;
    my($name, $ext_class, $moniker) = @_;

    no strict 'refs';

    *{"$class\::$name"} = sub {
        my $obj = shift;

        my $ns_uri = $ext_class->element_ns || $obj->ns;
        if (@_) {
            # setter: clear existent elements first
            my @elem = childlist($obj->elem, $ns_uri, $name);
            for my $el (@elem) {
                $obj->elem->removeChild($el);
            }

            # add the new elements for each
            my $adder = "add_$name";
            for my $add_elem (@_) {
                $obj->$adder($add_elem);
            }
        } else {
            # getter: just call get_object which is a context aware
            return $obj->get_object($ns_uri, $name, $ext_class);
        }
    };
..

ここで、"return $obj;" とか入れてあれば楽なのに、と思うんだけど、どうなんだろうなあ。