lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm

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