lib/Moose/AttributeHelpers/MethodProvider/Hash.pm

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