package MooseX::Role::Hashable; =head1 NAME MooseX::Role::Hashable - Transform the object into a hash =cut use strict; use warnings; use Moose::Role; use Set::Functional qw{difference_by setify_by}; use namespace::autoclean; =head1 VERSION Version 1.04 =cut our $VERSION = '1.04'; =head1 SYNOPSIS This module adds a single method to an object to convert it into a simple hash. This is meant to act as the inverse function of I<new>, provided nothing too crazy is going on during initialization. If the class is made immutable, the optimizer will precalculate the extracted attributes for a signifcant speed up. Example usage: package Foo; use Moose; use MooseX::Role::Hashable; has field1 => (is => 'rw'); has field2 => (is => 'ro'); has field3 => (is => 'bare'); has _field4 => (is => 'rw', init_arg => 'field4'); __PACKAGE__->meta->make_immutable; package main; my $foo = Foo->new(field1 => 'val1', field2 => 'val2', field3 => 'val3', field4 => 'val4'); $foo->as_hash; # => {field1 => 'val1', field2 => 'val2', field3 => 'val3', field4 => 'val4'} =cut do { my $package = __PACKAGE__; package Moose::Meta::Class; use Class::Method::Modifiers (); Class::Method::Modifiers::after(make_immutable => sub { my $meta = shift; my $class = $meta->name; $class->optimize_as_hash if $class->can('does') && $class->does($package); }); Class::Method::Modifiers::before(make_mutable => sub { my $meta = shift; my $class = $meta->name; $class->deoptimize_as_hash if $class->can('does') && $class->does($package); }); }; =head1 METHODS =cut =head2 as_hash Transform the object into a hash of attribute-value pairs. All attributes, including those without a reader, are extracted. Attributes whose initial arguments differ from their name will appear using the initialization argument. Attributes which can' be initialized will be ignored. Reference values will perform a shallow copy. =cut my %CLASS_TO_ATTRIBUTES; my $extract_attributes_ref = sub { return #We only want one copy of each attribute setify_by { $_->name } #Manually taverse all attributes, get_all_attributes doesn't update #with superclass changes afte subclass immutability map { my $meta = $_->meta; map { $meta->get_attribute($_) } $meta->get_attribute_list } #Make sure attribute overrides take precedence reverse $_[0]->meta->linearized_isa; }; my $extract_ignored_ref = sub { grep { ! $_->has_init_arg } @_ }; my $extract_translated_ref = sub { map { ($_->name => $_->init_arg) } grep { $_->has_init_arg && $_->init_arg ne $_->name } @_ }; my $extract_uninitialized_ref = sub { grep { ! ($_->is_required || ! $_->is_lazy && ($_->has_builder || $_->has_default)) } @_ }; my $prepare_attributes_ref = sub { my @ignored = $extract_ignored_ref->(@_); my %translated = $extract_translated_ref->(@_); my @uninitialized = $extract_uninitialized_ref->(@_); return ( [map { $_->name } @ignored], \%translated, [difference_by { $_->name } \@uninitialized, \@ignored], ) }; sub as_hash { my $self = shift; my $cached_attributes = $CLASS_TO_ATTRIBUTES{ref $self}; my ($ignored_attributes, $translated_attributes, $uninitialized_attributes) = $cached_attributes ? @{$cached_attributes}{qw{ignored translated uninitialized}} : $prepare_attributes_ref->($extract_attributes_ref->($self)) ; my %copy = %$self; $copy{$_->name} = $_->get_value($self) for grep { ! exists $copy{$_->name} } @$uninitialized_attributes; @copy{values %$translated_attributes} = delete @copy{keys %$translated_attributes}; delete @copy{@$ignored_attributes}; return \%copy; } sub optimize_as_hash { my $class = shift; #Precalculate the attributes @{$CLASS_TO_ATTRIBUTES{$class}}{qw{ ignored translated uninitialized }} = $prepare_attributes_ref->($extract_attributes_ref->($class)); $_->optimize_as_hash for $class->meta->direct_subclasses; return; } sub deoptimize_as_hash { my $class = shift; delete $CLASS_TO_ATTRIBUTES{$class}; $_->deoptimize_as_hash for $class->meta->direct_subclasses; return; } =head1 AUTHOR Aaron Cohen, C<< <aarondcohen at gmail.com> >> Special thanks to: L<Dibin Pookombil|https://github.com/dibinp> =head1 ACKNOWLEDGEMENTS This module was made possible by L<Shutterstock|http://www.shutterstock.com/> (L<@ShutterTech|https://twitter.com/ShutterTech>). Additional open source projects from Shutterstock can be found at L<code.shutterstock.com|http://code.shutterstock.com/>. =head1 BUGS Please report any bugs or feature requests to C<bug-MooseX-Role-Hashable at rt.cpan.org>, or through the web interface at L<https://github.com/aarondcohen/perl-moosex-role-hashable/issues>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc MooseX::Role::Hashable You can also look for information at: =over 4 =item * Official GitHub Repo L<https://github.com/aarondcohen/perl-moosex-role-hashable> =item * GitHub's Issue Tracker (report bugs here) L<https://github.com/aarondcohen/perl-moosex-role-hashable/issues> =item * CPAN Ratings L<http://cpanratings.perl.org/d/MooseX-Role-Hashable> =item * Official CPAN Page L<http://search.cpan.org/dist/MooseX-Role-Hashable/> =back =head1 LICENSE AND COPYRIGHT Copyright 2013,2014 Aaron Cohen. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; # End of MooseX::Role::Hashable