lib/Moose/Meta/Attribute/Native/MethodProvider/Hash.pm

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