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