Providing sugar *and* object methods in a Moose role - moose

Question

I'm working on a Moose Role that allows the consuming class to emit XML based on an 'xml_path' option specified to one or more attributes, like so:
package MooseX::Role::EmitsXML::Trait::HasXMLPath;
use Moose::Role;
has xml_path => (
'is' => 'ro',
'isa' => 'Str',
'predicate' => 'has_xml_path',
);
has 'namespace' => (
'is' => 'ro',
'isa' => 'Str',
'predicate' => 'has_namespace',
);
has 'cdata' => (
'is' => 'ro',
'isa' => 'Bool',
'predicate' => 'has_cdata',
);
package MooseX::Role::EmitsXML;
our $VERSION = '0.01';
use Moose::Role;
use namespace::autoclean;
use XML::LibXML;
use Moose::Exporter;
sub has_xml {
my ($meta, $attr_name, %opts) = #_;
$opts{'traits'} ||= [];
push #{$opts{'traits'}}, 'MooseX::Role::EmitsXML::Trait::HasXMLPath';
$meta->add_attribute($attr_name, %opts);
}
Moose::Exporter->setup_import_methods(
with_meta => [qw(has_xml)],
also => [qw/Moose/],
);
sub to_xml {
my ( $self, #args ) = #_;
my $doc = XML::LibXML::Document->new();
for my $attr ( map { $self->meta->get_attribute($_) } $self->meta->get_attribute_list ) {
my $reader = $attr->get_read_method;
if ( $attr->does('XMLPath') && $attr->has_xml_path ) {
my $val = $self->$reader();
my $path = $attr->xml_path;
my #elements = split /\//, $path;
if ( $path =~ /^\// ) { # Throw away blank
shift #elements;
}
my $previous;
while ( my $element = shift #elements ) {
my $node;
my $attrs = extract_attrs($element);
( my $node_name = $element ) =~ s/\[.+?\]//g;
if ( !$previous ) {
if ( !$doc->documentElement ) {
$doc->setDocumentElement( XML::LibXML::Element->new($node_name) );
for my $key ( keys %{$attrs} ) {
$doc->documentElement->setAttribute( $key, $attrs->{$key} );
}
}
else {
my $root1 = $doc->documentElement->nodeName;
my $root2 = $element;
if ( $root1 ne $root2 ) {
die qq{MISMATCH! Root elements do not match: "$root1" <> "$root2"};
}
}
$node = $doc->documentElement;
}
else {
($node) = #{ $previous->find(qq{./$element}) };
if ( !$node ) {
$node = XML::LibXML::Element->new($node_name);
for my $key ( keys %{$attrs} ) {
$node->setAttribute( $key, $attrs->{$key} );
}
$previous->addChild($node);
}
}
$previous = $node;
}
# $previous has become the leaf here
$previous->appendText($val);
}
}
}
sub _extract_attrs {
my $element = shift;
my #attr_strings = ($element =~ m/(\[.+?\])/); # Capture everything between [ and ].
if (scalar #attr_strings > 1) {
die q{Invalid attribute specification. Specify multiple attrs as [#attr1=val1,#attr2=val2]};
}
my %attrs;
if (#attr_strings) {
for my $string (split /,/, $attr_strings[0]) {
my ($key, $val) = ($string =~ m/\[#?\s*(\w+)\s*=\s*"(\w+)"\s*\]/);
if (!$key) {
die qq{Malformed attribute specification: "$string". Should be [key="value"] (DOUBLE QUOTES MANDATORY)\n};
}
if (exists $attrs{$key}) {
warn qq{Duplicate key "$key" in attrs};
}
$attrs{$key} = $val;
}
}
return \%attrs;
}
no Moose::Role;
1;
However, when I try to use it:
package Product;
use Moose;
use MooseX::Role::EmitsXML;
# If I comment this out, has_xml works right ($meta is passed as first argument) but I don't have to_xml() available in the
# consuming class.
#
# If I don't, I have to_xml available in the consuming class, but has_xml doesn't work right.
with 'MooseX::Role::EmitsXML';
has_xml 'description' =>
( 'is' => 'ro', 'isa' => 'Str', 'xml_path' => '/Product/DescriptiveInformation/ProductDescription' );
has_xml 'item_number' => ( 'is' => 'ro', 'isa' => 'Str', 'xml_path' => '/Product/Identifiers/ItemNumber' );
has_xml 'catalog_number' => ( 'is' => 'ro', 'isa' => 'Str', 'xml_path' => '/Product/Identifiers/CatalogNumber' );
has_xml 'upc' => ( 'is' => 'ro', 'isa' => 'Int', 'xml_path' => '/Product/Identifiers/UPC' );
has_xml 'color' => ( 'is' => 'ro', 'isa' => 'Str', 'xml_path' => '/Product/DescriptiveInformation/Color' );
has 'that_je_ne_sais_quoi' => ('is' => 'ro', 'isa' => 'Str' );
1;
package main;
use Test::Most;
use XML::LibXML;
my %product_args = (
color => 'periwinkle',
upc => 1234567890123,
item_number => 'THX-1138',
catalog_number => 'KP-1652051819',
description => q{Oh, yes. It's very nice!},
that_je_ne_sais_quoi => q{Something French. Or maybe Swahili.},
);
ok my $p = Product->new(%product_args), 'Created instance of class using role';
ok my $xml = $p->to_xml, 'Output XML';
ok my $doc = XML::LibXML::parse_string($xml), 'XML is valid (or at least parseable)';
for my $key (keys %product_args) {
my $attr = $p->meta->get_attribute($key);
if ($key ne 'that_je_ne_sais_quoi') {
ok $attr->can('has_xml_path'), qq{Predicate 'has_xml_path' present for "$key"};
ok my $path = $attr->xml_path, qq{Got an XML path for "$key"};
1;
}
}
As the comments say, if I comment out with 'MooseX::Role::EmitsXML', then has_xml gets the consuming package's metaclass as the first argument, but the consuming package doesn't have to_xml. If I uncomment it, the consuming package gets to_xml, but has_xml doesn't get the consuming package metaclass. How can I get both to_xml and the has_xml sugar?

Answer 1

Per ether, this is Not How It's Done. Instead, the Role providing with_xml needs to be defined in a separate package, and the "ultimate" Role should apply the aforementioned to the consuming class, like so:
package MooseX::Role::EmitsXML::Trait::HasXMLPath;
use Moose::Role;
has xml_path => (
'is' => 'ro',
'isa' => 'Str',
'predicate' => 'has_xml_path',
);
has 'namespace' => (
'is' => 'ro',
'isa' => 'Str',
'predicate' => 'has_namespace',
);
has 'cdata' => (
'is' => 'ro',
'isa' => 'Bool',
'predicate' => 'has_cdata',
);
package MooseX::Role::EmitsXML::ToXML;
# This package provides the to_xml() method to the consuming class
our $VERSION = '0.01';
use Moose::Role;
use namespace::autoclean;
use XML::LibXML;
sub to_xml {
my ( $self, #args ) = #_;
my $doc = XML::LibXML::Document->new();
for my $attr ( map { $self->meta->get_attribute($_) } $self->meta->get_attribute_list ) {
my $reader = $attr->get_read_method;
if ( $attr->does('MooseX::Role::EmitsXML::Trait::HasXMLPath') && $attr->has_xml_path ) {
my $val = $self->$reader();
my $path = $attr->xml_path;
my #elements = split /\//, $path;
if ( $path =~ /^\// ) { # Throw away blank
shift #elements;
}
my $previous;
while ( my $element = shift #elements ) {
my $node;
my $attrs = extract_attrs($element);
( my $node_name = $element ) =~ s/\[.+?\]//g;
if ( !$previous ) {
if ( !$doc->documentElement ) {
$doc->setDocumentElement( XML::LibXML::Element->new($node_name) );
for my $key ( keys %{$attrs} ) {
$doc->documentElement->setAttribute( $key, $attrs->{$key} );
}
}
else {
my $root1 = $doc->documentElement->nodeName;
my $root2 = $element;
if ( $root1 ne $root2 ) {
die qq{MISMATCH! Root elements do not match: "$root1" <> "$root2"};
}
}
$node = $doc->documentElement;
}
else {
($node) = #{ $previous->find(qq{./$element}) };
if ( !$node ) {
$node = XML::LibXML::Element->new($node_name);
for my $key ( keys %{$attrs} ) {
$node->setAttribute( $key, $attrs->{$key} );
}
$previous->addChild($node);
}
}
$previous = $node;
}
# $previous has become the leaf here
$previous->appendText($val);
}
}
return "$doc";
}
sub _extract_attrs {
my $element = shift;
my #attr_strings = ($element =~ m/(\[.+?\])/); # Capture everything between [ and ].
if (scalar #attr_strings > 1) {
die q{Invalid attribute specification. Specify multiple attrs as [#attr1=val1,#attr2=val2]};
}
my %attrs;
if (#attr_strings) {
for my $string (split /,/, $attr_strings[0]) {
my ($key, $val) = ($string =~ m/\[#?\s*(\w+)\s*=\s*"(\w+)"\s*\]/);
if (!$key) {
die qq{Malformed attribute specification: "$string". Should be [key="value"] (DOUBLE QUOTES MANDATORY)\n};
}
if (exists $attrs{$key}) {
warn qq{Duplicate key "$key" in attrs};
}
$attrs{$key} = $val;
}
}
return \%attrs;
}
no Moose::Role;
1;
package MooseX::Role::EmitsXML;
# This package applies the role providing to_xml to the consuming class,
# and creates the 'has_xml' sugar
use Moose::Exporter;
sub has_xml {
my ($meta, $attr_name, %opts) = #_;
$opts{'traits'} ||= [];
push #{$opts{'traits'}}, 'MooseX::Role::EmitsXML::Trait::HasXMLPath';
$meta->add_attribute($attr_name, %opts);
}
Moose::Exporter->setup_import_methods(
with_meta => [qw(has_xml)],
base_class_roles => [qw(MooseX::Role::EmitsXML::ToXML)],
);