lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm

   1 package MooseX::AttributeHelpers::MethodProvider::Hash;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.12';
   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 {
  60         my $hashref = $reader->(shift);
  61         CORE::delete @{$hashref}{@_};
  62     };
  63 }
  64
  65 1;
  66
  67 __END__
  68
  69 =pod
  70
  71 =head1 NAME
  72
  73 MooseX::AttributeHelpers::MethodProvider::Hash
  74
  75 =head1 DESCRIPTION
  76
  77 This is a role which provides the method generators for
  78 L<MooseX::AttributeHelpers::Collection::Hash>.
  79
  80 This role is composed from the
  81 L<MooseX::AttributeHelpers::Collection::ImmutableHash> role.
  82
  83 =head1 METHODS
  84
  85 =over 4
  86
  87 =item B<meta>
  88
  89 =back
  90
  91 =head1 PROVIDED METHODS
  92
  93 =over 4
  94
  95 =item B<count>
  96
  97 =item B<delete>
  98
  99 =item B<empty>
 100
 101 =item B<clear>
 102
 103 =item B<exists>
 104
 105 =item B<get>
 106
 107 =item B<keys>
 108
 109 =item B<set>
 110
 111 =item B<values>
 112
 113 =item B<kv>
 114
 115 =back
 116
 117 =head1 BUGS
 118
 119 All complex software has bugs lurking in it, and this module is no
 120 exception. If you find a bug please either email me, or add the bug
 121 to cpan-RT.
 122
 123 =head1 AUTHOR
 124
 125 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 126
 127 =head1 COPYRIGHT AND LICENSE
 128
 129 Copyright 2007-2008 by Infinity Interactive, Inc.
 130
 131 L<http://www.iinteractive.com>
 132
 133 This library is free software; you can redistribute it and/or modify
 134 it under the same terms as Perl itself.
 135
 136 =cut
 137