lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm

   1 package MooseX::AttributeHelpers::MethodProvider::Hash;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.03';
   5 our $AUTHORITY = 'cpan:STEVAN';
   6
   7 with 'MooseX::AttributeHelpers::MethodProvider::ImmutableHash';
   8
   9 sub set : method {
  10     my ($attr, $reader, $writer) = @_;
  11     if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
  12         my $container_type_constraint = $attr->type_constraint->type_parameter;
  13         return sub {
  14             my ( $self, @kvp ) = @_;
  15
  16             my ( @keys, @values );
  17
  18             while ( @kvp ) {
  19                 my ( $key, $value ) = ( shift(@kvp), shift(@kvp) );
  20                 ($container_type_constraint->check($value))
  21                     || confess "Value " . ($value||'undef') . " did not pass container type constraint";
  22                 push @keys, $key;
  23                 push @values, $value;
  24             }
  25
  26             if ( @values > 1 ) {
  27                 @{ $reader->($self) }{@keys} = @values;
  28             } else {
  29                 $reader->($self)->{$keys[0]} = $values[0];
  30             }
  31         };
  32     }
  33     else {
  34         return sub {
  35             if ( @_ == 3 ) {
  36                 $reader->($_[0])->{$_[1]} = $_[2]
  37             } else {
  38                 my ( $self, @kvp ) = @_;
  39                 my ( @keys, @values );
  40
  41                 while ( @kvp ) {
  42                     push @keys, shift @kvp;
  43                     push @values, shift @kvp;
  44                 }
  45
  46                 @{ $reader->($_[0]) }{@keys} = @values;
  47             }
  48         };
  49     }
  50 }
  51
  52 sub clear : method {
  53     my ($attr, $reader, $writer) = @_;
  54     return sub { %{$reader->($_[0])} = () };
  55 }
  56
  57 sub delete : method {
  58     my ($attr, $reader, $writer) = @_;
  59     return sub { CORE::delete $reader->($_[0])->{$_[1]} };
  60 }
  61
  62 1;
  63
  64 __END__
  65
  66 =pod
  67
  68 =head1 NAME
  69
  70 MooseX::AttributeHelpers::MethodProvider::Hash
  71
  72 =head1 DESCRIPTION
  73
  74 This is a role which provides the method generators for
  75 L<MooseX::AttributeHelpers::Collection::Hash>.
  76
  77 This role is composed from the
  78 L<MooseX::AttributeHelpers::Collection::ImmutableHash> role.
  79
  80 =head1 METHODS
  81
  82 =over 4
  83
  84 =item B<meta>
  85
  86 =back
  87
  88 =head1 PROVIDED METHODS
  89
  90 =over 4
  91
  92 =item B<count>
  93
  94 =item B<delete>
  95
  96 =item B<empty>
  97
  98 =item B<clear>
  99
 100 =item B<exists>
 101
 102 =item B<get>
 103
 104 =item B<keys>
 105
 106 =item B<set>
 107
 108 =item B<values>
 109
 110 =item B<kv>
 111
 112 =back
 113
 114 =head1 BUGS
 115
 116 All complex software has bugs lurking in it, and this module is no
 117 exception. If you find a bug please either email me, or add the bug
 118 to cpan-RT.
 119
 120 =head1 AUTHOR
 121
 122 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 123
 124 =head1 COPYRIGHT AND LICENSE
 125
 126 Copyright 2007 by Infinity Interactive, Inc.
 127
 128 L<http://www.iinteractive.com>
 129
 130 This library is free software; you can redistribute it and/or modify
 131 it under the same terms as Perl itself.
 132
 133 =cut
 134